darcs 2.8.5 → 2.10.0
raw patch · 772 files changed
+62843/−39258 lines, 772 filesdep +attoparsecdep +base16-bytestringdep +binarydep −cmdlibdep −extensible-exceptionsdep −hashed-storagedep ~HTTPdep ~HUnitdep ~QuickChecksetup-changednew-uploaderbinary-addedPVP ok
version bump matches the API change (PVP)
Dependencies added: attoparsec, base16-bytestring, binary, cmdargs, cryptohash, darcs, data-ordlist, dataenc, deepseq, hashable, lcs, old-locale, regex-applicative, regex-compat-tdfa, shelly, split, time, transformers, transformers-compat, zip-archive
Dependencies removed: cmdlib, extensible-exceptions, hashed-storage, network-uri, regex-compat, regex-posix, shellish
Dependency ranges changed: HTTP, HUnit, QuickCheck, Win32, array, base, bytestring, containers, directory, filepath, haskeline, mmap, mtl, network, old-time, parsec, process, random, tar, test-framework, test-framework-hunit, test-framework-quickcheck2, text, unix, unix-compat, utf8-string, vector, zlib
API changes (from Hackage documentation)
- ByteStringUtils: betweenLinesPS :: ByteString -> ByteString -> ByteString -> Maybe (ByteString)
- ByteStringUtils: breakAfterNthNewline :: Int -> ByteString -> Maybe (ByteString, ByteString)
- ByteStringUtils: breakBeforeNthNewline :: Int -> ByteString -> (ByteString, ByteString)
- ByteStringUtils: breakFirstPS :: Char -> ByteString -> Maybe (ByteString, ByteString)
- ByteStringUtils: breakLastPS :: Char -> ByteString -> Maybe (ByteString, ByteString)
- ByteStringUtils: breakSpace :: ByteString -> (ByteString, ByteString)
- ByteStringUtils: decodeLocale :: ByteString -> String
- ByteStringUtils: decodeString :: String -> String
- ByteStringUtils: dropSpace :: ByteString -> ByteString
- ByteStringUtils: encodeLocale :: String -> ByteString
- ByteStringUtils: fromHex2PS :: ByteString -> ByteString
- ByteStringUtils: fromPS2Hex :: ByteString -> ByteString
- ByteStringUtils: gzDecompress :: Maybe Int -> ByteString -> ([ByteString], Bool)
- ByteStringUtils: gzReadFilePS :: FilePath -> IO ByteString
- ByteStringUtils: gzReadStdin :: IO ByteString
- ByteStringUtils: gzWriteFilePS :: FilePath -> ByteString -> IO ()
- ByteStringUtils: gzWriteFilePSs :: FilePath -> [ByteString] -> IO ()
- ByteStringUtils: hashPS :: ByteString -> Int32
- ByteStringUtils: intercalate :: ByteString -> [ByteString] -> ByteString
- ByteStringUtils: isAscii :: ByteString -> Bool
- ByteStringUtils: isFunky :: ByteString -> Bool
- ByteStringUtils: isGZFile :: FilePath -> IO (Maybe Int)
- ByteStringUtils: linesPS :: ByteString -> [ByteString]
- ByteStringUtils: mmapFilePS :: FilePath -> IO ByteString
- ByteStringUtils: packStringToUTF8 :: String -> ByteString
- ByteStringUtils: readIntPS :: ByteString -> Maybe (Int, ByteString)
- ByteStringUtils: substrPS :: ByteString -> ByteString -> Maybe Int
- ByteStringUtils: unlinesPS :: [ByteString] -> ByteString
- ByteStringUtils: unpackPSFromUTF8 :: ByteString -> String
- ByteStringUtils: unsafeWithInternals :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a
- CommandLine: addUrlencoded :: FTable -> FTable
- CommandLine: parseCmd :: FTable -> String -> Either ParseError ([String], Bool)
- Crypt.SHA256: sha256sum :: ByteString -> String
- Darcs.Annotate: annotate :: (Apply p, ApplyState p ~ Tree) => FL (PatchInfoAnd p) x y -> FileName -> ByteString -> Annotated
- Darcs.Annotate: annotateDirectory :: (Apply p, ApplyState p ~ Tree) => FL (PatchInfoAnd p) x y -> FileName -> [FileName] -> Annotated
- Darcs.Annotate: format :: ByteString -> Annotated -> String
- Darcs.Annotate: instance ApplyMonad AnnotatedM Tree
- Darcs.Annotate: instance Eq FileOrDirectory
- Darcs.Annotate: instance Show Annotated
- Darcs.Annotate: instance Show FileOrDirectory
- Darcs.Annotate: machineFormat :: ByteString -> Annotated -> String
- Darcs.ArgumentDefaults: getDefaultFlags :: String -> [DarcsOption] -> [DarcsFlag] -> IO [DarcsFlag]
- Darcs.Arguments: AfterPatch :: String -> DarcsFlag
- Darcs.Arguments: AfterPattern :: PatchMatch -> DarcsFlag
- Darcs.Arguments: AfterTag :: String -> DarcsFlag
- Darcs.Arguments: All :: DarcsFlag
- Darcs.Arguments: AllowCaseOnly :: DarcsFlag
- Darcs.Arguments: AllowConflicts :: DarcsFlag
- Darcs.Arguments: AllowUnrelatedRepos :: DarcsFlag
- Darcs.Arguments: AllowWindowsReserved :: DarcsFlag
- Darcs.Arguments: AmendUnrecord :: DarcsFlag
- Darcs.Arguments: AnyOrder :: DarcsFlag
- Darcs.Arguments: ApplyAs :: String -> DarcsFlag
- Darcs.Arguments: ApplyOnDisk :: DarcsFlag
- Darcs.Arguments: AskDeps :: DarcsFlag
- Darcs.Arguments: AskPosthook :: DarcsFlag
- Darcs.Arguments: AskPrehook :: DarcsFlag
- Darcs.Arguments: Author :: String -> DarcsFlag
- Darcs.Arguments: Bisect :: DarcsFlag
- Darcs.Arguments: Boring :: DarcsFlag
- Darcs.Arguments: Cc :: String -> DarcsFlag
- Darcs.Arguments: ChangesToAllFiles :: DarcsFlag
- Darcs.Arguments: Charset :: String -> DarcsFlag
- Darcs.Arguments: Check :: DarcsFlag
- Darcs.Arguments: Complement :: DarcsFlag
- Darcs.Arguments: Complete :: DarcsFlag
- Darcs.Arguments: Compress :: DarcsFlag
- Darcs.Arguments: Context :: AbsolutePath -> DarcsFlag
- Darcs.Arguments: Count :: DarcsFlag
- Darcs.Arguments: CreatorHash :: String -> DarcsFlag
- Darcs.Arguments: DarcsAbsPathOption :: [Char] -> [String] -> (AbsolutePath -> DarcsFlag) -> String -> String -> DarcsAtomicOption
- Darcs.Arguments: DarcsAbsPathOrStdOption :: [Char] -> [String] -> (AbsolutePathOrStd -> DarcsFlag) -> String -> String -> DarcsAtomicOption
- Darcs.Arguments: DarcsArgOption :: [Char] -> [String] -> (String -> DarcsFlag) -> String -> String -> DarcsAtomicOption
- Darcs.Arguments: DarcsInternalOption :: DarcsFlag -> DarcsAtomicOption
- Darcs.Arguments: DarcsMultipleChoiceOption :: [DarcsAtomicOption] -> DarcsOption
- Darcs.Arguments: DarcsMutuallyExclusive :: [DarcsAtomicOption] -> ([DarcsFlag] -> [DarcsFlag]) -> DarcsOption
- Darcs.Arguments: DarcsNoArgOption :: [Char] -> [String] -> DarcsFlag -> String -> DarcsAtomicOption
- Darcs.Arguments: DarcsOptAbsPathOption :: [Char] -> [String] -> String -> (AbsolutePath -> DarcsFlag) -> String -> String -> DarcsAtomicOption
- Darcs.Arguments: DarcsSingleOption :: DarcsAtomicOption -> DarcsOption
- Darcs.Arguments: Debug :: DarcsFlag
- Darcs.Arguments: DebugHTTP :: DarcsFlag
- Darcs.Arguments: DebugVerbose :: DarcsFlag
- Darcs.Arguments: DiffCmd :: String -> DarcsFlag
- Darcs.Arguments: DiffFlags :: String -> DarcsFlag
- Darcs.Arguments: Directories :: DarcsFlag
- Darcs.Arguments: Disable :: DarcsFlag
- Darcs.Arguments: DistName :: String -> DarcsFlag
- Darcs.Arguments: DontAllowCaseOnly :: DarcsFlag
- Darcs.Arguments: DontAllowWindowsReserved :: DarcsFlag
- Darcs.Arguments: DontGrabDeps :: DarcsFlag
- Darcs.Arguments: DontIgnoreTimes :: DarcsFlag
- Darcs.Arguments: DontPromptForDependencies :: DarcsFlag
- Darcs.Arguments: DontRestrictPaths :: DarcsFlag
- Darcs.Arguments: DontRmLogFile :: DarcsFlag
- Darcs.Arguments: DontSetScriptsExecutable :: DarcsFlag
- Darcs.Arguments: DryRun :: DarcsFlag
- Darcs.Arguments: EditDescription :: DarcsFlag
- Darcs.Arguments: EditLongComment :: DarcsFlag
- Darcs.Arguments: ExternalMerge :: String -> DarcsFlag
- Darcs.Arguments: Files :: DarcsFlag
- Darcs.Arguments: FixFilePath :: AbsolutePath -> AbsolutePath -> DarcsFlag
- Darcs.Arguments: ForceReplace :: DarcsFlag
- Darcs.Arguments: Forward :: DarcsFlag
- Darcs.Arguments: GenContext :: DarcsFlag
- Darcs.Arguments: HappyForwarding :: DarcsFlag
- Darcs.Arguments: Help :: DarcsFlag
- Darcs.Arguments: HumanReadable :: DarcsFlag
- Darcs.Arguments: IgnoreTimes :: DarcsFlag
- Darcs.Arguments: InReplyTo :: String -> DarcsFlag
- Darcs.Arguments: Interactive :: DarcsFlag
- Darcs.Arguments: Intersection :: DarcsFlag
- Darcs.Arguments: JustThisRepo :: DarcsFlag
- Darcs.Arguments: KeepDate :: DarcsFlag
- Darcs.Arguments: LastN :: Int -> DarcsFlag
- Darcs.Arguments: Lazy :: DarcsFlag
- Darcs.Arguments: LeaveTestDir :: DarcsFlag
- Darcs.Arguments: ListOptions :: DarcsFlag
- Darcs.Arguments: LogFile :: AbsolutePath -> DarcsFlag
- Darcs.Arguments: LookForAdds :: DarcsFlag
- Darcs.Arguments: MachineReadable :: DarcsFlag
- Darcs.Arguments: MarkConflicts :: DarcsFlag
- Darcs.Arguments: MaxCount :: Int -> DarcsFlag
- Darcs.Arguments: NewRepo :: String -> DarcsFlag
- Darcs.Arguments: NoAllowConflicts :: DarcsFlag
- Darcs.Arguments: NoAmendUnrecord :: DarcsFlag
- Darcs.Arguments: NoAskDeps :: DarcsFlag
- Darcs.Arguments: NoCache :: DarcsFlag
- Darcs.Arguments: NoCompress :: DarcsFlag
- Darcs.Arguments: NoDirectories :: DarcsFlag
- Darcs.Arguments: NoEditDescription :: DarcsFlag
- Darcs.Arguments: NoEditLongComment :: DarcsFlag
- Darcs.Arguments: NoFiles :: DarcsFlag
- Darcs.Arguments: NoHTTPPipelining :: DarcsFlag
- Darcs.Arguments: NoHappyForwarding :: DarcsFlag
- Darcs.Arguments: NoKeepDate :: DarcsFlag
- Darcs.Arguments: NoLeaveTestDir :: DarcsFlag
- Darcs.Arguments: NoLookForAdds :: DarcsFlag
- Darcs.Arguments: NoPacks :: DarcsFlag
- Darcs.Arguments: NoPauseForGui :: DarcsFlag
- Darcs.Arguments: NoPending :: DarcsFlag
- Darcs.Arguments: NoPosthook :: DarcsFlag
- Darcs.Arguments: NoPrehook :: DarcsFlag
- Darcs.Arguments: NoRecordRollback :: DarcsFlag
- Darcs.Arguments: NoRecursive :: DarcsFlag
- Darcs.Arguments: NoSetDefault :: Bool -> DarcsFlag
- Darcs.Arguments: NoSign :: DarcsFlag
- Darcs.Arguments: NoSummary :: DarcsFlag
- Darcs.Arguments: NoTest :: DarcsFlag
- Darcs.Arguments: NoUpdateWorking :: DarcsFlag
- Darcs.Arguments: NonApply :: DarcsFlag
- Darcs.Arguments: NonForce :: DarcsFlag
- Darcs.Arguments: NonUnified :: DarcsFlag
- Darcs.Arguments: NonVerify :: DarcsFlag
- Darcs.Arguments: NormalVerbosity :: DarcsFlag
- Darcs.Arguments: NullFlag :: DarcsFlag
- Darcs.Arguments: NumberPatches :: DarcsFlag
- Darcs.Arguments: OnePatch :: String -> DarcsFlag
- Darcs.Arguments: OnePattern :: PatchMatch -> DarcsFlag
- Darcs.Arguments: OneTag :: String -> DarcsFlag
- Darcs.Arguments: OnlyChangesToFiles :: DarcsFlag
- Darcs.Arguments: OptimizeHTTP :: DarcsFlag
- Darcs.Arguments: OptimizePristine :: DarcsFlag
- Darcs.Arguments: Output :: AbsolutePathOrStd -> DarcsFlag
- Darcs.Arguments: OutputAutoName :: AbsolutePath -> DarcsFlag
- Darcs.Arguments: Packs :: DarcsFlag
- Darcs.Arguments: PatchIndexRange :: Int -> Int -> DarcsFlag
- Darcs.Arguments: PatchName :: String -> DarcsFlag
- Darcs.Arguments: PauseForGui :: DarcsFlag
- Darcs.Arguments: Pending :: DarcsFlag
- Darcs.Arguments: Pipe :: DarcsFlag
- Darcs.Arguments: PosthookCmd :: String -> DarcsFlag
- Darcs.Arguments: PrehookCmd :: String -> DarcsFlag
- Darcs.Arguments: PromptForDependencies :: DarcsFlag
- Darcs.Arguments: PromptLongComment :: DarcsFlag
- Darcs.Arguments: Quiet :: DarcsFlag
- Darcs.Arguments: RecordRollback :: DarcsFlag
- Darcs.Arguments: Recursive :: DarcsFlag
- Darcs.Arguments: Relink :: DarcsFlag
- Darcs.Arguments: RemoteDarcsOpt :: String -> DarcsFlag
- Darcs.Arguments: RemoteRepo :: String -> DarcsFlag
- Darcs.Arguments: Reorder :: DarcsFlag
- Darcs.Arguments: Repair :: DarcsFlag
- Darcs.Arguments: Reply :: String -> DarcsFlag
- Darcs.Arguments: RestrictPaths :: DarcsFlag
- Darcs.Arguments: Reverse :: DarcsFlag
- Darcs.Arguments: RmLogFile :: DarcsFlag
- Darcs.Arguments: RunPosthook :: DarcsFlag
- Darcs.Arguments: RunPrehook :: DarcsFlag
- Darcs.Arguments: SendmailCmd :: String -> DarcsFlag
- Darcs.Arguments: SetDefault :: Bool -> DarcsFlag
- Darcs.Arguments: SetScriptsExecutable :: DarcsFlag
- Darcs.Arguments: SeveralPatch :: String -> DarcsFlag
- Darcs.Arguments: SeveralPattern :: PatchMatch -> DarcsFlag
- Darcs.Arguments: Sibling :: AbsolutePath -> DarcsFlag
- Darcs.Arguments: Sign :: DarcsFlag
- Darcs.Arguments: SignAs :: String -> DarcsFlag
- Darcs.Arguments: SignSSL :: String -> DarcsFlag
- Darcs.Arguments: SkipBoring :: DarcsFlag
- Darcs.Arguments: SkipConflicts :: DarcsFlag
- Darcs.Arguments: StoreInMemory :: DarcsFlag
- Darcs.Arguments: Subject :: String -> DarcsFlag
- Darcs.Arguments: Summary :: DarcsFlag
- Darcs.Arguments: TagName :: String -> DarcsFlag
- Darcs.Arguments: Target :: String -> DarcsFlag
- Darcs.Arguments: Test :: DarcsFlag
- Darcs.Arguments: Timings :: DarcsFlag
- Darcs.Arguments: Toks :: String -> DarcsFlag
- Darcs.Arguments: UMask :: String -> DarcsFlag
- Darcs.Arguments: UnCompress :: DarcsFlag
- Darcs.Arguments: Unified :: DarcsFlag
- Darcs.Arguments: Union :: DarcsFlag
- Darcs.Arguments: UpToPatch :: String -> DarcsFlag
- Darcs.Arguments: UpToPattern :: PatchMatch -> DarcsFlag
- Darcs.Arguments: UpToTag :: String -> DarcsFlag
- Darcs.Arguments: UpgradeFormat :: DarcsFlag
- Darcs.Arguments: UseFormat2 :: DarcsFlag
- Darcs.Arguments: UseHashedInventory :: DarcsFlag
- Darcs.Arguments: UseNoWorkingDir :: DarcsFlag
- Darcs.Arguments: UseWorkingDir :: DarcsFlag
- Darcs.Arguments: Verbose :: DarcsFlag
- Darcs.Arguments: Verify :: AbsolutePath -> DarcsFlag
- Darcs.Arguments: VerifySSL :: AbsolutePath -> DarcsFlag
- Darcs.Arguments: WorkRepoDir :: String -> DarcsFlag
- Darcs.Arguments: WorkRepoUrl :: String -> DarcsFlag
- Darcs.Arguments: XMLOutput :: DarcsFlag
- Darcs.Arguments: allInteractive :: DarcsOption
- Darcs.Arguments: allPipeInteractive :: DarcsOption
- Darcs.Arguments: allowProblematicFilenames :: DarcsOption
- Darcs.Arguments: allowUnrelatedRepos :: DarcsOption
- Darcs.Arguments: amendUnrecord :: DarcsOption
- Darcs.Arguments: anyVerbosity :: [DarcsOption]
- Darcs.Arguments: applyConflictOptions :: DarcsOption
- Darcs.Arguments: applyDefaults :: [DarcsOption] -> [DarcsFlag] -> [DarcsFlag]
- Darcs.Arguments: applyas :: DarcsOption
- Darcs.Arguments: arein :: DarcsOption -> [DarcsFlag] -> Bool
- Darcs.Arguments: askLongComment :: DarcsOption
- Darcs.Arguments: askdeps :: DarcsOption
- Darcs.Arguments: atomicOptions :: DarcsOption -> [DarcsAtomicOption]
- Darcs.Arguments: author :: DarcsOption
- Darcs.Arguments: bisect :: DarcsOption
- Darcs.Arguments: ccApply :: DarcsOption
- Darcs.Arguments: ccSend :: DarcsOption
- Darcs.Arguments: changesFormat :: DarcsOption
- Darcs.Arguments: changesReverse :: DarcsOption
- Darcs.Arguments: charset :: DarcsOption
- Darcs.Arguments: checkOrRepair :: DarcsOption
- Darcs.Arguments: creatorhash :: DarcsOption
- Darcs.Arguments: data DarcsAtomicOption
- Darcs.Arguments: data DarcsFlag
- Darcs.Arguments: data DarcsOption
- Darcs.Arguments: depsSel :: DarcsOption
- Darcs.Arguments: diffCmdFlag :: DarcsOption
- Darcs.Arguments: diffflags :: DarcsOption
- Darcs.Arguments: directories :: DarcsOption
- Darcs.Arguments: disable :: DarcsOption
- Darcs.Arguments: distnameOption :: DarcsOption
- Darcs.Arguments: dryRun :: [DarcsOption]
- Darcs.Arguments: dryRunNoxml :: DarcsOption
- Darcs.Arguments: editDescription :: DarcsOption
- Darcs.Arguments: environmentHelpEmail :: ([String], [String])
- Darcs.Arguments: environmentHelpSendmail :: ([String], [String])
- Darcs.Arguments: fileHelpAuthor :: [String]
- Darcs.Arguments: files :: DarcsOption
- Darcs.Arguments: fixFilePathOrStd :: [DarcsFlag] -> FilePath -> IO AbsolutePathOrStd
- Darcs.Arguments: fixSubPaths :: [DarcsFlag] -> [FilePath] -> IO [SubPath]
- Darcs.Arguments: fixUrl :: [DarcsFlag] -> String -> IO String
- Darcs.Arguments: fixUrlFlag :: [DarcsFlag] -> DarcsFlag -> IO DarcsFlag
- Darcs.Arguments: flagToString :: [DarcsOption] -> DarcsFlag -> Maybe String
- Darcs.Arguments: flagsToSiblings :: [DarcsFlag] -> [AbsolutePath]
- Darcs.Arguments: forceReplace :: DarcsOption
- Darcs.Arguments: fromOpt :: DarcsOption
- Darcs.Arguments: getAuthor :: [DarcsFlag] -> IO String
- Darcs.Arguments: getCc :: [DarcsFlag] -> String
- Darcs.Arguments: getCharset :: [DarcsFlag] -> Maybe String
- Darcs.Arguments: getContext :: [DarcsFlag] -> Maybe AbsolutePath
- Darcs.Arguments: getEasyAuthor :: IO [String]
- Darcs.Arguments: getInReplyTo :: [DarcsFlag] -> Maybe String
- Darcs.Arguments: getOutput :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd
- Darcs.Arguments: getPosthookCmd :: [DarcsFlag] -> Maybe String
- Darcs.Arguments: getPrehookCmd :: [DarcsFlag] -> Maybe String
- Darcs.Arguments: getRepourl :: [DarcsFlag] -> Maybe String
- Darcs.Arguments: getSendmailCmd :: [DarcsFlag] -> IO String
- Darcs.Arguments: getSubject :: [DarcsFlag] -> Maybe String
- Darcs.Arguments: happyForwarding :: DarcsOption
- Darcs.Arguments: help :: DarcsOption
- Darcs.Arguments: humanReadable :: DarcsOption
- Darcs.Arguments: ignoretimes :: DarcsOption
- Darcs.Arguments: inReplyTo :: DarcsOption
- Darcs.Arguments: instance Eq FlagContent
- Darcs.Arguments: instance Ord FlagContent
- Darcs.Arguments: instance Show FlagContent
- Darcs.Arguments: isin :: DarcsAtomicOption -> [DarcsFlag] -> Bool
- Darcs.Arguments: justThisRepo :: DarcsOption
- Darcs.Arguments: keepDate :: DarcsOption
- Darcs.Arguments: leaveTestDir :: DarcsOption
- Darcs.Arguments: listFiles :: IO [String]
- Darcs.Arguments: listOptions :: DarcsOption
- Darcs.Arguments: listRegisteredFiles :: IO [String]
- Darcs.Arguments: listUnregisteredFiles :: IO [String]
- Darcs.Arguments: logfile :: DarcsOption
- Darcs.Arguments: lookforadds :: DarcsOption
- Darcs.Arguments: machineReadable :: DarcsOption
- Darcs.Arguments: makeScriptsExecutable :: Patchy p => [DarcsFlag] -> p x y -> IO ()
- Darcs.Arguments: matchMaxcount :: DarcsOption
- Darcs.Arguments: matchOne :: DarcsOption
- Darcs.Arguments: matchOneContext :: DarcsOption
- Darcs.Arguments: matchOneNontag :: DarcsOption
- Darcs.Arguments: matchRange :: DarcsOption
- Darcs.Arguments: matchSeveral :: DarcsOption
- Darcs.Arguments: matchSeveralOrLast :: DarcsOption
- Darcs.Arguments: matchSeveralOrRange :: DarcsOption
- Darcs.Arguments: maxCount :: [DarcsFlag] -> Maybe Int
- Darcs.Arguments: maybeFixSubPaths :: [DarcsFlag] -> [FilePath] -> IO [Maybe SubPath]
- Darcs.Arguments: networkOptions :: [DarcsOption]
- Darcs.Arguments: noCache :: DarcsOption
- Darcs.Arguments: nocompress :: DarcsOption
- Darcs.Arguments: noskipBoring :: DarcsOption
- Darcs.Arguments: notest :: DarcsOption
- Darcs.Arguments: nubOptions :: [DarcsOption] -> [DarcsFlag] -> [DarcsFlag]
- Darcs.Arguments: nullFlag :: DarcsOption
- Darcs.Arguments: onlyToFiles :: DarcsOption
- Darcs.Arguments: optimizeHTTP :: DarcsOption
- Darcs.Arguments: optimizePristine :: DarcsOption
- Darcs.Arguments: optionFromDarcsOption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag]
- Darcs.Arguments: optionsLatex :: [DarcsOption] -> String
- Darcs.Arguments: output :: DarcsOption
- Darcs.Arguments: outputAutoName :: DarcsOption
- Darcs.Arguments: partial :: DarcsOption
- Darcs.Arguments: patchFormatChoices :: DarcsOption
- Darcs.Arguments: patchSelectFlag :: DarcsFlag -> Bool
- Darcs.Arguments: patchnameOption :: DarcsOption
- Darcs.Arguments: pauseForGui :: DarcsOption
- Darcs.Arguments: pending :: DarcsOption
- Darcs.Arguments: pipeInteractive :: DarcsOption
- Darcs.Arguments: possiblyRemoteRepoDir :: DarcsOption
- Darcs.Arguments: posthookCmd :: DarcsOption
- Darcs.Arguments: posthookPrompt :: DarcsOption
- Darcs.Arguments: prehookCmd :: DarcsOption
- Darcs.Arguments: prehookPrompt :: DarcsOption
- Darcs.Arguments: printDryRunMessageAndExit :: (RepoPatch p, ApplyState p ~ Tree) => String -> [DarcsFlag] -> FL (PatchInfoAnd p) x y -> IO ()
- Darcs.Arguments: pullConflictOptions :: DarcsOption
- Darcs.Arguments: recordRollback :: DarcsOption
- Darcs.Arguments: recursive :: String -> DarcsOption
- Darcs.Arguments: relink :: DarcsOption
- Darcs.Arguments: remoteRepo :: DarcsOption
- Darcs.Arguments: reorderPatches :: DarcsOption
- Darcs.Arguments: reply :: DarcsOption
- Darcs.Arguments: repoCombinator :: DarcsOption
- Darcs.Arguments: reponame :: DarcsOption
- Darcs.Arguments: restrictPaths :: DarcsOption
- Darcs.Arguments: rmlogfile :: DarcsOption
- Darcs.Arguments: sendToContext :: DarcsOption
- Darcs.Arguments: sendmailCmd :: DarcsOption
- Darcs.Arguments: setDefault :: Bool -> DarcsOption
- Darcs.Arguments: setEnvDarcsFiles :: Patchy p => p x y -> IO ()
- Darcs.Arguments: setEnvDarcsPatches :: (RepoPatch p, ApplyState p ~ Tree) => FL (PatchInfoAnd p) x y -> IO ()
- Darcs.Arguments: setScriptsExecutableOption :: DarcsOption
- Darcs.Arguments: showFriendly :: Patchy p => [DarcsFlag] -> p x y -> Doc
- Darcs.Arguments: sibling :: DarcsOption
- Darcs.Arguments: sign :: DarcsOption
- Darcs.Arguments: storeInMemory :: DarcsOption
- Darcs.Arguments: subject :: DarcsOption
- Darcs.Arguments: summary :: DarcsOption
- Darcs.Arguments: target :: DarcsOption
- Darcs.Arguments: test :: DarcsOption
- Darcs.Arguments: tokens :: DarcsOption
- Darcs.Arguments: umaskOption :: DarcsOption
- Darcs.Arguments: uncompressNocompress :: DarcsOption
- Darcs.Arguments: unidiff :: DarcsOption
- Darcs.Arguments: unified :: DarcsOption
- Darcs.Arguments: upgradeFormat :: DarcsOption
- Darcs.Arguments: useExternalMerge :: DarcsOption
- Darcs.Arguments: usePacks :: DarcsOption
- Darcs.Arguments: useWorkingDir :: DarcsOption
- Darcs.Arguments: verify :: DarcsOption
- Darcs.Arguments: workingRepoDir :: DarcsOption
- Darcs.Arguments: xmloutput :: DarcsOption
- Darcs.Bug: _bug :: BugStuff -> String -> a
- Darcs.Bug: _bugDoc :: BugStuff -> Doc -> a
- Darcs.Bug: _fromJust :: BugStuff -> Maybe a -> a
- Darcs.Bug: _impossible :: BugStuff -> a
- Darcs.ColorPrinter: assertDoc :: Maybe Doc -> a -> a
- Darcs.ColorPrinter: errorDoc :: Doc -> a
- Darcs.ColorPrinter: fancyPrinters :: Printers
- Darcs.ColorPrinter: instance Show Doc
- Darcs.ColorPrinter: traceDoc :: Doc -> a -> a
- Darcs.Commands: CommandData :: DarcsCommand -> CommandControl
- Darcs.Commands: CommandOnly :: DarcsCommand -> CommandArgs
- Darcs.Commands: DarcsCommand :: String -> String -> String -> String -> Int -> [String] -> ([DarcsFlag] -> [String] -> IO ()) -> ([DarcsFlag] -> IO (Either String ())) -> IO [String] -> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String]) -> [DarcsOption] -> [DarcsOption] -> DarcsCommand
- Darcs.Commands: GroupName :: String -> CommandControl
- Darcs.Commands: HiddenCommand :: DarcsCommand -> CommandControl
- Darcs.Commands: SuperCommand :: String -> String -> String -> String -> ([DarcsFlag] -> IO (Either String ())) -> [CommandControl] -> DarcsCommand
- Darcs.Commands: SuperCommandOnly :: DarcsCommand -> CommandArgs
- Darcs.Commands: SuperCommandSub :: DarcsCommand -> DarcsCommand -> CommandArgs
- Darcs.Commands: abortRun :: [DarcsFlag] -> Doc -> IO ()
- Darcs.Commands: chompNewline :: String -> String
- Darcs.Commands: commandAdvancedOptions :: DarcsCommand -> [DarcsOption]
- Darcs.Commands: commandAlias :: String -> Maybe DarcsCommand -> DarcsCommand -> DarcsCommand
- Darcs.Commands: commandAlloptions :: DarcsCommand -> ([DarcsOption], [DarcsOption])
- Darcs.Commands: commandArgdefaults :: DarcsCommand -> [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
- Darcs.Commands: commandBasicOptions :: DarcsCommand -> [DarcsOption]
- Darcs.Commands: commandCommand :: DarcsCommand -> [DarcsFlag] -> [String] -> IO ()
- Darcs.Commands: commandDescription :: DarcsCommand -> String
- Darcs.Commands: commandExtraArgHelp :: DarcsCommand -> [String]
- Darcs.Commands: commandExtraArgs :: DarcsCommand -> Int
- Darcs.Commands: commandGetArgPossibilities :: DarcsCommand -> IO [String]
- Darcs.Commands: commandHelp :: DarcsCommand -> String
- Darcs.Commands: commandName :: DarcsCommand -> String
- Darcs.Commands: commandOptions :: AbsolutePath -> DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag])
- Darcs.Commands: commandPrereq :: DarcsCommand -> [DarcsFlag] -> IO (Either String ())
- Darcs.Commands: commandProgramName :: DarcsCommand -> String
- Darcs.Commands: commandStub :: String -> String -> String -> DarcsCommand -> DarcsCommand
- Darcs.Commands: commandSubCommands :: DarcsCommand -> [CommandControl]
- Darcs.Commands: data CommandArgs
- Darcs.Commands: data CommandControl
- Darcs.Commands: data DarcsCommand
- Darcs.Commands: disambiguateCommands :: [CommandControl] -> String -> [String] -> Either String (CommandArgs, [String])
- Darcs.Commands: extractCommands :: [CommandControl] -> [DarcsCommand]
- Darcs.Commands: getCommandHelp :: Maybe DarcsCommand -> DarcsCommand -> String
- Darcs.Commands: getCommandMiniHelp :: Maybe DarcsCommand -> DarcsCommand -> String
- Darcs.Commands: getSubcommands :: DarcsCommand -> [CommandControl]
- Darcs.Commands: nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
- Darcs.Commands: putInfo :: [DarcsFlag] -> Doc -> IO ()
- Darcs.Commands: putVerbose :: [DarcsFlag] -> Doc -> IO ()
- Darcs.Commands: putWarning :: [DarcsFlag] -> Doc -> IO ()
- Darcs.Commands: subusage :: DarcsCommand -> String
- Darcs.Commands: superName :: Maybe DarcsCommand -> String
- Darcs.Commands: usage :: [CommandControl] -> String
- Darcs.Commands: usageHelper :: [CommandControl] -> String
- Darcs.Commands.Add: add :: DarcsCommand
- Darcs.Commands.Add: expandDirs :: [SubPath] -> IO [SubPath]
- Darcs.Commands.AmendRecord: amendrecord :: DarcsCommand
- Darcs.Commands.AmendRecord: amendunrecord :: DarcsCommand
- Darcs.Commands.Annotate: annotate :: DarcsCommand
- Darcs.Commands.Apply: apply :: DarcsCommand
- Darcs.Commands.Apply: getPatchBundle :: RepoPatch p => [DarcsFlag] -> ByteString -> IO (Either String (SealedPatchSet p Origin))
- Darcs.Commands.Changes: changes :: DarcsCommand
- Darcs.Commands.Changes: log :: DarcsCommand
- Darcs.Commands.Check: check :: DarcsCommand
- Darcs.Commands.Check: repair :: DarcsCommand
- Darcs.Commands.Convert: convert :: DarcsCommand
- Darcs.Commands.Diff: diffCommand :: DarcsCommand
- Darcs.Commands.Dist: dist :: DarcsCommand
- Darcs.Commands.GZCRCs: doCRCWarnings :: Bool -> IO ()
- Darcs.Commands.GZCRCs: gzcrcs :: DarcsCommand
- Darcs.Commands.Get: clone :: DarcsCommand
- Darcs.Commands.Get: get :: DarcsCommand
- Darcs.Commands.Help: commandControlList :: [CommandControl]
- Darcs.Commands.Help: environmentHelp :: [([String], [String])]
- Darcs.Commands.Help: helpCmd :: [DarcsFlag] -> [String] -> IO ()
- Darcs.Commands.Help: listAvailableCommands :: IO ()
- Darcs.Commands.Help: printVersion :: IO ()
- Darcs.Commands.Init: initialize :: DarcsCommand
- Darcs.Commands.Init: initializeCmd :: [DarcsFlag] -> [String] -> IO ()
- Darcs.Commands.MarkConflicts: markconflicts :: DarcsCommand
- Darcs.Commands.Move: instance Eq FileKind
- Darcs.Commands.Move: instance Show FileKind
- Darcs.Commands.Move: instance Show FileStatus
- Darcs.Commands.Move: move :: DarcsCommand
- Darcs.Commands.Move: mv :: DarcsCommand
- Darcs.Commands.Optimize: optimize :: DarcsCommand
- Darcs.Commands.Pull: fetch :: DarcsCommand
- Darcs.Commands.Pull: pull :: DarcsCommand
- Darcs.Commands.Push: push :: DarcsCommand
- Darcs.Commands.Put: put :: DarcsCommand
- Darcs.Commands.Record: askAboutDepends :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> FL (PrimOf p) t y -> [DarcsFlag] -> [PatchInfo] -> IO [PatchInfo]
- Darcs.Commands.Record: commit :: DarcsCommand
- Darcs.Commands.Record: getDate :: [DarcsFlag] -> IO String
- Darcs.Commands.Record: getLog :: (Patchy prim, PrimPatch prim) => [DarcsFlag] -> Maybe (String, [String]) -> IO String -> FL prim x y -> IO (String, [String], Maybe String)
- Darcs.Commands.Record: record :: DarcsCommand
- Darcs.Commands.Remove: remove :: DarcsCommand
- Darcs.Commands.Remove: rm :: DarcsCommand
- Darcs.Commands.Remove: unadd :: DarcsCommand
- Darcs.Commands.Replace: defaultToks :: String
- Darcs.Commands.Replace: replace :: DarcsCommand
- Darcs.Commands.Revert: revert :: DarcsCommand
- Darcs.Commands.Rollback: rollback :: DarcsCommand
- Darcs.Commands.Send: send :: DarcsCommand
- Darcs.Commands.SetPref: setpref :: DarcsCommand
- Darcs.Commands.Show: list :: DarcsCommand
- Darcs.Commands.Show: query :: DarcsCommand
- Darcs.Commands.Show: showCommand :: DarcsCommand
- Darcs.Commands.ShowAuthors: showAuthors :: DarcsCommand
- Darcs.Commands.ShowBug: showBug :: DarcsCommand
- Darcs.Commands.ShowContents: showContents :: DarcsCommand
- Darcs.Commands.ShowFiles: manifest :: [DarcsFlag] -> [String] -> IO [FilePath]
- Darcs.Commands.ShowFiles: manifestCmd :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> [DarcsFlag] -> [String] -> IO ()
- Darcs.Commands.ShowFiles: showFiles :: DarcsCommand
- Darcs.Commands.ShowFiles: toListManifest :: [DarcsFlag] -> Tree m -> [FilePath]
- Darcs.Commands.ShowIndex: showIndex :: DarcsCommand
- Darcs.Commands.ShowIndex: showPristineCmd :: [DarcsFlag] -> [String] -> IO ()
- Darcs.Commands.ShowRepo: showRepo :: DarcsCommand
- Darcs.Commands.ShowTags: showTags :: DarcsCommand
- Darcs.Commands.Tag: tag :: DarcsCommand
- Darcs.Commands.Test: test :: DarcsCommand
- Darcs.Commands.TrackDown: instance Show BisectDir
- Darcs.Commands.TrackDown: trackdown :: DarcsCommand
- Darcs.Commands.TransferMode: transferMode :: DarcsCommand
- Darcs.Commands.Unrecord: getLastPatches :: RepoPatch p => [DarcsFlag] -> PatchSet p Origin r -> ((PatchSet p) :> (FL (PatchInfoAnd p))) Origin r
- Darcs.Commands.Unrecord: obliterate :: DarcsCommand
- Darcs.Commands.Unrecord: unpull :: DarcsCommand
- Darcs.Commands.Unrecord: unrecord :: DarcsCommand
- Darcs.Commands.Unrevert: unrevert :: DarcsCommand
- Darcs.Commands.Unrevert: writeUnrevert :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> FL (PrimOf p) x y -> Tree IO -> FL (PrimOf p) r x -> IO ()
- Darcs.Commands.Util: announceFiles :: Maybe [SubPath] -> String -> IO ()
- Darcs.Commands.Util: filterExistingFiles :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> [SubPath] -> IO [SubPath]
- Darcs.Commands.WhatsNew: status :: DarcsCommand
- Darcs.Commands.WhatsNew: whatsnew :: DarcsCommand
- Darcs.CommandsAux: checkPaths :: Patchy p => [DarcsFlag] -> FL p x y -> IO ()
- Darcs.CommandsAux: hasMaliciousPath :: Patchy p => p x y -> Bool
- Darcs.CommandsAux: isMaliciousPath :: String -> Bool
- Darcs.CommandsAux: isMaliciousSubPath :: String -> Bool
- Darcs.CommandsAux: maliciousPatches :: Patchy p => [Sealed2 p] -> [Sealed2 p]
- Darcs.Compat: atomicCreate :: FilePath -> IO ()
- Darcs.Compat: canonFilename :: FilePath -> IO FilePath
- Darcs.Compat: maybeRelink :: String -> String -> IO Bool
- Darcs.Compat: mkStdoutTemp :: String -> IO String
- Darcs.Compat: sloppyAtomicCreate :: FilePath -> IO ()
- Darcs.Compat: stdoutIsAPipe :: IO Bool
- Darcs.Diff: treeDiff :: (Functor m, Monad m, Gap w, PrimPatch prim) => (FilePath -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
- Darcs.Email: formatHeader :: String -> String -> ByteString
- Darcs.Email: makeEmail :: String -> [(String, String)] -> (Maybe Doc) -> Maybe String -> Doc -> (Maybe String) -> Doc
- Darcs.Email: readEmail :: ByteString -> ByteString
- Darcs.External: Cachable :: Cachable
- Darcs.External: MaxAge :: !CInt -> Cachable
- Darcs.External: Uncachable :: Cachable
- Darcs.External: backupByCopying :: FilePath -> IO ()
- Darcs.External: backupByRenaming :: FilePath -> IO ()
- Darcs.External: cloneFile :: FilePath -> FilePath -> IO ()
- Darcs.External: cloneTree :: FilePath -> FilePath -> IO ()
- Darcs.External: cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()
- Darcs.External: copyFileOrUrl :: RemoteDarcs -> FilePath -> FilePath -> Cachable -> IO ()
- Darcs.External: copyLocal :: String -> FilePath -> IO ()
- Darcs.External: darcsProgram :: IO String
- Darcs.External: data Cachable
- Darcs.External: diffProgram :: IO String
- Darcs.External: execDocPipe :: String -> [String] -> Doc -> IO Doc
- Darcs.External: execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc
- Darcs.External: execSSH :: SshFilePath -> String -> IO ExitCode
- Darcs.External: fetchFileLazyPS :: String -> Cachable -> IO ByteString
- Darcs.External: fetchFilePS :: String -> Cachable -> IO ByteString
- Darcs.External: generateEmail :: Handle -> String -> String -> String -> String -> Doc -> IO ()
- Darcs.External: getTermNColors :: IO Int
- Darcs.External: gzFetchFilePS :: String -> Cachable -> IO ByteString
- Darcs.External: haveSendmail :: IO Bool
- Darcs.External: maybeURLCmd :: String -> String -> IO (Maybe (String))
- Darcs.External: pipeDoc :: String -> [String] -> Doc -> IO ExitCode
- Darcs.External: pipeDocSSH :: SshFilePath -> [String] -> Doc -> IO ExitCode
- Darcs.External: resendEmail :: String -> String -> ByteString -> IO ()
- Darcs.External: sendEmail :: String -> String -> String -> String -> String -> String -> IO ()
- Darcs.External: sendEmailDoc :: String -> String -> String -> String -> String -> Maybe (Doc, Doc) -> Doc -> IO ()
- Darcs.External: sendmailPath :: IO String
- Darcs.External: signString :: [DarcsFlag] -> Doc -> IO Doc
- Darcs.External: speculateFileOrUrl :: String -> FilePath -> IO ()
- Darcs.External: verifyPS :: [DarcsFlag] -> ByteString -> IO (Maybe ByteString)
- Darcs.External: viewDoc :: Doc -> IO ()
- Darcs.External: viewDocWith :: Printers -> Doc -> IO ()
- Darcs.Flags: AfterPatch :: String -> DarcsFlag
- Darcs.Flags: AfterPattern :: PatchMatch -> DarcsFlag
- Darcs.Flags: AfterTag :: String -> DarcsFlag
- Darcs.Flags: All :: DarcsFlag
- Darcs.Flags: AllowCaseOnly :: DarcsFlag
- Darcs.Flags: AllowConflicts :: DarcsFlag
- Darcs.Flags: AllowUnrelatedRepos :: DarcsFlag
- Darcs.Flags: AllowWindowsReserved :: DarcsFlag
- Darcs.Flags: AmendUnrecord :: DarcsFlag
- Darcs.Flags: AnyOrder :: DarcsFlag
- Darcs.Flags: ApplyAs :: String -> DarcsFlag
- Darcs.Flags: ApplyOnDisk :: DarcsFlag
- Darcs.Flags: AskDeps :: DarcsFlag
- Darcs.Flags: AskPosthook :: DarcsFlag
- Darcs.Flags: AskPrehook :: DarcsFlag
- Darcs.Flags: Author :: String -> DarcsFlag
- Darcs.Flags: Bisect :: DarcsFlag
- Darcs.Flags: Boring :: DarcsFlag
- Darcs.Flags: Cc :: String -> DarcsFlag
- Darcs.Flags: ChangesToAllFiles :: DarcsFlag
- Darcs.Flags: Charset :: String -> DarcsFlag
- Darcs.Flags: Check :: DarcsFlag
- Darcs.Flags: Complement :: DarcsFlag
- Darcs.Flags: Complete :: DarcsFlag
- Darcs.Flags: Compress :: DarcsFlag
- Darcs.Flags: Context :: AbsolutePath -> DarcsFlag
- Darcs.Flags: Count :: DarcsFlag
- Darcs.Flags: CreatorHash :: String -> DarcsFlag
- Darcs.Flags: Debug :: DarcsFlag
- Darcs.Flags: DebugHTTP :: DarcsFlag
- Darcs.Flags: DebugVerbose :: DarcsFlag
- Darcs.Flags: DefaultRemoteDarcs :: RemoteDarcs
- Darcs.Flags: DiffCmd :: String -> DarcsFlag
- Darcs.Flags: DiffFlags :: String -> DarcsFlag
- Darcs.Flags: Directories :: DarcsFlag
- Darcs.Flags: Disable :: DarcsFlag
- Darcs.Flags: DistName :: String -> DarcsFlag
- Darcs.Flags: DontAllowCaseOnly :: DarcsFlag
- Darcs.Flags: DontAllowWindowsReserved :: DarcsFlag
- Darcs.Flags: DontGrabDeps :: DarcsFlag
- Darcs.Flags: DontIgnoreTimes :: DarcsFlag
- Darcs.Flags: DontPromptForDependencies :: DarcsFlag
- Darcs.Flags: DontRestrictPaths :: DarcsFlag
- Darcs.Flags: DontRmLogFile :: DarcsFlag
- Darcs.Flags: DontSetScriptsExecutable :: DarcsFlag
- Darcs.Flags: DryRun :: DarcsFlag
- Darcs.Flags: EditDescription :: DarcsFlag
- Darcs.Flags: EditLongComment :: DarcsFlag
- Darcs.Flags: ExternalMerge :: String -> DarcsFlag
- Darcs.Flags: Files :: DarcsFlag
- Darcs.Flags: FixFilePath :: AbsolutePath -> AbsolutePath -> DarcsFlag
- Darcs.Flags: ForceReplace :: DarcsFlag
- Darcs.Flags: Forward :: DarcsFlag
- Darcs.Flags: GenContext :: DarcsFlag
- Darcs.Flags: GzipCompression :: Compression
- Darcs.Flags: HappyForwarding :: DarcsFlag
- Darcs.Flags: Help :: DarcsFlag
- Darcs.Flags: HumanReadable :: DarcsFlag
- Darcs.Flags: IgnoreIndex :: UseIndex
- Darcs.Flags: IgnoreTimes :: DarcsFlag
- Darcs.Flags: InReplyTo :: String -> DarcsFlag
- Darcs.Flags: Interactive :: DarcsFlag
- Darcs.Flags: Intersection :: DarcsFlag
- Darcs.Flags: JustThisRepo :: DarcsFlag
- Darcs.Flags: KeepDate :: DarcsFlag
- Darcs.Flags: LastN :: Int -> DarcsFlag
- Darcs.Flags: Lazy :: DarcsFlag
- Darcs.Flags: LeaveTestDir :: DarcsFlag
- Darcs.Flags: ListOptions :: DarcsFlag
- Darcs.Flags: LogFile :: AbsolutePath -> DarcsFlag
- Darcs.Flags: LookForAdds :: DarcsFlag
- Darcs.Flags: MachineReadable :: DarcsFlag
- Darcs.Flags: MarkConflicts :: DarcsFlag
- Darcs.Flags: MaxCount :: Int -> DarcsFlag
- Darcs.Flags: NewRepo :: String -> DarcsFlag
- Darcs.Flags: NoAllowConflicts :: DarcsFlag
- Darcs.Flags: NoAmendUnrecord :: DarcsFlag
- Darcs.Flags: NoAskDeps :: DarcsFlag
- Darcs.Flags: NoCache :: DarcsFlag
- Darcs.Flags: NoCompress :: DarcsFlag
- Darcs.Flags: NoCompression :: Compression
- Darcs.Flags: NoDirectories :: DarcsFlag
- Darcs.Flags: NoEditDescription :: DarcsFlag
- Darcs.Flags: NoEditLongComment :: DarcsFlag
- Darcs.Flags: NoFiles :: DarcsFlag
- Darcs.Flags: NoHTTPPipelining :: DarcsFlag
- Darcs.Flags: NoHappyForwarding :: DarcsFlag
- Darcs.Flags: NoKeepDate :: DarcsFlag
- Darcs.Flags: NoLeaveTestDir :: DarcsFlag
- Darcs.Flags: NoLookForAdds :: DarcsFlag
- Darcs.Flags: NoPacks :: DarcsFlag
- Darcs.Flags: NoPauseForGui :: DarcsFlag
- Darcs.Flags: NoPending :: DarcsFlag
- Darcs.Flags: NoPosthook :: DarcsFlag
- Darcs.Flags: NoPrehook :: DarcsFlag
- Darcs.Flags: NoRecordRollback :: DarcsFlag
- Darcs.Flags: NoRecursive :: DarcsFlag
- Darcs.Flags: NoSetDefault :: Bool -> DarcsFlag
- Darcs.Flags: NoSign :: DarcsFlag
- Darcs.Flags: NoSummary :: DarcsFlag
- Darcs.Flags: NoTest :: DarcsFlag
- Darcs.Flags: NoUpdateWorking :: DarcsFlag
- Darcs.Flags: NonApply :: DarcsFlag
- Darcs.Flags: NonForce :: DarcsFlag
- Darcs.Flags: NonUnified :: DarcsFlag
- Darcs.Flags: NonVerify :: DarcsFlag
- Darcs.Flags: NormalVerbosity :: DarcsFlag
- Darcs.Flags: NullFlag :: DarcsFlag
- Darcs.Flags: NumberPatches :: DarcsFlag
- Darcs.Flags: OnePatch :: String -> DarcsFlag
- Darcs.Flags: OnePattern :: PatchMatch -> DarcsFlag
- Darcs.Flags: OneTag :: String -> DarcsFlag
- Darcs.Flags: OnlyChangesToFiles :: DarcsFlag
- Darcs.Flags: OptimizeHTTP :: DarcsFlag
- Darcs.Flags: OptimizePristine :: DarcsFlag
- Darcs.Flags: Output :: AbsolutePathOrStd -> DarcsFlag
- Darcs.Flags: OutputAutoName :: AbsolutePath -> DarcsFlag
- Darcs.Flags: Packs :: DarcsFlag
- Darcs.Flags: PatchIndexRange :: Int -> Int -> DarcsFlag
- Darcs.Flags: PatchName :: String -> DarcsFlag
- Darcs.Flags: PauseForGui :: DarcsFlag
- Darcs.Flags: Pending :: DarcsFlag
- Darcs.Flags: Pipe :: DarcsFlag
- Darcs.Flags: PosthookCmd :: String -> DarcsFlag
- Darcs.Flags: PrehookCmd :: String -> DarcsFlag
- Darcs.Flags: PromptForDependencies :: DarcsFlag
- Darcs.Flags: PromptLongComment :: DarcsFlag
- Darcs.Flags: Quiet :: DarcsFlag
- Darcs.Flags: RecordRollback :: DarcsFlag
- Darcs.Flags: Recursive :: DarcsFlag
- Darcs.Flags: Relink :: DarcsFlag
- Darcs.Flags: RemoteDarcs :: String -> RemoteDarcs
- Darcs.Flags: RemoteDarcsOpt :: String -> DarcsFlag
- Darcs.Flags: RemoteRepo :: String -> DarcsFlag
- Darcs.Flags: Reorder :: DarcsFlag
- Darcs.Flags: Repair :: DarcsFlag
- Darcs.Flags: Reply :: String -> DarcsFlag
- Darcs.Flags: RestrictPaths :: DarcsFlag
- Darcs.Flags: Reverse :: DarcsFlag
- Darcs.Flags: RmLogFile :: DarcsFlag
- Darcs.Flags: RunPosthook :: DarcsFlag
- Darcs.Flags: RunPrehook :: DarcsFlag
- Darcs.Flags: ScanAll :: ScanKnown
- Darcs.Flags: ScanBoring :: ScanKnown
- Darcs.Flags: ScanKnown :: ScanKnown
- Darcs.Flags: SendmailCmd :: String -> DarcsFlag
- Darcs.Flags: SetDefault :: Bool -> DarcsFlag
- Darcs.Flags: SetScriptsExecutable :: DarcsFlag
- Darcs.Flags: SeveralPatch :: String -> DarcsFlag
- Darcs.Flags: SeveralPattern :: PatchMatch -> DarcsFlag
- Darcs.Flags: Sibling :: AbsolutePath -> DarcsFlag
- Darcs.Flags: Sign :: DarcsFlag
- Darcs.Flags: SignAs :: String -> DarcsFlag
- Darcs.Flags: SignSSL :: String -> DarcsFlag
- Darcs.Flags: SkipBoring :: DarcsFlag
- Darcs.Flags: SkipConflicts :: DarcsFlag
- Darcs.Flags: StoreInMemory :: DarcsFlag
- Darcs.Flags: Subject :: String -> DarcsFlag
- Darcs.Flags: Summary :: DarcsFlag
- Darcs.Flags: TagName :: String -> DarcsFlag
- Darcs.Flags: Target :: String -> DarcsFlag
- Darcs.Flags: Test :: DarcsFlag
- Darcs.Flags: Timings :: DarcsFlag
- Darcs.Flags: Toks :: String -> DarcsFlag
- Darcs.Flags: UMask :: String -> DarcsFlag
- Darcs.Flags: UnCompress :: DarcsFlag
- Darcs.Flags: Unified :: DarcsFlag
- Darcs.Flags: Union :: DarcsFlag
- Darcs.Flags: UpToPatch :: String -> DarcsFlag
- Darcs.Flags: UpToPattern :: PatchMatch -> DarcsFlag
- Darcs.Flags: UpToTag :: String -> DarcsFlag
- Darcs.Flags: UpgradeFormat :: DarcsFlag
- Darcs.Flags: UseFormat2 :: DarcsFlag
- Darcs.Flags: UseHashedInventory :: DarcsFlag
- Darcs.Flags: UseIndex :: UseIndex
- Darcs.Flags: UseNoWorkingDir :: DarcsFlag
- Darcs.Flags: UseWorkingDir :: DarcsFlag
- Darcs.Flags: Verbose :: DarcsFlag
- Darcs.Flags: Verify :: AbsolutePath -> DarcsFlag
- Darcs.Flags: VerifySSL :: AbsolutePath -> DarcsFlag
- Darcs.Flags: WorkRepoDir :: String -> DarcsFlag
- Darcs.Flags: WorkRepoUrl :: String -> DarcsFlag
- Darcs.Flags: XMLOutput :: DarcsFlag
- Darcs.Flags: compression :: [DarcsFlag] -> Compression
- Darcs.Flags: data Compression
- Darcs.Flags: data DarcsFlag
- Darcs.Flags: data RemoteDarcs
- Darcs.Flags: data ScanKnown
- Darcs.Flags: data UseIndex
- Darcs.Flags: defaultFlag :: [DarcsFlag] -> DarcsFlag -> [DarcsFlag] -> [DarcsFlag]
- Darcs.Flags: diffingOpts :: [DarcsFlag] -> (UseIndex, ScanKnown)
- Darcs.Flags: doAllowCaseOnly :: [DarcsFlag] -> Bool
- Darcs.Flags: doAllowWindowsReserved :: [DarcsFlag] -> Bool
- Darcs.Flags: doHappyForwarding :: [DarcsFlag] -> Bool
- Darcs.Flags: doReverse :: [DarcsFlag] -> Bool
- Darcs.Flags: includeBoring :: [DarcsFlag] -> Bool
- Darcs.Flags: instance Eq DarcsFlag
- Darcs.Flags: instance Show DarcsFlag
- Darcs.Flags: isInteractive :: [DarcsFlag] -> Bool
- Darcs.Flags: isNotUnified :: [DarcsFlag] -> Bool
- Darcs.Flags: isUnified :: [DarcsFlag] -> Bool
- Darcs.Flags: maxCount :: [DarcsFlag] -> Maybe Int
- Darcs.Flags: remoteDarcs :: [DarcsFlag] -> RemoteDarcs
- Darcs.Flags: removeFromAmended :: [DarcsFlag] -> Bool
- Darcs.Flags: rollbackInWorkingDir :: [DarcsFlag] -> Bool
- Darcs.Flags: showChangesOnlyToFiles :: [DarcsFlag] -> Bool
- Darcs.Flags: usePacks :: [DarcsFlag] -> Bool
- Darcs.Flags: wantExternalMerge :: [DarcsFlag] -> Maybe String
- Darcs.Flags: wantGuiPause :: [DarcsFlag] -> Bool
- Darcs.Flags: willIgnoreTimes :: [DarcsFlag] -> Bool
- Darcs.Flags: willRemoveLogFile :: [DarcsFlag] -> Bool
- Darcs.Global: SshSettings :: String -> String -> String -> SshSettings
- Darcs.Global: addBadSource :: String -> IO ()
- Darcs.Global: addCRCWarning :: FilePath -> IO ()
- Darcs.Global: addReachableSource :: String -> IO ()
- Darcs.Global: atexit :: IO () -> IO ()
- Darcs.Global: darcsdir :: String
- Darcs.Global: data SshSettings
- Darcs.Global: debugFail :: String -> IO a
- Darcs.Global: debugMessage :: String -> IO ()
- Darcs.Global: defaultSsh :: SshSettings
- Darcs.Global: getBadSourcesList :: IO [String]
- Darcs.Global: getCRCWarnings :: IO [FilePath]
- Darcs.Global: instance Eq SshSettings
- Darcs.Global: instance Show SshSettings
- Darcs.Global: isBadSource :: IO (String -> Bool)
- Darcs.Global: isReachableSource :: IO (String -> Bool)
- Darcs.Global: putTiming :: IO ()
- Darcs.Global: resetCRCWarnings :: IO ()
- Darcs.Global: scp :: SshSettings -> String
- Darcs.Global: setDebugMode :: IO ()
- Darcs.Global: setTimingsMode :: IO ()
- Darcs.Global: sftp :: SshSettings -> String
- Darcs.Global: ssh :: SshSettings -> String
- Darcs.Global: timingsMode :: Bool
- Darcs.Global: whenDebugMode :: IO () -> IO ()
- Darcs.Global: windows :: Bool
- Darcs.Global: withAtexit :: IO a -> IO a
- Darcs.Global: withDebugMode :: (Bool -> IO a) -> IO a
- Darcs.IO: instance ApplyMonad IO Tree
- Darcs.IO: instance ApplyMonad SilentIO Tree
- Darcs.IO: instance ApplyMonad TolerantIO Tree
- Darcs.IO: instance Functor SilentIO
- Darcs.IO: instance Functor TolerantIO
- Darcs.IO: instance Monad SilentIO
- Darcs.IO: instance Monad TolerantIO
- Darcs.IO: instance TolerantMonad SilentIO
- Darcs.IO: instance TolerantMonad TolerantIO
- Darcs.IO: runSilently :: SilentIO a -> IO a
- Darcs.IO: runTolerantly :: TolerantIO a -> IO a
- Darcs.Lock: appendBinFile :: FilePathLike p => p -> String -> IO ()
- Darcs.Lock: appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()
- Darcs.Lock: appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()
- Darcs.Lock: canonFilename :: FilePath -> IO FilePath
- Darcs.Lock: editText :: String -> ByteString -> IO ByteString
- Darcs.Lock: environmentHelpKeepTmpdir :: ([String], [String])
- Darcs.Lock: environmentHelpTmpdir :: ([String], [String])
- Darcs.Lock: gzWriteAtomicFilePS :: FilePathLike p => p -> ByteString -> IO ()
- Darcs.Lock: gzWriteAtomicFilePSs :: FilePathLike p => p -> [ByteString] -> IO ()
- Darcs.Lock: gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()
- Darcs.Lock: maybeRelink :: String -> String -> IO Bool
- Darcs.Lock: readBinFile :: FilePathLike p => p -> IO String
- Darcs.Lock: readDocBinFile :: FilePathLike p => p -> IO Doc
- Darcs.Lock: readLocaleFile :: FilePathLike p => p -> IO String
- Darcs.Lock: removeFileMayNotExist :: FilePathLike p => p -> IO ()
- Darcs.Lock: rmRecursive :: FilePath -> IO ()
- Darcs.Lock: tempdirLoc :: IO FilePath
- Darcs.Lock: withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a
- Darcs.Lock: withLock :: String -> IO a -> IO a
- Darcs.Lock: withLockCanFail :: String -> IO a -> IO (Either () a)
- Darcs.Lock: withNamedTemp :: String -> (String -> IO a) -> IO a
- Darcs.Lock: withOpenTemp :: ((Handle, String) -> IO a) -> IO a
- Darcs.Lock: withPermDir :: String -> (AbsolutePath -> IO a) -> IO a
- Darcs.Lock: withStdoutTemp :: (String -> IO a) -> IO a
- Darcs.Lock: withTemp :: (String -> IO a) -> IO a
- Darcs.Lock: withTempDir :: String -> (AbsolutePath -> IO a) -> IO a
- Darcs.Lock: worldReadableTemp :: String -> IO String
- Darcs.Lock: writeAtomicFilePS :: FilePathLike p => p -> ByteString -> IO ()
- Darcs.Lock: writeBinFile :: FilePathLike p => p -> String -> IO ()
- Darcs.Lock: writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()
- Darcs.Lock: writeLocaleFile :: FilePathLike p => p -> String -> IO ()
- Darcs.Lock: writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()
- Darcs.Match: Exclusive :: InclusiveOrExclusive
- Darcs.Match: Inclusive :: InclusiveOrExclusive
- Darcs.Match: applyInvToMatcher :: (RepoPatch p, ApplyMonad m (ApplyState p)) => InclusiveOrExclusive -> Matcher p -> PatchSet p Origin x -> m ()
- Darcs.Match: applyNInv :: (RepoPatch p, ApplyMonad m (ApplyState p)) => Int -> PatchSet p Origin x -> m ()
- Darcs.Match: checkMatchSyntax :: [DarcsFlag] -> IO ()
- Darcs.Match: data InclusiveOrExclusive
- Darcs.Match: firstMatch :: [DarcsFlag] -> Bool
- Darcs.Match: getFirstMatch :: (ApplyMonad IO (ApplyState p), RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> [DarcsFlag] -> IO ()
- Darcs.Match: getNonrangeMatch :: (ApplyMonad IO (ApplyState p), RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> [DarcsFlag] -> IO ()
- Darcs.Match: getNonrangeMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> PatchSet p Origin x -> m ()
- Darcs.Match: getOnePatchset :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> [DarcsFlag] -> IO (SealedPatchSet p Origin)
- Darcs.Match: getPartialFirstMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree) => Repository p r u t -> [DarcsFlag] -> Maybe [FileName] -> IO ()
- Darcs.Match: getPartialNonrangeMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree) => Repository p r u t -> [DarcsFlag] -> [FileName] -> IO ()
- Darcs.Match: getPartialSecondMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree) => Repository p r u t -> [DarcsFlag] -> Maybe [FileName] -> IO ()
- Darcs.Match: hasIndexRange :: [DarcsFlag] -> Maybe (Int, Int)
- Darcs.Match: haveNonrangeMatch :: [DarcsFlag] -> Bool
- Darcs.Match: havePatchsetMatch :: [DarcsFlag] -> Bool
- Darcs.Match: instance Eq InclusiveOrExclusive
- Darcs.Match: matchAPatch :: Patchy p => [DarcsFlag] -> Named p x y -> Bool
- Darcs.Match: matchAPatchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p x y -> Bool
- Darcs.Match: matchExists :: Matcher p -> PatchSet p start x -> Bool
- Darcs.Match: matchFirstPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p start x -> SealedPatchSet p start
- Darcs.Match: matchPatch :: RepoPatch p => [DarcsFlag] -> PatchSet p start x -> Sealed2 (Named p)
- Darcs.Match: matchSecondPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p start x -> SealedPatchSet p start
- Darcs.Match: nonrangeMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)
- Darcs.Match: secondMatch :: [DarcsFlag] -> Bool
- Darcs.MonadProgress: ProgressAction :: m a -> Doc -> Doc -> ProgressAction m a
- Darcs.MonadProgress: class Monad m => MonadProgress m
- Darcs.MonadProgress: data ProgressAction m a
- Darcs.MonadProgress: instance (Functor m, Monad m) => MonadProgress (TreeMonad m)
- Darcs.MonadProgress: instance MonadProgress IO
- Darcs.MonadProgress: paAction :: ProgressAction m a -> m a
- Darcs.MonadProgress: paMessage :: ProgressAction m a -> Doc
- Darcs.MonadProgress: paOnError :: ProgressAction m a -> Doc
- Darcs.MonadProgress: runProgressActions :: MonadProgress m => String -> [ProgressAction m ()] -> m ()
- Darcs.MonadProgress: silentlyRunProgressActions :: Monad m => String -> [ProgressAction m ()] -> m ()
- Darcs.Patch: gzWritePatch :: ShowPatchBasic p => FilePath -> p x y -> IO ()
- Darcs.Patch: instance (CommuteNoConflicts p, Conflict p, IsHunk p, PatchListFormat p, PrimPatchBase p, Patchy p, ApplyState p ~ Tree) => Patchy (Named p)
- Darcs.Patch: joinPatches :: FromPrims p => FL p x y -> p x y
- Darcs.Patch: writePatch :: ShowPatchBasic p => FilePath -> p x y -> IO ()
- Darcs.Patch.Bracketed: mapBracketedFL_FL :: (forall a b. p a b -> q a b) -> BracketedFL p x y -> BracketedFL q x y
- Darcs.Patch.Bundle: scanContext :: RepoPatch p => ByteString -> PatchSet p Origin x
- Darcs.Patch.Choices: data Tag
- Darcs.Patch.Choices: data TaggedPatch p x y
- Darcs.Patch.Choices: instance Commute p => Commute (TaggedPatch p)
- Darcs.Patch.Choices: instance Eq Tag
- Darcs.Patch.Choices: instance Invert p => Invert (TaggedPatch p)
- Darcs.Patch.Choices: instance Merge p => Merge (TaggedPatch p)
- Darcs.Patch.Choices: instance MyEq p => MyEq (TaggedPatch p)
- Darcs.Patch.Choices: instance Ord Tag
- Darcs.Patch.Choices: instance PatchInspect p => PatchInspect (TaggedPatch p)
- Darcs.Patch.Choices: patchChoicesTps :: Patchy p => FL p x y -> (PatchChoices p x y, FL (TaggedPatch p) x y)
- Darcs.Patch.Choices: patchChoicesTpsSub :: Patchy p => Maybe Tag -> FL p x y -> (PatchChoices p x y, FL (TaggedPatch p) x y)
- Darcs.Patch.Choices: tag :: TaggedPatch p x y -> Tag
- Darcs.Patch.Choices: tpPatch :: TaggedPatch p x y -> p x y
- Darcs.Patch.Depends: deepOptimizePatchset :: PatchSet p start x -> PatchSet p start x
- Darcs.Patch.Depends: getPatchesInTag :: RepoPatch p => PatchInfo -> PatchSet p start x -> SealedPatchSet p start
- Darcs.Patch.Depends: getTagsRight :: PatchSet p start x -> [PatchInfo]
- Darcs.Patch.Depends: optimizePatchset :: PatchSet p start x -> PatchSet p start x
- Darcs.Patch.FileName: (///) :: FileName -> FileName -> FileName
- Darcs.Patch.FileName: breakOnDir :: FileName -> Maybe (FileName, FileName)
- Darcs.Patch.FileName: breakup :: String -> [String]
- Darcs.Patch.FileName: data FileName
- Darcs.Patch.FileName: decodeWhite :: String -> FilePath
- Darcs.Patch.FileName: encodeWhite :: FilePath -> String
- Darcs.Patch.FileName: fn2fp :: FileName -> FilePath
- Darcs.Patch.FileName: fn2niceps :: FileName -> ByteString
- Darcs.Patch.FileName: fn2ps :: FileName -> ByteString
- Darcs.Patch.FileName: fp2fn :: FilePath -> FileName
- Darcs.Patch.FileName: instance Eq FileName
- Darcs.Patch.FileName: instance Ord FileName
- Darcs.Patch.FileName: instance Show FileName
- Darcs.Patch.FileName: isParentOrEqOf :: FileName -> FileName -> Bool
- Darcs.Patch.FileName: movedirfilename :: FileName -> FileName -> FileName -> FileName
- Darcs.Patch.FileName: niceps2fn :: ByteString -> FileName
- Darcs.Patch.FileName: normPath :: FileName -> FileName
- Darcs.Patch.FileName: ownName :: FileName -> FileName
- Darcs.Patch.FileName: ps2fn :: ByteString -> FileName
- Darcs.Patch.FileName: superName :: FileName -> FileName
- Darcs.Patch.Info: data RepoPatchInfo
- Darcs.Patch.Info: humanFriendly :: PatchInfo -> Doc
- Darcs.Patch.Info: idpatchinfo :: PatchInfo
- Darcs.Patch.Info: instance HTML RepoPatchInfo
- Darcs.Patch.Info: makeAltFilename :: PatchInfo -> String
- Darcs.Patch.Info: repopatchinfo :: String -> PatchInfo -> RepoPatchInfo
- Darcs.Patch.Match: applyMatcher :: Matcher p -> PatchInfoAnd p x y -> Bool
- Darcs.Patch.Match: data Matcher p
- Darcs.Patch.Match: data PatchMatch
- Darcs.Patch.Match: makeMatcher :: String -> (Sealed2 (PatchInfoAnd p) -> Bool) -> Matcher p
- Darcs.Patch.Match: matchPattern :: Patchy p => PatchMatch -> Matcher p
- Darcs.Patch.Match: parseMatch :: Patchy p => PatchMatch -> Either String (MatchFun p)
- Darcs.Patch.Match: patchMatch :: String -> PatchMatch
- Darcs.Patch.Match: type MatchFun p = Sealed2 (PatchInfoAnd p) -> Bool
- Darcs.Patch.MatchData: PatternMatch :: String -> PatchMatch
- Darcs.Patch.MatchData: data PatchMatch
- Darcs.Patch.MatchData: instance Eq PatchMatch
- Darcs.Patch.MatchData: instance Show PatchMatch
- Darcs.Patch.MatchData: patchMatch :: String -> PatchMatch
- Darcs.Patch.Named: instance (Commute p, Invert p) => Invert (Named p)
- Darcs.Patch.Named: instance (PatchListFormat p, ShowPatch p) => Show (Named p x y)
- Darcs.Patch.Named: instance (PatchListFormat p, ShowPatch p) => Show1 (Named p x)
- Darcs.Patch.Named: instance (PatchListFormat p, ShowPatch p) => Show2 (Named p)
- Darcs.Patch.Named: instance Commute p => Commute (Named p)
- Darcs.Patch.Named: instance Merge p => Merge (Named p)
- Darcs.Patch.PatchInfoAnd: fmapFL_PIAP :: (FL p x y -> FL q x y) -> PatchInfoAnd p x y -> PatchInfoAnd q x y
- Darcs.Patch.PatchInfoAnd: instance (Commute p, Invert p) => Invert (PatchInfoAnd p)
- Darcs.Patch.PatchInfoAnd: instance (Commute p, MyEq p) => MyEq (PatchInfoAnd p)
- Darcs.Patch.PatchInfoAnd: instance (RepoPatch p, ApplyState p ~ Tree) => Patchy (PatchInfoAnd p)
- Darcs.Patch.PatchInfoAnd: instance Commute p => Commute (PatchInfoAnd p)
- Darcs.Patch.PatchInfoAnd: instance Merge p => Merge (PatchInfoAnd p)
- Darcs.Patch.Permutations: commuterFLId :: CommuteFn p1 p2 -> CommuteFn (FL p1) p2
- Darcs.Patch.Permutations: commuterIdFL :: CommuteFn p1 p2 -> CommuteFn p1 (FL p2)
- Darcs.Patch.Permutations: commuterIdRL :: CommuteFn p1 p2 -> CommuteFn p1 (RL p2)
- Darcs.Patch.Permutations: instance (Commute p, Invert p) => Invert (RL p)
- Darcs.Patch.Permutations: instance (Invert p, Commute p) => Invert (FL p)
- Darcs.Patch.Permutations: selfCommuter :: Commute p => CommuteFn p p
- Darcs.Patch.Permutations: type CommuteFn p1 p2 = forall x y. (p1 :> p2) x y -> Maybe ((p2 :> p1) x y)
- Darcs.Patch.Prim: join :: PrimCanonize prim => (prim :> prim) x y -> Maybe (FL prim x y)
- Darcs.Patch.Prim: joinPatches :: FromPrims p => FL p x y -> p x y
- Darcs.Patch.Prim.Class: join :: PrimCanonize prim => (prim :> prim) x y -> Maybe (FL prim x y)
- Darcs.Patch.Prim.Class: joinPatches :: FromPrims p => FL p x y -> p x y
- Darcs.Patch.Prim.V1.Coalesce: instance Show (Simple x y)
- Darcs.Patch.Prim.V1.Core: instance Eq (DirPatchType x y)
- Darcs.Patch.Prim.V1.Core: instance Eq (FilePatchType x y)
- Darcs.Patch.Prim.V1.Core: instance Eq (Prim x y)
- Darcs.Patch.Prim.V1.Core: instance Ord (DirPatchType x y)
- Darcs.Patch.Prim.V1.Core: instance Ord (FilePatchType x y)
- Darcs.Patch.Prim.V1.Show: instance Show (DirPatchType x y)
- Darcs.Patch.Prim.V1.Show: instance Show (FilePatchType x y)
- Darcs.Patch.Prim.V1.Show: instance Show (Prim x y)
- Darcs.Patch.Prim.V1.Show: instance Show1 (Prim x)
- Darcs.Patch.Prim.V3.Core: instance Eq (Prim x y)
- Darcs.Patch.Prim.V3.Show: instance Show (Prim x y)
- Darcs.Patch.Prim.V3.Show: instance Show1 (Prim x)
- Darcs.Patch.Prim.V3.Show: instance Show2 Prim
- Darcs.Patch.Show: gzWritePatch :: ShowPatchBasic p => FilePath -> p x y -> IO ()
- Darcs.Patch.Show: writePatch :: ShowPatchBasic p => FilePath -> p x y -> IO ()
- Darcs.Patch.V1.Commute: instance MyEq prim => Eq (Patch prim x y)
- Darcs.Patch.V1.Show: instance PrimPatch prim => Show (Patch prim x y)
- Darcs.Patch.V1.Show: instance PrimPatch prim => Show1 (Patch prim x)
- Darcs.Patch.V1.Show: instance PrimPatch prim => Show2 (Patch prim)
- Darcs.Patch.V2.Non: instance (Commute p, MyEq p, MyEq (PrimOf p)) => Eq (Non p x)
- Darcs.Patch.V2.Non: instance (Show2 p, Show2 (PrimOf p)) => Show (Non p x)
- Darcs.Patch.V2.Real: instance PrimPatch prim => Show (RealPatch prim x y)
- Darcs.Patch.V2.Real: instance PrimPatch prim => Show2 (RealPatch prim)
- Darcs.PrintPatch: contextualPrintPatch :: (Patchy p, ApplyState p ~ Tree) => Tree IO -> p x y -> IO ()
- Darcs.PrintPatch: printFriendly :: (Patchy p, ApplyState p ~ Tree) => (Maybe (Tree IO)) -> [DarcsFlag] -> p x y -> IO ()
- Darcs.PrintPatch: printPatch :: Patchy p => p x y -> IO ()
- Darcs.PrintPatch: printPatchPager :: Patchy p => p x y -> IO ()
- Darcs.ProgressPatches: progressFL :: String -> FL a x y -> FL a x y
- Darcs.ProgressPatches: progressRL :: String -> RL a x y -> RL a x y
- Darcs.ProgressPatches: progressRLShowTags :: String -> RL (PatchInfoAnd p) x y -> RL (PatchInfoAnd p) x y
- Darcs.RemoteApply: applyAs :: [DarcsFlag] -> Maybe String
- Darcs.RemoteApply: remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode
- Darcs.RepoPath: class FilePathOrURL a => FilePathLike a
- Darcs.RepoPath: class FilePathOrURL a
- Darcs.RepoPath: data AbsoluteOrRemotePath
- Darcs.RepoPath: data AbsolutePath
- Darcs.RepoPath: data AbsolutePathOrStd
- Darcs.RepoPath: data SubPath
- Darcs.RepoPath: getCurrentDirectory :: IO AbsolutePath
- Darcs.RepoPath: instance CharLike Char
- Darcs.RepoPath: instance CharLike c => FilePathLike [c]
- Darcs.RepoPath: instance CharLike c => FilePathOrURL [c]
- Darcs.RepoPath: instance Eq AbsoluteOrRemotePath
- Darcs.RepoPath: instance Eq AbsolutePath
- Darcs.RepoPath: instance Eq AbsolutePathOrStd
- Darcs.RepoPath: instance Eq SubPath
- Darcs.RepoPath: instance FilePathLike AbsolutePath
- Darcs.RepoPath: instance FilePathLike FileName
- Darcs.RepoPath: instance FilePathLike SubPath
- Darcs.RepoPath: instance FilePathOrURL AbsoluteOrRemotePath
- Darcs.RepoPath: instance FilePathOrURL AbsolutePath
- Darcs.RepoPath: instance FilePathOrURL FileName
- Darcs.RepoPath: instance FilePathOrURL SubPath
- Darcs.RepoPath: instance Ord AbsoluteOrRemotePath
- Darcs.RepoPath: instance Ord AbsolutePath
- Darcs.RepoPath: instance Ord AbsolutePathOrStd
- Darcs.RepoPath: instance Ord SubPath
- Darcs.RepoPath: instance Show AbsoluteOrRemotePath
- Darcs.RepoPath: instance Show AbsolutePath
- Darcs.RepoPath: instance Show AbsolutePathOrStd
- Darcs.RepoPath: instance Show SubPath
- Darcs.RepoPath: ioAbsolute :: FilePath -> IO AbsolutePath
- Darcs.RepoPath: ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath
- Darcs.RepoPath: ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd
- Darcs.RepoPath: isRemote :: AbsoluteOrRemotePath -> Bool
- Darcs.RepoPath: makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath
- Darcs.RepoPath: makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd
- Darcs.RepoPath: makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath
- Darcs.RepoPath: rootDirectory :: AbsolutePath
- Darcs.RepoPath: setCurrentDirectory :: FilePathLike p => p -> IO ()
- Darcs.RepoPath: simpleSubPath :: FilePath -> Maybe SubPath
- Darcs.RepoPath: sp2fn :: SubPath -> FileName
- Darcs.RepoPath: stdOut :: AbsolutePathOrStd
- Darcs.RepoPath: toFilePath :: FilePathLike a => a -> FilePath
- Darcs.RepoPath: toPath :: FilePathOrURL a => a -> String
- Darcs.RepoPath: useAbsoluteOrStd :: (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a
- Darcs.Repository: copyRepository :: (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) => Repository p r u t -> Bool -> IO ()
- Darcs.Repository: extractOptions :: Repository p r u t -> [DarcsFlag]
- Darcs.Repository: makePatchLazy :: RepoPatch p => Repository p r u t -> PatchInfoAnd p x y -> IO (PatchInfoAnd p x y)
- Darcs.Repository: optimizeInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO ()
- Darcs.Repository: testRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (ExitCode)
- Darcs.Repository: withGutsOf :: Repository p r u t -> IO a -> IO a
- Darcs.Repository: withRepoReadLock :: [DarcsFlag] -> RepoJob a -> IO a
- Darcs.Repository.Cache: isthisrepo :: CacheLoc -> Bool
- Darcs.Repository.Format: Darcs1_0 :: RepoProperty
- Darcs.Repository.Format: readfromAndWritetoProblem :: RepoFormat -> RepoFormat -> Maybe String
- Darcs.Repository.HashedRepo: copyRepo :: RepoPatch p => Repository p r u t -> RemoteDarcs -> String -> IO ()
- Darcs.Repository.Internal: DarcsRepository :: !Pristine -> Cache -> RepoType
- Darcs.Repository.Internal: PrimV1Job :: (forall p r u. (RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim) => Repository p r u r -> IO a) -> RepoJob a
- Darcs.Repository.Internal: RepoJob :: (forall p r u. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository p r u r -> IO a) -> RepoJob a
- Darcs.Repository.Internal: V1Job :: (forall r u. Repository (Patch Prim) r u r -> IO a) -> RepoJob a
- Darcs.Repository.Internal: V2Job :: (forall r u. Repository (RealPatch Prim) r u r -> IO a) -> RepoJob a
- Darcs.Repository.Internal: data RIO p r u t t1 a
- Darcs.Repository.Internal: data RepoJob a
- Darcs.Repository.Internal: data RepoType (p :: * -> * -> *)
- Darcs.Repository.Internal: getRepository :: RIO p r u t t (Repository p r u t)
- Darcs.Repository.Internal: identifyDarcsRepository :: [DarcsFlag] -> String -> IO (Repository p r u t)
- Darcs.Repository.Internal: instance Functor (RIO p r u t t)
- Darcs.Repository.Internal: instance Monad (RIO p r u t t)
- Darcs.Repository.Internal: makePatchLazy :: RepoPatch p => Repository p r u t -> PatchInfoAnd p x y -> IO (PatchInfoAnd p x y)
- Darcs.Repository.Internal: optimizeInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO ()
- Darcs.Repository.Internal: rIO :: IO a -> RIO p r u t t a
- Darcs.Repository.Internal: testRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (ExitCode)
- Darcs.Repository.Internal: testTentative :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (ExitCode)
- Darcs.Repository.Internal: withGutsOf :: Repository p r u t -> IO a -> IO a
- Darcs.Repository.Internal: withRepoLock :: [DarcsFlag] -> RepoJob a -> IO a
- Darcs.Repository.Internal: withRepoReadLock :: [DarcsFlag] -> RepoJob a -> IO a
- Darcs.Repository.Internal: withRepository :: [DarcsFlag] -> RepoJob a -> IO a
- Darcs.Repository.Internal: withRepositoryDirectory :: [DarcsFlag] -> String -> RepoJob a -> IO a
- Darcs.Repository.InternalTypes: DarcsRepository :: !Pristine -> Cache -> RepoType
- Darcs.Repository.InternalTypes: data RepoType (p :: * -> * -> *)
- Darcs.Repository.InternalTypes: extractOptions :: Repository p r u t -> [DarcsFlag]
- Darcs.Repository.InternalTypes: instance Show (RepoType p)
- Darcs.Repository.InternalTypes: instance Show (Repository p recordedstate unrecordedstate tentativestate)
- Darcs.Repository.Prefs: setDefaultrepo :: String -> [DarcsFlag] -> IO ()
- Darcs.Resolution: externalResolution :: (RepoPatch p, ApplyState p ~ Tree) => Tree IO -> String -> [DarcsFlag] -> FL (PrimOf p) x y -> FL (PrimOf p) x z -> FL p y a -> IO (Sealed (FL (PrimOf p) a))
- Darcs.Resolution: patchsetConflictResolutions :: RepoPatch p => PatchSet p Origin x -> Sealed (FL (PrimOf p) x)
- Darcs.Resolution: standardResolution :: RepoPatch p => FL p x y -> Sealed (FL (PrimOf p) y)
- Darcs.RunCommand: runTheCommand :: [CommandControl] -> String -> [String] -> IO ()
- Darcs.SelectChanges: First :: WhichChanges
- Darcs.SelectChanges: FirstReversed :: WhichChanges
- Darcs.SelectChanges: Last :: WhichChanges
- Darcs.SelectChanges: LastReversed :: WhichChanges
- Darcs.SelectChanges: data WhichChanges
- Darcs.SelectChanges: filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> RL (PatchInfoAnd p) x t -> Repository p r u t -> FL (PatchInfoAnd p) x z -> IO (Bool, Sealed (FL (PatchInfoAnd p) x))
- Darcs.SelectChanges: instance Eq WhichChanges
- Darcs.SelectChanges: instance Show WhichChanges
- Darcs.SelectChanges: runSelection :: Patchy p => PatchSelection p x y -> PatchSelectionContext p -> IO ((FL p :> FL p) x y)
- Darcs.SelectChanges: selectChanges :: (Patchy p, ApplyState p ~ Tree) => WhichChanges -> FL p x y -> PatchSelection p x y
- Darcs.SelectChanges: selectionContext :: RepoPatch p => String -> [DarcsFlag] -> Maybe (Splitter (PatchInfoAnd p)) -> Maybe [FilePath] -> PatchSelectionContext (PatchInfoAnd p)
- Darcs.SelectChanges: selectionContextPrim :: PrimPatch prim => String -> [DarcsFlag] -> Maybe (Splitter prim) -> Maybe [FilePath] -> Maybe (Tree IO) -> PatchSelectionContext prim
- Darcs.SelectChanges: viewChanges :: (Patchy p, ApplyState p ~ Tree) => [DarcsFlag] -> [Sealed2 p] -> IO ()
- Darcs.SelectChanges: withSelectedPatchFromRepo :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p r u t -> [DarcsFlag] -> (forall a. (FL (PatchInfoAnd p) :> PatchInfoAnd p) a r -> IO ()) -> IO ()
- Darcs.SignalHandler: catchInterrupt :: IO a -> IO a -> IO a
- Darcs.SignalHandler: catchNonSignal :: IO a -> (SomeException -> IO a) -> IO a
- Darcs.SignalHandler: instance Exception SignalException
- Darcs.SignalHandler: instance Show SignalException
- Darcs.SignalHandler: instance Typeable SignalException
- Darcs.SignalHandler: stdoutIsAPipe :: IO Bool
- Darcs.SignalHandler: tryNonSignal :: IO a -> IO (Either SomeException a)
- Darcs.SignalHandler: withSignalsBlocked :: IO a -> IO a
- Darcs.SignalHandler: withSignalsHandled :: IO a -> IO a
- Darcs.Ssh: SCP :: SSHCmd
- Darcs.Ssh: SFTP :: SSHCmd
- Darcs.Ssh: SSH :: SSHCmd
- Darcs.Ssh: copySSH :: RemoteDarcs -> SshFilePath -> FilePath -> IO ()
- Darcs.Ssh: data SSHCmd
- Darcs.Ssh: environmentHelpScp :: ([String], [String])
- Darcs.Ssh: environmentHelpSsh :: ([String], [String])
- Darcs.Ssh: environmentHelpSshPort :: ([String], [String])
- Darcs.Ssh: getSSH :: SSHCmd -> IO (String, [String])
- Darcs.Ssh: remoteDarcs :: RemoteDarcs -> String
- Darcs.Test: getTest :: [DarcsFlag] -> IO (IO ExitCode)
- Darcs.Test: runPosthook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode
- Darcs.Test: runPrehook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode
- Darcs.TheCommands: commandControlList :: [CommandControl]
- Darcs.URL: data SshFilePath
- Darcs.URL: isAbsolute :: String -> Bool
- Darcs.URL: isFile :: String -> Bool
- Darcs.URL: isHttpUrl :: String -> Bool
- Darcs.URL: isRelative :: String -> Bool
- Darcs.URL: isSshNopath :: String -> Bool
- Darcs.URL: isSshUrl :: String -> Bool
- Darcs.URL: splitSshUrl :: String -> SshFilePath
- Darcs.URL: sshFile :: SshFilePath -> String
- Darcs.URL: sshRepo :: SshFilePath -> String
- Darcs.URL: sshUhost :: SshFilePath -> String
- Darcs.URL: urlOf :: SshFilePath -> String
- Darcs.Utils: PromptConfig :: String -> [Char] -> [Char] -> Maybe Char -> [Char] -> PromptConfig
- Darcs.Utils: addToErrorLoc :: IOException -> String -> IOException
- Darcs.Utils: askEnter :: String -> IO ()
- Darcs.Utils: askUser :: String -> IO String
- Darcs.Utils: askUserListItem :: String -> [String] -> IO String
- Darcs.Utils: breakCommand :: String -> (String, [String])
- Darcs.Utils: catchall :: IO a -> IO a -> IO a
- Darcs.Utils: clarifyErrors :: IO a -> String -> IO a
- Darcs.Utils: data PromptConfig
- Darcs.Utils: editFile :: FilePathLike p => p -> IO (ExitCode, Bool)
- Darcs.Utils: environmentHelpEditor :: ([String], [String])
- Darcs.Utils: environmentHelpPager :: ([String], [String])
- Darcs.Utils: filterFilePaths :: [FilePath] -> AnchoredPath -> t -> Bool
- Darcs.Utils: filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool
- Darcs.Utils: firstJustIO :: [IO (Maybe a)] -> IO (Maybe a)
- Darcs.Utils: formatPath :: String -> String
- Darcs.Utils: getFileStatus :: FilePath -> IO (Maybe FileStatus)
- Darcs.Utils: getSystemEncoding :: IO String
- Darcs.Utils: getViewer :: IO String
- Darcs.Utils: isUTF8Locale :: String -> Bool
- Darcs.Utils: maybeGetEnv :: String -> IO (Maybe String)
- Darcs.Utils: nubsort :: Ord a => [a] -> [a]
- Darcs.Utils: ortryrunning :: IO ExitCode -> IO ExitCode -> IO ExitCode
- Darcs.Utils: pAdvancedCharacters :: PromptConfig -> [Char]
- Darcs.Utils: pBasicCharacters :: PromptConfig -> [Char]
- Darcs.Utils: pDefault :: PromptConfig -> Maybe Char
- Darcs.Utils: pHelp :: PromptConfig -> [Char]
- Darcs.Utils: pPrompt :: PromptConfig -> String
- Darcs.Utils: prettyError :: IOError -> String
- Darcs.Utils: prettyException :: SomeException -> String
- Darcs.Utils: promptChar :: PromptConfig -> IO Char
- Darcs.Utils: promptYorn :: [Char] -> IO Bool
- Darcs.Utils: runEditor :: FilePath -> IO ExitCode
- Darcs.Utils: setDarcsEncodings :: IO ()
- Darcs.Utils: showHexLen :: (Integral a, Show a) => Int -> a -> String
- Darcs.Utils: stripCr :: String -> String
- Darcs.Utils: treeHas :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool
- Darcs.Utils: treeHasAnycase :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool
- Darcs.Utils: treeHasDir :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool
- Darcs.Utils: treeHasFile :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool
- Darcs.Utils: withCurrentDirectory :: FilePathLike p => p -> IO a -> IO a
- Darcs.Utils: withUMask :: String -> IO a -> IO a
- Darcs.Witnesses.Eq: (=/\=) :: MyEq p => p a c -> p b c -> EqCheck a b
- Darcs.Witnesses.Eq: (=\/=) :: MyEq p => p a b -> p a c -> EqCheck b c
- Darcs.Witnesses.Eq: IsEq :: EqCheck a a
- Darcs.Witnesses.Eq: NotEq :: EqCheck a b
- Darcs.Witnesses.Eq: class MyEq p where unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b) a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq | otherwise = NotEq a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq | otherwise = NotEq
- Darcs.Witnesses.Eq: data EqCheck a b
- Darcs.Witnesses.Eq: instance Eq (EqCheck a b)
- Darcs.Witnesses.Eq: instance Show (EqCheck a b)
- Darcs.Witnesses.Eq: isIsEq :: EqCheck a b -> Bool
- Darcs.Witnesses.Eq: unsafeCompare :: MyEq p => p a b -> p c d -> Bool
- Darcs.Witnesses.Ordered: (+<+) :: RL a y z -> RL a x y -> RL a x z
- Darcs.Witnesses.Ordered: (+>+) :: FL a x y -> FL a y z -> FL a x z
- Darcs.Witnesses.Ordered: (:/\:) :: (a1 x z) -> (a2 y z) -> :/\: a1 a2 x y
- Darcs.Witnesses.Ordered: (:<) :: (a1 z y) -> (a2 x z) -> :< a1 a2 x y
- Darcs.Witnesses.Ordered: (:<:) :: a y z -> RL a x y -> RL a x z
- Darcs.Witnesses.Ordered: (:>) :: (a1 x z) -> (a2 z y) -> :> a1 a2 x y
- Darcs.Witnesses.Ordered: (:>:) :: a x y -> FL a y z -> FL a x z
- Darcs.Witnesses.Ordered: (:\/:) :: (a1 z x) -> (a2 z y) -> :\/: a1 a2 x y
- Darcs.Witnesses.Ordered: (:||:) :: (a1 x y) -> (a2 x y) -> :||: a1 a2 x y
- Darcs.Witnesses.Ordered: NilFL :: FL a x x
- Darcs.Witnesses.Ordered: NilRL :: RL a x x
- Darcs.Witnesses.Ordered: allFL :: (forall x y. a x y -> Bool) -> FL a w z -> Bool
- Darcs.Witnesses.Ordered: anyFL :: (forall x y. a x y -> Bool) -> FL a w z -> Bool
- Darcs.Witnesses.Ordered: bunchFL :: Int -> FL a x y -> FL (FL a) x y
- Darcs.Witnesses.Ordered: concatFL :: FL (FL a) x z -> FL a x z
- Darcs.Witnesses.Ordered: concatRL :: RL (RL a) x z -> RL a x z
- Darcs.Witnesses.Ordered: consRLSealed :: a y z -> FlippedSeal (RL a) y -> FlippedSeal (RL a) z
- Darcs.Witnesses.Ordered: data (:||:) a1 a2 x y
- Darcs.Witnesses.Ordered: data FL a x z
- Darcs.Witnesses.Ordered: data RL a x z
- Darcs.Witnesses.Ordered: dropWhileFL :: (forall x y. a x y -> Bool) -> FL a r v -> FlippedSeal (FL a) v
- Darcs.Witnesses.Ordered: dropWhileRL :: (forall x y. a x y -> Bool) -> RL a r v -> Sealed (RL a r)
- Darcs.Witnesses.Ordered: eqFL :: MyEq a => FL a x y -> FL a x z -> EqCheck y z
- Darcs.Witnesses.Ordered: eqFLRev :: MyEq a => FL a x z -> FL a y z -> EqCheck x y
- Darcs.Witnesses.Ordered: eqFLUnsafe :: MyEq a => FL a x y -> FL a z w -> Bool
- Darcs.Witnesses.Ordered: filterFL :: (forall x y. a x y -> Bool) -> FL a w z -> [Sealed2 a]
- Darcs.Witnesses.Ordered: filterFLFL :: (forall x y. p x y -> EqCheck x y) -> FL p w z -> FL p w z
- Darcs.Witnesses.Ordered: filterRL :: (forall x y. p x y -> Bool) -> RL p a b -> [Sealed2 p]
- Darcs.Witnesses.Ordered: foldlFL :: (forall w y. a -> b w y -> a) -> a -> FL b x z -> a
- Darcs.Witnesses.Ordered: foldlRL :: (forall w y. a -> b w y -> a) -> a -> RL b x z -> a
- Darcs.Witnesses.Ordered: instance (MyEq a, MyEq b) => Eq ((:<) a b x y)
- Darcs.Witnesses.Ordered: instance (MyEq a, MyEq b) => Eq ((:>) a b x y)
- Darcs.Witnesses.Ordered: instance (MyEq a, MyEq b) => MyEq (a :< b)
- Darcs.Witnesses.Ordered: instance (MyEq a, MyEq b) => MyEq (a :> b)
- Darcs.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show ((:>) a b x y)
- Darcs.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show ((:\/:) a b x y)
- Darcs.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show1 ((:>) a b x)
- Darcs.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show2 (a :> b)
- Darcs.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show2 (a :\/: b)
- Darcs.Witnesses.Ordered: instance Show2 a => Show (FL a x z)
- Darcs.Witnesses.Ordered: instance Show2 a => Show (RL a x z)
- Darcs.Witnesses.Ordered: instance Show2 a => Show1 (FL a x)
- Darcs.Witnesses.Ordered: instance Show2 a => Show1 (RL a x)
- Darcs.Witnesses.Ordered: instance Show2 a => Show2 (FL a)
- Darcs.Witnesses.Ordered: instance Show2 a => Show2 (RL a)
- Darcs.Witnesses.Ordered: isShorterThanRL :: RL a x y -> Int -> Bool
- Darcs.Witnesses.Ordered: lengthFL :: FL a x z -> Int
- Darcs.Witnesses.Ordered: lengthRL :: RL a x z -> Int
- Darcs.Witnesses.Ordered: mapFL :: (forall w z. a w z -> b) -> FL a x y -> [b]
- Darcs.Witnesses.Ordered: mapFL_FL :: (forall w y. a w y -> b w y) -> FL a x z -> FL b x z
- Darcs.Witnesses.Ordered: mapRL :: (forall w z. a w z -> b) -> RL a x y -> [b]
- Darcs.Witnesses.Ordered: mapRL_RL :: (forall w y. a w y -> b w y) -> RL a x z -> RL b x z
- Darcs.Witnesses.Ordered: nullFL :: FL a x z -> Bool
- Darcs.Witnesses.Ordered: nullRL :: RL a x z -> Bool
- Darcs.Witnesses.Ordered: reverseFL :: FL a x z -> RL a x z
- Darcs.Witnesses.Ordered: reverseRL :: RL a x z -> FL a x z
- Darcs.Witnesses.Ordered: spanFL :: (forall w y. a w y -> Bool) -> FL a x z -> (FL a :> FL a) x z
- Darcs.Witnesses.Ordered: spanFL_M :: Monad m => (forall w y. a w y -> m Bool) -> FL a x z -> m ((FL a :> FL a) x z)
- Darcs.Witnesses.Ordered: splitAtFL :: Int -> FL a x z -> (FL a :> FL a) x z
- Darcs.Witnesses.Ordered: splitAtRL :: Int -> RL a x z -> (RL a :< RL a) x z
- Darcs.Witnesses.Ordered: toFL :: [FreeLeft a] -> Sealed (FL a x)
- Darcs.Witnesses.Ordered: zipWithFL :: (forall x y. a -> p x y -> q x y) -> [a] -> FL p w z -> FL q w z
- Darcs.Witnesses.Sealed: FlippedSeal :: !(a x y) -> FlippedSeal a y
- Darcs.Witnesses.Sealed: Sealed :: a x -> Sealed a
- Darcs.Witnesses.Sealed: Sealed2 :: !(a x y) -> Sealed2 a
- Darcs.Witnesses.Sealed: class Gap w
- Darcs.Witnesses.Sealed: data FlippedSeal a y
- Darcs.Witnesses.Sealed: data FreeLeft p
- Darcs.Witnesses.Sealed: data FreeRight p
- Darcs.Witnesses.Sealed: data Sealed a
- Darcs.Witnesses.Sealed: data Sealed2 a
- Darcs.Witnesses.Sealed: emptyGap :: Gap w => (forall x. p x x) -> w p
- Darcs.Witnesses.Sealed: flipSeal :: a x y -> FlippedSeal a y
- Darcs.Witnesses.Sealed: freeGap :: Gap w => (forall x y. p x y) -> w p
- Darcs.Witnesses.Sealed: instance Gap FreeLeft
- Darcs.Witnesses.Sealed: instance Gap FreeRight
- Darcs.Witnesses.Sealed: instance MyEq a => Eq (Sealed (a x))
- Darcs.Witnesses.Sealed: instance Show1 a => Show (Sealed a)
- Darcs.Witnesses.Sealed: instance Show2 a => Show (Sealed2 a)
- Darcs.Witnesses.Sealed: joinGap :: Gap w => (forall x y z. p x y -> q y z -> r x z) -> w p -> w q -> w r
- Darcs.Witnesses.Sealed: liftSM :: Monad m => (forall x. a x -> b) -> m (Sealed a) -> m b
- Darcs.Witnesses.Sealed: mapFlipped :: (forall x. a x y -> b x z) -> FlippedSeal a y -> FlippedSeal b z
- Darcs.Witnesses.Sealed: mapSeal :: (forall x. a x -> b x) -> Sealed a -> Sealed b
- Darcs.Witnesses.Sealed: mapSeal2 :: (forall x y. a x y -> b x y) -> Sealed2 a -> Sealed2 b
- Darcs.Witnesses.Sealed: seal :: a x -> Sealed a
- Darcs.Witnesses.Sealed: seal2 :: a x y -> Sealed2 a
- Darcs.Witnesses.Sealed: unFreeLeft :: FreeLeft p -> Sealed (p x)
- Darcs.Witnesses.Sealed: unFreeRight :: FreeRight p -> FlippedSeal p x
- Darcs.Witnesses.Sealed: unsafeUnseal :: Sealed a -> a x
- Darcs.Witnesses.Sealed: unsafeUnseal2 :: Sealed2 a -> a x y
- Darcs.Witnesses.Sealed: unsafeUnsealFlipped :: FlippedSeal a y -> a x y
- Darcs.Witnesses.Sealed: unseal :: (forall x. a x -> b) -> Sealed a -> b
- Darcs.Witnesses.Sealed: unseal2 :: (forall x y. a x y -> b) -> Sealed2 a -> b
- Darcs.Witnesses.Sealed: unsealFlipped :: (forall x y. a x y -> b) -> FlippedSeal a z -> b
- Darcs.Witnesses.Sealed: unsealM :: Monad m => m (Sealed a) -> (forall x. a x -> m b) -> m b
- Darcs.Witnesses.Show: ShowDictClass :: ShowDict a
- Darcs.Witnesses.Show: ShowDictRecord :: (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> ShowDict a
- Darcs.Witnesses.Show: appPrec :: Int
- Darcs.Witnesses.Show: class Show1 a
- Darcs.Witnesses.Show: class Show2 a
- Darcs.Witnesses.Show: data ShowDict a
- Darcs.Witnesses.Show: show1 :: Show1 a => a x -> String
- Darcs.Witnesses.Show: show2 :: Show2 a => a x y -> String
- Darcs.Witnesses.Show: showD :: ShowDict a -> a -> String
- Darcs.Witnesses.Show: showDict1 :: Show1 a => ShowDict (a x)
- Darcs.Witnesses.Show: showDict2 :: Show2 a => ShowDict (a x y)
- Darcs.Witnesses.Show: showListD :: ShowDict a -> [a] -> ShowS
- Darcs.Witnesses.Show: showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a w x -> b y z -> String -> String
- Darcs.Witnesses.Show: showsPrec1 :: Show1 a => Int -> a x -> ShowS
- Darcs.Witnesses.Show: showsPrec2 :: Show2 a => Int -> a x y -> ShowS
- Darcs.Witnesses.Show: showsPrecD :: ShowDict a -> Int -> a -> ShowS
- Darcs.Witnesses.Unsafe: unsafeCoerceP :: a x y -> a b c
- Darcs.Witnesses.Unsafe: unsafeCoerceP1 :: a x -> a y
- Darcs.Witnesses.Unsafe: unsafeCoerceP2 :: t w x y z -> t a b c d
- Darcs.Witnesses.Unsafe: unsafeCoercePEnd :: a x y1 -> a x y2
- Darcs.Witnesses.Unsafe: unsafeCoercePStart :: a x1 y -> a x2 y
- Darcs.Witnesses.WZipper: FZipper :: RL a x y -> FL a y z -> FZipper a x z
- Darcs.Witnesses.WZipper: clowns :: FZipper a x y -> Sealed ((RL a) x)
- Darcs.Witnesses.WZipper: data FZipper a x z
- Darcs.Witnesses.WZipper: flToZipper :: FL a x y -> FZipper a x y
- Darcs.Witnesses.WZipper: focus :: FZipper a x y -> Maybe (Sealed2 a)
- Darcs.Witnesses.WZipper: jokers :: FZipper a x y -> FlippedSeal (FL a) y
- Darcs.Witnesses.WZipper: left :: FZipper p x y -> FZipper p x y
- Darcs.Witnesses.WZipper: leftmost :: FZipper p x y -> Bool
- Darcs.Witnesses.WZipper: lengthFZ :: FZipper a x y -> Int
- Darcs.Witnesses.WZipper: nullFZ :: FZipper a x y -> Bool
- Darcs.Witnesses.WZipper: right :: FZipper p x y -> FZipper p x y
- Darcs.Witnesses.WZipper: rightmost :: FZipper p x y -> Bool
- Darcs.Witnesses.WZipper: toEnd :: FZipper p x y -> FZipper p x y
- Darcs.Witnesses.WZipper: toStart :: FZipper p x y -> FZipper p x y
- DateMatcher: DM :: String -> (Either ParseError d) -> (d -> CalendarTime -> Bool) -> DateMatcher
- DateMatcher: data DateMatcher
- DateMatcher: getMatchers :: String -> IO [DateMatcher]
- DateMatcher: parseDateMatcher :: String -> IO (CalendarTime -> Bool)
- Encoding: decode :: ByteString -> IO String
- Encoding: encode :: String -> IO ByteString
- English: It :: Pronoun
- English: Noun :: String -> Noun
- English: This :: Noun -> This
- English: andClauses :: [String] -> String
- English: class Countable a
- English: data Pronoun
- English: data This
- English: englishNum :: Countable n => Int -> n -> ShowS
- English: instance Countable Noun
- English: instance Countable Pronoun
- English: instance Countable This
- English: intersperseLast :: String -> String -> [String] -> String
- English: newtype Noun
- English: orClauses :: [String] -> String
- English: plural :: Countable a => a -> ShowS
- English: presentParticiple :: String -> String
- English: singular :: Countable a => a -> ShowS
- Exec: AsIs :: Redirect
- Exec: ExecException :: String -> [String] -> Redirects -> String -> ExecException
- Exec: File :: FilePath -> Redirect
- Exec: Null :: Redirect
- Exec: Stdout :: Redirect
- Exec: data ExecException
- Exec: data Redirect
- Exec: exec :: String -> [String] -> Redirects -> IO ExitCode
- Exec: execInteractive :: String -> String -> IO ExitCode
- Exec: instance Exception ExecException
- Exec: instance Show ExecException
- Exec: instance Show Redirect
- Exec: instance Typeable ExecException
- Exec: type Redirects = (Redirect, Redirect, Redirect)
- Exec: withoutNonBlock :: IO a -> IO a
- IsoDate: MCalendarTime :: Maybe Int -> Maybe Month -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Integer -> Maybe Day -> Maybe Int -> Maybe String -> Maybe Int -> Maybe Bool -> Bool -> MCalendarTime
- IsoDate: addToMCal :: TimeDiff -> MCalendarTime -> MCalendarTime
- IsoDate: cleanLocalDate :: String -> String
- IsoDate: data MCalendarTime
- IsoDate: englishDateTime :: CalendarTime -> CharParser a CalendarTime
- IsoDate: englishInterval :: CalendarTime -> CharParser a TimeInterval
- IsoDate: englishLast :: CalendarTime -> CharParser a (CalendarTime, CalendarTime)
- IsoDate: getIsoDateTime :: IO String
- IsoDate: getLocalTz :: IO Int
- IsoDate: instance Show MCalendarTime
- IsoDate: iso8601Duration :: CharParser a TimeDiff
- IsoDate: iso8601Interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime))
- IsoDate: mctDay :: MCalendarTime -> Maybe Int
- IsoDate: mctHour :: MCalendarTime -> Maybe Int
- IsoDate: mctIsDST :: MCalendarTime -> Maybe Bool
- IsoDate: mctMin :: MCalendarTime -> Maybe Int
- IsoDate: mctMonth :: MCalendarTime -> Maybe Month
- IsoDate: mctPicosec :: MCalendarTime -> Maybe Integer
- IsoDate: mctSec :: MCalendarTime -> Maybe Int
- IsoDate: mctTZ :: MCalendarTime -> Maybe Int
- IsoDate: mctTZName :: MCalendarTime -> Maybe String
- IsoDate: mctWDay :: MCalendarTime -> Maybe Day
- IsoDate: mctWeek :: MCalendarTime -> Bool
- IsoDate: mctYDay :: MCalendarTime -> Maybe Int
- IsoDate: mctYear :: MCalendarTime -> Maybe Int
- IsoDate: parseDate :: Int -> String -> Either ParseError MCalendarTime
- IsoDate: readLocalDate :: String -> CalendarTime
- IsoDate: readUTCDate :: String -> CalendarTime
- IsoDate: resetCalendar :: CalendarTime -> CalendarTime
- IsoDate: subtractFromMCal :: TimeDiff -> MCalendarTime -> MCalendarTime
- IsoDate: toMCalendarTime :: CalendarTime -> MCalendarTime
- IsoDate: type TimeInterval = (Maybe CalendarTime, Maybe CalendarTime)
- IsoDate: unsafeToCalendarTime :: MCalendarTime -> CalendarTime
- IsoDate: unsetTime :: CalendarTime -> CalendarTime
- Lcs: getChanges :: [ByteString] -> [ByteString] -> [(Int, [ByteString], [ByteString])]
- Lcs: shiftBoundaries :: BSTArray s -> BSTArray s -> PArray -> Int -> Int -> ST s ()
- Printer: ($$) :: Doc -> Doc -> Doc
- Printer: (<+>) :: Doc -> Doc -> Doc
- Printer: (<>) :: Doc -> Doc -> Doc
- Printer: (<?>) :: Doc -> Doc -> Doc
- Printer: Blue :: Color
- Printer: Both :: !String -> !ByteString -> Printable
- Printer: Cyan :: Color
- Printer: Doc :: (St -> Document) -> Doc
- Printer: Green :: Color
- Printer: Magenta :: Color
- Printer: PS :: !ByteString -> Printable
- Printer: Printers :: !(Color -> Printer) -> !Printer -> !Printer -> !Printer -> !Printer -> !(Color -> Doc -> Doc) -> !([Printable] -> [Printable]) -> Printers'
- Printer: Red :: Color
- Printer: S :: !String -> Printable
- Printer: backslash :: Doc
- Printer: blueText :: String -> Doc
- Printer: colorP :: Printers' -> !(Color -> Printer)
- Printer: colorText :: Color -> String -> Doc
- Printer: cyanText :: String -> Doc
- Printer: data Color
- Printer: data Printable
- Printer: data Printers'
- Printer: defP :: Printers' -> !Printer
- Printer: doc :: ([Printable] -> [Printable]) -> Doc
- Printer: empty :: Doc
- Printer: errorDoc :: Doc -> a
- Printer: greenText :: String -> Doc
- Printer: hPutDoc :: Handle -> Doc -> IO ()
- Printer: hPutDocLn :: Handle -> Doc -> IO ()
- Printer: hPutDocLnWith :: Printers -> Handle -> Doc -> IO ()
- Printer: hPutDocWith :: Printers -> Handle -> Doc -> IO ()
- Printer: hcat :: [Doc] -> Doc
- Printer: hiddenP :: Printers' -> !Printer
- Printer: hiddenPrefix :: String -> Doc -> Doc
- Printer: hiddenText :: String -> Doc
- Printer: insertBeforeLastline :: Doc -> Doc -> Doc
- Printer: invisibleP :: Printers' -> !Printer
- Printer: invisiblePS :: ByteString -> Doc
- Printer: invisiblePrinter :: Printer
- Printer: invisibleText :: String -> Doc
- Printer: lineColor :: Color -> Doc -> Doc
- Printer: lineColorS :: Printers' -> !([Printable] -> [Printable])
- Printer: lineColorT :: Printers' -> !(Color -> Doc -> Doc)
- Printer: lparen :: Doc
- Printer: magentaText :: String -> Doc
- Printer: minus :: Doc
- Printer: newline :: Doc
- Printer: newtype Doc
- Printer: packedString :: ByteString -> Doc
- Printer: parens :: Doc -> Doc
- Printer: plus :: Doc
- Printer: prefix :: String -> Doc -> Doc
- Printer: printable :: Printable -> Doc
- Printer: putDoc :: Doc -> IO ()
- Printer: putDocLn :: Doc -> IO ()
- Printer: putDocLnWith :: Printers -> Doc -> IO ()
- Printer: putDocWith :: Printers -> Doc -> IO ()
- Printer: redText :: String -> Doc
- Printer: renderPS :: Doc -> ByteString
- Printer: renderPSWith :: Printers' -> Doc -> ByteString
- Printer: renderPSs :: Doc -> [ByteString]
- Printer: renderPSsWith :: Printers' -> Doc -> [ByteString]
- Printer: renderString :: Doc -> String
- Printer: renderStringWith :: Printers' -> Doc -> String
- Printer: rparen :: Doc
- Printer: simplePrinter :: Printer
- Printer: simplePrinters :: Printers
- Printer: space :: Doc
- Printer: text :: String -> Doc
- Printer: type Printer = Printable -> St -> Document
- Printer: type Printers = Handle -> Printers'
- Printer: unDoc :: Doc -> St -> Document
- Printer: unsafeBoth :: String -> ByteString -> Doc
- Printer: unsafeBothText :: String -> Doc
- Printer: unsafeChar :: Char -> Doc
- Printer: unsafePackedString :: ByteString -> Doc
- Printer: unsafeText :: String -> Doc
- Printer: userchunk :: String -> Doc
- Printer: userchunkP :: Printers' -> !Printer
- Printer: userchunkPS :: ByteString -> Doc
- Printer: vcat :: [Doc] -> Doc
- Printer: vsep :: [Doc] -> Doc
- Printer: wrapText :: Int -> String -> Doc
- Progress: beginTedious :: String -> IO ()
- Progress: debugFail :: String -> IO a
- Progress: debugMessage :: String -> IO ()
- Progress: endTedious :: String -> IO ()
- Progress: finishedOne :: String -> String -> a -> a
- Progress: finishedOneIO :: String -> String -> IO ()
- Progress: minlist :: Int
- Progress: progress :: String -> a -> a
- Progress: progressKeepLatest :: String -> a -> a
- Progress: progressList :: String -> [a] -> [a]
- Progress: setProgressMode :: Bool -> IO ()
- Progress: tediousSize :: String -> Int -> IO ()
- Progress: withoutProgress :: IO a -> IO a
- Ratified: hGetContents :: Handle -> IO String
- Ratified: readFile :: FilePath -> IO String
- SHA1: sha1PS :: ByteString -> String
- URL: Cachable :: Cachable
- URL: CouldNotConnectToServer :: ConnectionError
- URL: CouldNotResolveHost :: ConnectionError
- URL: MaxAge :: !CInt -> Cachable
- URL: OperationTimeout :: ConnectionError
- URL: Uncachable :: Cachable
- URL: copyUrl :: String -> FilePath -> Cachable -> IO ()
- URL: copyUrlFirst :: String -> FilePath -> Cachable -> IO ()
- URL: data Cachable
- URL: data ConnectionError
- URL: disableHTTPPipelining :: IO ()
- URL: environmentHelpProxy :: ([String], [String])
- URL: environmentHelpProxyPassword :: ([String], [String])
- URL: maxPipelineLength :: IO Int
- URL: setDebugHTTP :: IO ()
- URL: waitUrl :: String -> IO ()
- URL.HTTP: fetchUrl :: String -> IO String
- URL.HTTP: postUrl :: String -> String -> String -> IO ()
- URL.HTTP: requestUrl :: String -> FilePath -> a -> IO String
- URL.HTTP: waitNextUrl :: IO (String, String, Maybe ConnectionError)
- URL.Request: Cachable :: Cachable
- URL.Request: CouldNotConnectToServer :: ConnectionError
- URL.Request: CouldNotResolveHost :: ConnectionError
- URL.Request: High :: Priority
- URL.Request: Low :: Priority
- URL.Request: MaxAge :: !CInt -> Cachable
- URL.Request: OperationTimeout :: ConnectionError
- URL.Request: Q :: [a] -> [a] -> Q a
- URL.Request: Uncachable :: Cachable
- URL.Request: UrlRequest :: String -> FilePath -> Cachable -> Priority -> UrlRequest
- URL.Request: UrlState :: Map String (FilePath, [FilePath], Cachable) -> Q String -> Int -> String -> UrlState
- URL.Request: cachable :: UrlRequest -> Cachable
- URL.Request: data Cachable
- URL.Request: data ConnectionError
- URL.Request: data Priority
- URL.Request: data Q a
- URL.Request: data UrlRequest
- URL.Request: data UrlState
- URL.Request: deleteQ :: Eq a => a -> Q a -> Q a
- URL.Request: elemQ :: Eq a => a -> Q a -> Bool
- URL.Request: emptyQ :: Q a
- URL.Request: file :: UrlRequest -> FilePath
- URL.Request: inProgress :: UrlState -> Map String (FilePath, [FilePath], Cachable)
- URL.Request: insertQ :: a -> Q a -> Q a
- URL.Request: instance Eq Cachable
- URL.Request: instance Eq ConnectionError
- URL.Request: instance Eq Priority
- URL.Request: instance Read ConnectionError
- URL.Request: instance Show Cachable
- URL.Request: instance Show ConnectionError
- URL.Request: nullQ :: Q a -> Bool
- URL.Request: pipeLength :: UrlState -> Int
- URL.Request: priority :: UrlRequest -> Priority
- URL.Request: pushQ :: a -> Q a -> Q a
- URL.Request: randomJunk :: UrlState -> String
- URL.Request: readQ :: Q a -> Maybe (a, Q a)
- URL.Request: url :: UrlRequest -> String
- URL.Request: waitToStart :: UrlState -> Q String
- Workaround: Catch :: IO () -> Handler
- Workaround: CatchOnce :: IO () -> Handler
- Workaround: Default :: Handler
- Workaround: Ignore :: Handler
- Workaround: data Handler :: *
- Workaround: getCurrentDirectory :: IO FilePath
- Workaround: installHandler :: Signal -> Handler -> Maybe SignalSet -> IO Handler
- Workaround: raiseSignal :: Signal -> IO ()
- Workaround: renameFile :: FilePath -> FilePath -> IO ()
- Workaround: setExecutable :: FilePath -> Bool -> IO ()
- Workaround: sigABRT :: CInt
- Workaround: sigALRM :: CInt
- Workaround: sigHUP :: CInt
- Workaround: sigINT :: CInt
- Workaround: sigPIPE :: CInt
- Workaround: sigTERM :: CInt
- Workaround: type Signal = CInt
+ Darcs.Patch: instance (Patchy p, NameHack p, ApplyState p ~ Tree) => Patchy (Named p)
+ Darcs.Patch.Annotate: annotate :: (Apply p, ApplyState p ~ Tree) => DiffAlgorithm -> FL (PatchInfoAnd p) wX wY -> FileName -> ByteString -> AnnotateResult
+ Darcs.Patch.Annotate: annotateDirectory :: (Apply p, ApplyState p ~ Tree) => DiffAlgorithm -> FL (PatchInfoAnd p) wX wY -> FileName -> [FileName] -> AnnotateResult
+ Darcs.Patch.Annotate: format :: ByteString -> AnnotateResult -> String
+ Darcs.Patch.Annotate: instance ApplyMonad AnnotatedM Tree
+ Darcs.Patch.Annotate: instance Eq FileOrDirectory
+ Darcs.Patch.Annotate: instance Show Annotated
+ Darcs.Patch.Annotate: instance Show FileOrDirectory
+ Darcs.Patch.Annotate: machineFormat :: ByteString -> AnnotateResult -> String
+ Darcs.Patch.Annotate: type AnnotateResult = Vector (Maybe PatchInfo, ByteString)
+ Darcs.Patch.Apply: applyToFileMods :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Set FileName -> (Set FileName, [PatchMod FileName])
+ Darcs.Patch.ApplyPatches: applyPatches :: (MonadProgress m, ApplyMonad m (ApplyState p), Patchy p) => FL (PatchInfoAnd p) wX wY -> m ()
+ Darcs.Patch.Bracketed: mapBracketedFLFL :: (forall wA wB. p wA wB -> q wA wB) -> BracketedFL p wX wY -> BracketedFL q wX wY
+ Darcs.Patch.Bundle: minContext :: RepoPatch p => PatchSet p wStart wB -> FL (PatchInfoAnd p) wB wC -> Sealed ((PatchSet p :> FL (PatchInfoAnd p)) wStart)
+ Darcs.Patch.Bundle: scanContextFile :: RepoPatch p => FilePath -> IO (PatchSet p Origin wX)
+ Darcs.Patch.Choices: data Label
+ Darcs.Patch.Choices: data LabelledPatch p wX wY
+ Darcs.Patch.Choices: instance Commute p => Commute (LabelledPatch p)
+ Darcs.Patch.Choices: instance Eq Label
+ Darcs.Patch.Choices: instance Invert p => Invert (LabelledPatch p)
+ Darcs.Patch.Choices: instance Merge p => Merge (LabelledPatch p)
+ Darcs.Patch.Choices: instance MyEq p => MyEq (LabelledPatch p)
+ Darcs.Patch.Choices: instance Ord Label
+ Darcs.Patch.Choices: instance PatchInspect p => PatchInspect (LabelledPatch p)
+ Darcs.Patch.Choices: label :: LabelledPatch p wX wY -> Label
+ Darcs.Patch.Choices: lpPatch :: LabelledPatch p wX wY -> p wX wY
+ Darcs.Patch.Choices: patchChoicesLps :: Patchy p => FL p wX wY -> (PatchChoices p wX wY, FL (LabelledPatch p) wX wY)
+ Darcs.Patch.Choices: patchChoicesLpsSub :: Patchy p => Maybe Label -> FL p wX wY -> (PatchChoices p wX wY, FL (LabelledPatch p) wX wY)
+ Darcs.Patch.Commute: selfCommuter :: Commute p => CommuteFn p p
+ Darcs.Patch.CommuteFn: commuterFLId :: CommuteFn p1 p2 -> CommuteFn (FL p1) p2
+ Darcs.Patch.CommuteFn: commuterIdFL :: CommuteFn p1 p2 -> CommuteFn p1 (FL p2)
+ Darcs.Patch.CommuteFn: commuterIdRL :: CommuteFn p1 p2 -> CommuteFn p1 (RL p2)
+ Darcs.Patch.CommuteFn: commuterRLId :: CommuteFn p1 p2 -> CommuteFn (RL p1) p2
+ Darcs.Patch.CommuteFn: mergerIdFL :: MergeFn p1 p2 -> MergeFn p1 (FL p2)
+ Darcs.Patch.CommuteFn: totalCommuterFLFL :: TotalCommuteFn p1 p2 -> TotalCommuteFn (FL p1) (FL p2)
+ Darcs.Patch.CommuteFn: totalCommuterFLId :: TotalCommuteFn p1 p2 -> TotalCommuteFn (FL p1) p2
+ Darcs.Patch.CommuteFn: totalCommuterIdFL :: TotalCommuteFn p1 p2 -> TotalCommuteFn p1 (FL p2)
+ Darcs.Patch.CommuteFn: type CommuteFn p1 p2 = forall wX wY. (p1 :> p2) wX wY -> Maybe ((p2 :> p1) wX wY)
+ Darcs.Patch.CommuteFn: type MergeFn p1 p2 = forall wX wY. (p1 :\/: p2) wX wY -> (p2 :/\: p1) wX wY
+ Darcs.Patch.CommuteFn: type TotalCommuteFn p1 p2 = forall wX wY. (p1 :> p2) wX wY -> (p2 :> p1) wX wY
+ Darcs.Patch.Conflict: instance Show2 prim => Show (IsConflictedPrim prim)
+ Darcs.Patch.Debug: class PatchDebug p where patchDebugDummy _ = ()
+ Darcs.Patch.Debug: instance PatchDebug p => PatchDebug (FL p)
+ Darcs.Patch.Debug: instance PatchDebug p => PatchDebug (RL p)
+ Darcs.Patch.Debug: patchDebugDummy :: PatchDebug p => p wX wY -> ()
+ Darcs.Patch.Depends: findCommonAndUncommon :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> Fork (PatchSet p) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wStart wX wY
+ Darcs.Patch.Depends: getUncovered :: PatchSet p wStart wX -> [PatchInfo]
+ Darcs.Patch.Dummy: instance Apply DummyPrim
+ Darcs.Patch.Dummy: instance Check DummyPatch
+ Darcs.Patch.Dummy: instance Commute DummyPrim
+ Darcs.Patch.Dummy: instance CommuteNoConflicts DummyPatch
+ Darcs.Patch.Dummy: instance Conflict DummyPatch
+ Darcs.Patch.Dummy: instance Effect DummyPatch
+ Darcs.Patch.Dummy: instance FromPrim DummyPatch
+ Darcs.Patch.Dummy: instance Invert DummyPrim
+ Darcs.Patch.Dummy: instance IsHunk DummyPrim
+ Darcs.Patch.Dummy: instance Matchable DummyPatch
+ Darcs.Patch.Dummy: instance MaybeInternal DummyPatch
+ Darcs.Patch.Dummy: instance Merge DummyPatch
+ Darcs.Patch.Dummy: instance MyEq DummyPrim
+ Darcs.Patch.Dummy: instance NameHack DummyPatch
+ Darcs.Patch.Dummy: instance PatchDebug DummyPatch
+ Darcs.Patch.Dummy: instance PatchDebug DummyPrim
+ Darcs.Patch.Dummy: instance PatchInspect DummyPrim
+ Darcs.Patch.Dummy: instance PatchListFormat DummyPrim
+ Darcs.Patch.Dummy: instance Patchy DummyPrim
+ Darcs.Patch.Dummy: instance PrimApply DummyPrim
+ Darcs.Patch.Dummy: instance PrimCanonize DummyPrim
+ Darcs.Patch.Dummy: instance PrimClassify DummyPrim
+ Darcs.Patch.Dummy: instance PrimConstruct DummyPrim
+ Darcs.Patch.Dummy: instance PrimDetails DummyPrim
+ Darcs.Patch.Dummy: instance PrimPatch DummyPrim
+ Darcs.Patch.Dummy: instance PrimPatchBase DummyPatch
+ Darcs.Patch.Dummy: instance PrimRead DummyPrim
+ Darcs.Patch.Dummy: instance PrimShow DummyPrim
+ Darcs.Patch.Dummy: instance ReadPatch DummyPrim
+ Darcs.Patch.Dummy: instance RecontextRebase DummyPatch
+ Darcs.Patch.Dummy: instance RepairToFL DummyPatch
+ Darcs.Patch.Dummy: instance RepairToFL DummyPrim
+ Darcs.Patch.Dummy: instance RepoPatch DummyPatch
+ Darcs.Patch.Dummy: instance ShowPatch DummyPrim
+ Darcs.Patch.Dummy: instance ShowPatchBasic DummyPrim
+ Darcs.Patch.Format: copyListFormat :: ListFormat p -> ListFormat q
+ Darcs.Patch.Index.Monad: data FileModMonad a
+ Darcs.Patch.Index.Monad: instance Applicative FileModMonad
+ Darcs.Patch.Index.Monad: instance ApplyMonad FileModMonad Tree
+ Darcs.Patch.Index.Monad: instance Functor FileModMonad
+ Darcs.Patch.Index.Monad: instance Monad FileModMonad
+ Darcs.Patch.Index.Monad: instance MonadState (Set FileName, [PatchMod FileName]) FileModMonad
+ Darcs.Patch.Index.Monad: withPatchMods :: FileModMonad a -> Set FileName -> (Set FileName, [PatchMod FileName])
+ Darcs.Patch.Index.Types: DatedFilePath :: FilePath -> (Maybe PatchId) -> DatedFilePath
+ Darcs.Patch.Index.Types: FileId :: FileName -> Int -> FileId
+ Darcs.Patch.Index.Types: PCreateDir :: a -> PatchMod a
+ Darcs.Patch.Index.Types: PCreateFile :: a -> PatchMod a
+ Darcs.Patch.Index.Types: PDuplicateTouch :: a -> PatchMod a
+ Darcs.Patch.Index.Types: PID :: SHA1 -> PatchId
+ Darcs.Patch.Index.Types: PInvalid :: a -> PatchMod a
+ Darcs.Patch.Index.Types: PRemove :: a -> PatchMod a
+ Darcs.Patch.Index.Types: PRename :: a -> a -> PatchMod a
+ Darcs.Patch.Index.Types: PTouch :: a -> PatchMod a
+ Darcs.Patch.Index.Types: cname :: FileId -> FileName
+ Darcs.Patch.Index.Types: count :: FileId -> Int
+ Darcs.Patch.Index.Types: data DatedFilePath
+ Darcs.Patch.Index.Types: data FileId
+ Darcs.Patch.Index.Types: data PatchMod a
+ Darcs.Patch.Index.Types: instance Binary FileId
+ Darcs.Patch.Index.Types: instance Binary PatchId
+ Darcs.Patch.Index.Types: instance Eq FileId
+ Darcs.Patch.Index.Types: instance Eq PatchId
+ Darcs.Patch.Index.Types: instance Eq a => Eq (PatchMod a)
+ Darcs.Patch.Index.Types: instance Functor PatchMod
+ Darcs.Patch.Index.Types: instance Ord FileId
+ Darcs.Patch.Index.Types: instance Ord PatchId
+ Darcs.Patch.Index.Types: instance Show FileId
+ Darcs.Patch.Index.Types: instance Show PatchId
+ Darcs.Patch.Index.Types: instance Show a => Show (PatchMod a)
+ Darcs.Patch.Index.Types: makePatchID :: PatchInfo -> PatchId
+ Darcs.Patch.Index.Types: newtype PatchId
+ Darcs.Patch.Index.Types: parseFileId :: String -> FileId
+ Darcs.Patch.Index.Types: patchId :: PatchId -> SHA1
+ Darcs.Patch.Index.Types: pid2string :: PatchId -> String
+ Darcs.Patch.Index.Types: short :: PatchId -> Word32
+ Darcs.Patch.Index.Types: showFileId :: FileId -> String
+ Darcs.Patch.Info: rawPatchInfo :: String -> String -> String -> [String] -> Bool -> PatchInfo
+ Darcs.Patch.Info: showPatchInfoUI :: PatchInfo -> Doc
+ Darcs.Patch.Invert: instance Invert p => Invert (FL p)
+ Darcs.Patch.Invert: instance Invert p => Invert (RL p)
+ Darcs.Patch.Match: AfterHash :: String -> MatchFlag
+ Darcs.Patch.Match: AfterPatch :: String -> MatchFlag
+ Darcs.Patch.Match: AfterPattern :: String -> MatchFlag
+ Darcs.Patch.Match: AfterTag :: String -> MatchFlag
+ Darcs.Patch.Match: Context :: AbsolutePath -> MatchFlag
+ Darcs.Patch.Match: Exclusive :: InclusiveOrExclusive
+ Darcs.Patch.Match: Inclusive :: InclusiveOrExclusive
+ Darcs.Patch.Match: LastN :: Int -> MatchFlag
+ Darcs.Patch.Match: OneHash :: String -> MatchFlag
+ Darcs.Patch.Match: OnePatch :: String -> MatchFlag
+ Darcs.Patch.Match: OnePattern :: String -> MatchFlag
+ Darcs.Patch.Match: OneTag :: String -> MatchFlag
+ Darcs.Patch.Match: PatchIndexRange :: Int -> Int -> MatchFlag
+ Darcs.Patch.Match: SeveralPatch :: String -> MatchFlag
+ Darcs.Patch.Match: SeveralPattern :: String -> MatchFlag
+ Darcs.Patch.Match: UpToHash :: String -> MatchFlag
+ Darcs.Patch.Match: UpToPatch :: String -> MatchFlag
+ Darcs.Patch.Match: UpToPattern :: String -> MatchFlag
+ Darcs.Patch.Match: UpToTag :: String -> MatchFlag
+ Darcs.Patch.Match: addInternalMatcher :: Matchable p => Maybe (Matcher p) -> Maybe (Matcher p)
+ Darcs.Patch.Match: applyInvToMatcher :: (Matchable p, ApplyMonad m (ApplyState p)) => InclusiveOrExclusive -> Matcher p -> PatchSet p Origin wX -> m ()
+ Darcs.Patch.Match: applyNInv :: (Matchable p, ApplyMonad m (ApplyState p)) => Int -> PatchSet p Origin wX -> m ()
+ Darcs.Patch.Match: checkMatchSyntax :: [MatchFlag] -> IO ()
+ Darcs.Patch.Match: data InclusiveOrExclusive
+ Darcs.Patch.Match: data MatchFlag
+ Darcs.Patch.Match: firstMatch :: [MatchFlag] -> Bool
+ Darcs.Patch.Match: getFirstMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, Matchable p) => [MatchFlag] -> PatchSet p Origin wX -> m ()
+ Darcs.Patch.Match: getMatchingTag :: Matchable p => Matcher p -> PatchSet p wStart wX -> SealedPatchSet p wStart
+ Darcs.Patch.Match: getNonrangeMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, Matchable p, ApplyState p ~ Tree) => [MatchFlag] -> PatchSet p Origin wX -> m ()
+ Darcs.Patch.Match: hasIndexRange :: [MatchFlag] -> Maybe (Int, Int)
+ Darcs.Patch.Match: haveNonrangeMatch :: Matchable p => PatchType p -> [MatchFlag] -> Bool
+ Darcs.Patch.Match: havePatchsetMatch :: [MatchFlag] -> Bool
+ Darcs.Patch.Match: instance Eq InclusiveOrExclusive
+ Darcs.Patch.Match: instance Show MatchFlag
+ Darcs.Patch.Match: matchAPatch :: Matchable p => [MatchFlag] -> Named p wX wY -> Bool
+ Darcs.Patch.Match: matchAPatchread :: Matchable p => [MatchFlag] -> PatchInfoAnd p wX wY -> Bool
+ Darcs.Patch.Match: matchAPatchset :: Matchable p => Matcher p -> PatchSet p wStart wX -> SealedPatchSet p wStart
+ Darcs.Patch.Match: matchExists :: Matcher p -> PatchSet p wStart wX -> Bool
+ Darcs.Patch.Match: matchFirstPatchset :: Matchable p => [MatchFlag] -> PatchSet p wStart wX -> SealedPatchSet p wStart
+ Darcs.Patch.Match: matchPatch :: Matchable p => [MatchFlag] -> PatchSet p wStart wX -> Sealed2 (Named p)
+ Darcs.Patch.Match: matchSecondPatchset :: Matchable p => [MatchFlag] -> PatchSet p wStart wX -> SealedPatchSet p wStart
+ Darcs.Patch.Match: nonrangeMatcher :: Matchable p => [MatchFlag] -> Maybe (Matcher p)
+ Darcs.Patch.Match: nonrangeMatcherIsTag :: [MatchFlag] -> Bool
+ Darcs.Patch.Match: secondMatch :: [MatchFlag] -> Bool
+ Darcs.Patch.Match: splitSecondFL :: Matchable p => (forall wA wB. q wA wB -> Sealed2 (Named p)) -> [MatchFlag] -> FL q wX wY -> (FL q :> FL q) wX wY
+ Darcs.Patch.Matchable: class (Patchy p, PatchInspect p, MaybeInternal p, NameHack p) => Matchable p
+ Darcs.Patch.MaybeInternal: InternalChecker :: (forall wX wY. p wX wY -> EqCheck wX wY) -> InternalChecker p
+ Darcs.Patch.MaybeInternal: class MaybeInternal p where patchInternalChecker = Nothing
+ Darcs.Patch.MaybeInternal: flIsInternal :: MaybeInternal p => FL p wX wY -> EqCheck wX wY
+ Darcs.Patch.MaybeInternal: isInternal :: InternalChecker p -> forall wX wY. p wX wY -> EqCheck wX wY
+ Darcs.Patch.MaybeInternal: newtype InternalChecker p
+ Darcs.Patch.MaybeInternal: patchInternalChecker :: MaybeInternal p => Maybe (InternalChecker (FL p))
+ Darcs.Patch.Merge: selfMerger :: Merge p => MergeFn p p
+ Darcs.Patch.MonadProgress: ProgressAction :: m a -> Doc -> Doc -> ProgressAction m a
+ Darcs.Patch.MonadProgress: class Monad m => MonadProgress m
+ Darcs.Patch.MonadProgress: data ProgressAction m a
+ Darcs.Patch.MonadProgress: instance (Functor m, Monad m) => MonadProgress (TreeMonad m)
+ Darcs.Patch.MonadProgress: paAction :: ProgressAction m a -> m a
+ Darcs.Patch.MonadProgress: paMessage :: ProgressAction m a -> Doc
+ Darcs.Patch.MonadProgress: paOnError :: ProgressAction m a -> Doc
+ Darcs.Patch.MonadProgress: runProgressActions :: MonadProgress m => String -> [ProgressAction m ()] -> m ()
+ Darcs.Patch.MonadProgress: silentlyRunProgressActions :: Monad m => String -> [ProgressAction m ()] -> m ()
+ Darcs.Patch.Named: commuterIdNamed :: CommuteFn p1 p2 -> CommuteFn p1 (Named p2)
+ Darcs.Patch.Named: commuterNamedId :: CommuteFn p1 p2 -> CommuteFn (Named p1) p2
+ Darcs.Patch.Named: instance (Commute p, NameHack p) => Commute (Named p)
+ Darcs.Patch.Named: instance (Merge p, NameHack p) => Merge (Named p)
+ Darcs.Patch.Named: instance Invert p => Invert (Named p)
+ Darcs.Patch.Named: instance PatchDebug p => PatchDebug (Named p)
+ Darcs.Patch.Named: instance Show2 p => Show (Named p wX wY)
+ Darcs.Patch.Named: instance Show2 p => Show1 (Named p wX)
+ Darcs.Patch.Named: instance Show2 p => Show2 (Named p)
+ Darcs.Patch.Named: mergerIdNamed :: MergeFn p1 p2 -> MergeFn p1 (Named p2)
+ Darcs.Patch.PatchInfoAnd: Actually :: (a wX wY) -> SimpleHopefully a wX wY
+ Darcs.Patch.PatchInfoAnd: Hashed :: String -> (SimpleHopefully a wX wY) -> Hopefully a wX wY
+ Darcs.Patch.PatchInfoAnd: Hopefully :: (SimpleHopefully a wX wY) -> Hopefully a wX wY
+ Darcs.Patch.PatchInfoAnd: PIAP :: !PatchInfo -> (Hopefully (Named p) wA wB) -> PatchInfoAnd p wA wB
+ Darcs.Patch.PatchInfoAnd: Unavailable :: String -> SimpleHopefully a wX wY
+ Darcs.Patch.PatchInfoAnd: data SimpleHopefully a wX wY
+ Darcs.Patch.PatchInfoAnd: fmapFLPIAP :: (FL p wX wY -> FL q wX wY) -> PatchInfoAnd p wX wY -> PatchInfoAnd q wX wY
+ Darcs.Patch.PatchInfoAnd: instance (Commute p, NameHack p) => Commute (PatchInfoAnd p)
+ Darcs.Patch.PatchInfoAnd: instance (Merge p, NameHack p) => Merge (PatchInfoAnd p)
+ Darcs.Patch.PatchInfoAnd: instance (Patchy p, NameHack p, ApplyState p ~ Tree) => Patchy (PatchInfoAnd p)
+ Darcs.Patch.PatchInfoAnd: instance Invert p => Invert (PatchInfoAnd p)
+ Darcs.Patch.PatchInfoAnd: instance MyEq (PatchInfoAnd p)
+ Darcs.Patch.PatchInfoAnd: instance PatchDebug p => PatchDebug (PatchInfoAnd p)
+ Darcs.Patch.PatchInfoAnd: instance Show (a wX wY) => Show (Hopefully a wX wY)
+ Darcs.Patch.PatchInfoAnd: instance Show (a wX wY) => Show (SimpleHopefully a wX wY)
+ Darcs.Patch.PatchInfoAnd: instance Show2 p => Show (PatchInfoAnd p wA wB)
+ Darcs.Patch.PatchInfoAnd: instance Show2 p => Show1 (PatchInfoAnd p wX)
+ Darcs.Patch.PatchInfoAnd: instance Show2 p => Show2 (PatchInfoAnd p)
+ Darcs.Patch.Permutations: genCommuteWhatWeCanFL :: Commute q => (forall wA wB. (p :> q) wA wB -> Maybe ((q :> p) wA wB)) -> (p :> FL q) wX wY -> (FL q :> (p :> FL q)) wX wY
+ Darcs.Patch.Permutations: inverseCommuter :: (Invert p, Invert q) => CommuteFn p q -> CommuteFn q p
+ Darcs.Patch.Prim: coalesce :: PrimCanonize prim => (prim :> prim) wX wY -> Maybe (FL prim wX wY)
+ Darcs.Patch.Prim.Class: coalesce :: PrimCanonize prim => (prim :> prim) wX wY -> Maybe (FL prim wX wY)
+ Darcs.Patch.Prim.V1.Coalesce: instance Show (Simple wX wY)
+ Darcs.Patch.Prim.V1.Commute: instance Alternative Perhaps
+ Darcs.Patch.Prim.V1.Commute: instance Applicative Perhaps
+ Darcs.Patch.Prim.V1.Commute: instance Functor Perhaps
+ Darcs.Patch.Prim.V1.Core: instance Eq (DirPatchType wX wY)
+ Darcs.Patch.Prim.V1.Core: instance Eq (FilePatchType wX wY)
+ Darcs.Patch.Prim.V1.Core: instance Eq (Prim wX wY)
+ Darcs.Patch.Prim.V1.Core: instance Ord (DirPatchType wX wY)
+ Darcs.Patch.Prim.V1.Core: instance Ord (FilePatchType wX wY)
+ Darcs.Patch.Prim.V1.Core: instance PatchDebug Prim
+ Darcs.Patch.Prim.V1.Show: instance Show (DirPatchType wX wY)
+ Darcs.Patch.Prim.V1.Show: instance Show (FilePatchType wX wY)
+ Darcs.Patch.Prim.V1.Show: instance Show (Prim wX wY)
+ Darcs.Patch.Prim.V1.Show: instance Show1 (Prim wX)
+ Darcs.Patch.Prim.V3.Core: instance Eq (Prim wX wY)
+ Darcs.Patch.Prim.V3.Core: instance Show (Hunk wX wY)
+ Darcs.Patch.Prim.V3.Core: instance Show (Prim wX wY)
+ Darcs.Patch.Prim.V3.Core: instance Show1 (Hunk wX)
+ Darcs.Patch.Prim.V3.Core: instance Show1 (Prim wX)
+ Darcs.Patch.Prim.V3.Core: instance Show2 Hunk
+ Darcs.Patch.Prim.V3.Core: instance Show2 Prim
+ Darcs.Patch.Progress: progressFL :: String -> FL a wX wY -> FL a wX wY
+ Darcs.Patch.Progress: progressRL :: String -> RL a wX wY -> RL a wX wY
+ Darcs.Patch.Progress: progressRLShowTags :: String -> RL (PatchInfoAnd p) wX wY -> RL (PatchInfoAnd p) wX wY
+ Darcs.Patch.Rebase: AddName :: PatchInfo -> RebaseName p wX wY
+ Darcs.Patch.Rebase: DelName :: PatchInfo -> RebaseName p wX wY
+ Darcs.Patch.Rebase: Fixup :: RebaseFixup p wX wY -> RebaseItem p wX wY
+ Darcs.Patch.Rebase: NameFixup :: RebaseName p wX wY -> RebaseFixup p wX wY
+ Darcs.Patch.Rebase: Normal :: p wX wY -> Rebasing p wX wY
+ Darcs.Patch.Rebase: PrimFixup :: PrimOf p wX wY -> RebaseFixup p wX wY
+ Darcs.Patch.Rebase: Rename :: PatchInfo -> PatchInfo -> RebaseName p wX wY
+ Darcs.Patch.Rebase: Suspended :: FL (RebaseItem p) wX wY -> Rebasing p wX wX
+ Darcs.Patch.Rebase: ToEdit :: Named p wX wY -> RebaseItem p wX wY
+ Darcs.Patch.Rebase: countToEdit :: FL (RebaseItem p) wX wY -> Int
+ Darcs.Patch.Rebase: data RebaseFixup p wX wY
+ Darcs.Patch.Rebase: data RebaseItem p wX wY
+ Darcs.Patch.Rebase: data RebaseName (p :: * -> * -> *) wX wY
+ Darcs.Patch.Rebase: data Rebasing p wX wY
+ Darcs.Patch.Rebase: instance (Commute p, PrimPatchBase p, FromPrim p, Effect p) => RecontextRebase (Rebasing p)
+ Darcs.Patch.Rebase: instance (Conflict p, FromPrim p, Effect p, Invert p, Commute p) => Conflict (Rebasing p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, FromPrim p, Effect p, Commute p) => NameHack (Rebasing p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Commute p) => Commute (Rebasing p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Commute p, CommuteNoConflicts p) => CommuteNoConflicts (Rebasing p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Merge p) => Merge (Rebasing p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Rebasing p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (RebaseItem p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (Rebasing p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, PatchListFormat p, Patchy p, FromPrim p, Conflict p, Effect p, CommuteNoConflicts p, IsHunk p) => Patchy (Rebasing p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, PatchListFormat p, Patchy p, FromPrim p, Conflict p, Effect p, PatchInspect p, CommuteNoConflicts p, IsHunk p) => Matchable (Rebasing p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (RebaseItem p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (Rebasing p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p)
+ Darcs.Patch.Rebase: instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Rebasing p)
+ Darcs.Patch.Rebase: instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY)
+ Darcs.Patch.Rebase: instance (Show2 p, Show2 (PrimOf p)) => Show (Rebasing p wX wY)
+ Darcs.Patch.Rebase: instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX)
+ Darcs.Patch.Rebase: instance (Show2 p, Show2 (PrimOf p)) => Show1 (Rebasing p wX)
+ Darcs.Patch.Rebase: instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p)
+ Darcs.Patch.Rebase: instance (Show2 p, Show2 (PrimOf p)) => Show2 (Rebasing p)
+ Darcs.Patch.Rebase: instance Apply p => Apply (Rebasing p)
+ Darcs.Patch.Rebase: instance Check p => Check (RebaseItem p)
+ Darcs.Patch.Rebase: instance Check p => Check (Rebasing p)
+ Darcs.Patch.Rebase: instance Effect p => Effect (Rebasing p)
+ Darcs.Patch.Rebase: instance FromPrim p => FromPrim (Rebasing p)
+ Darcs.Patch.Rebase: instance Invert p => Invert (Rebasing p)
+ Darcs.Patch.Rebase: instance IsHunk p => IsHunk (Rebasing p)
+ Darcs.Patch.Rebase: instance MaybeInternal (Rebasing p)
+ Darcs.Patch.Rebase: instance PatchDebug p => PatchDebug (Rebasing p)
+ Darcs.Patch.Rebase: instance PatchListFormat p => PatchListFormat (Rebasing p)
+ Darcs.Patch.Rebase: instance PrimPatchBase p => PrimPatchBase (Rebasing p)
+ Darcs.Patch.Rebase: instance RepairInternalFL (RebaseFixup p)
+ Darcs.Patch.Rebase: instance RepairInternalFL (RebaseItem p)
+ Darcs.Patch.Rebase: instance RepairInternalFL p => RepairInternal (FL p)
+ Darcs.Patch.Rebase: instance RepairToFL p => RepairToFL (Rebasing p)
+ Darcs.Patch.Rebase: instance RepoPatch p => RepoPatch (Rebasing p)
+ Darcs.Patch.Rebase: mkSuspended :: FL (RebaseItem p) wX wY -> IO (Named (Rebasing p) wX wX)
+ Darcs.Patch.Rebase: simplifyPush :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) => DiffAlgorithm -> RebaseFixup p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)
+ Darcs.Patch.Rebase: simplifyPushes :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) => DiffAlgorithm -> FL (RebaseFixup p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)
+ Darcs.Patch.Rebase: takeAnyRebase :: PatchSet (Rebasing p) wA wB -> (Sealed2 (PatchInfoAnd (Rebasing p)), Sealed2 (FL (RebaseItem p)))
+ Darcs.Patch.Rebase: takeAnyRebaseAndTrailingPatches :: PatchSet (Rebasing p) wA wB -> FlippedSeal (PatchInfoAnd (Rebasing p) :> RL (PatchInfoAnd (Rebasing p))) wB
+ Darcs.Patch.Rebase: takeHeadRebase :: PatchSet (Rebasing p) wA wB -> (PatchInfoAnd (Rebasing p) wB wB, Sealed (FL (RebaseItem p) wB), PatchSet (Rebasing p) wA wB)
+ Darcs.Patch.Rebase: takeHeadRebaseFL :: FL (PatchInfoAnd (Rebasing p)) wA wB -> (PatchInfoAnd (Rebasing p) wB wB, Sealed (FL (RebaseItem p) wB), FL (PatchInfoAnd (Rebasing p)) wA wB)
+ Darcs.Patch.Rebase: takeHeadRebaseRL :: RL (PatchInfoAnd (Rebasing p)) wA wB -> (PatchInfoAnd (Rebasing p) wB wB, Sealed (FL (RebaseItem p) wB), RL (PatchInfoAnd (Rebasing p)) wA wB)
+ Darcs.Patch.Rebase.Fixup: NameFixup :: RebaseName p wX wY -> RebaseFixup p wX wY
+ Darcs.Patch.Rebase.Fixup: PrimFixup :: PrimOf p wX wY -> RebaseFixup p wX wY
+ Darcs.Patch.Rebase.Fixup: commuteFixupNamed :: (FromPrim p, Effect p, Commute p, Invert p) => (RebaseFixup p :> Named p) wX wY -> Maybe ((Named p :> FL (RebaseFixup p)) wX wY)
+ Darcs.Patch.Rebase.Fixup: commuteNamedFixup :: (FromPrim p, Effect p, Commute p, Invert p) => (Named p :> RebaseFixup p) wX wY -> Maybe ((FL (RebaseFixup p) :> Named p) wX wY)
+ Darcs.Patch.Rebase.Fixup: commuteNamedFixups :: (FromPrim p, Effect p, Commute p, Invert p) => (Named p :> FL (RebaseFixup p)) wX wY -> Maybe ((FL (RebaseFixup p) :> Named p) wX wY)
+ Darcs.Patch.Rebase.Fixup: data RebaseFixup p wX wY
+ Darcs.Patch.Rebase.Fixup: flToNamesPrims :: PrimPatchBase p => FL (RebaseFixup p) wX wY -> (FL (RebaseName p) :> FL (PrimOf p)) wX wY
+ Darcs.Patch.Rebase.Fixup: instance (PrimPatchBase p, Apply p, ApplyState p ~ ApplyState (PrimOf p)) => Apply (RebaseFixup p)
+ Darcs.Patch.Rebase.Fixup: instance Effect (RebaseFixup p)
+ Darcs.Patch.Rebase.Fixup: instance Invert (PrimOf p) => Invert (RebaseFixup p)
+ Darcs.Patch.Rebase.Fixup: instance MyEq (PrimOf p) => MyEq (RebaseFixup p)
+ Darcs.Patch.Rebase.Fixup: instance PatchInspect (PrimOf p) => PatchInspect (RebaseFixup p)
+ Darcs.Patch.Rebase.Fixup: instance PrimPatchBase p => Commute (RebaseFixup p)
+ Darcs.Patch.Rebase.Fixup: instance PrimPatchBase p => PrimPatchBase (RebaseFixup p)
+ Darcs.Patch.Rebase.Fixup: instance Show2 (PrimOf p) => Show (RebaseFixup p wX wY)
+ Darcs.Patch.Rebase.Fixup: instance Show2 (PrimOf p) => Show1 (RebaseFixup p wX)
+ Darcs.Patch.Rebase.Fixup: instance Show2 (PrimOf p) => Show2 (RebaseFixup p)
+ Darcs.Patch.Rebase.Name: AddName :: PatchInfo -> RebaseName p wX wY
+ Darcs.Patch.Rebase.Name: DelName :: PatchInfo -> RebaseName p wX wY
+ Darcs.Patch.Rebase.Name: Rename :: PatchInfo -> PatchInfo -> RebaseName p wX wY
+ Darcs.Patch.Rebase.Name: commuteNameNamed :: Invert p => CommuteFn (RebaseName p) (Named p)
+ Darcs.Patch.Rebase.Name: commuteNamePrim :: PrimPatchBase p => (RebaseName p :> PrimOf p) wX wY -> (PrimOf p :> RebaseName p) wX wY
+ Darcs.Patch.Rebase.Name: commuteNamedName :: Invert p => CommuteFn (Named p) (RebaseName p)
+ Darcs.Patch.Rebase.Name: commutePrimName :: PrimPatchBase p => (PrimOf p :> RebaseName p) wX wY -> (RebaseName p :> PrimOf p) wX wY
+ Darcs.Patch.Rebase.Name: data RebaseName (p :: * -> * -> *) wX wY
+ Darcs.Patch.Rebase.Name: instance Apply p => Apply (RebaseName p)
+ Darcs.Patch.Rebase.Name: instance Apply p => Patchy (RebaseName p)
+ Darcs.Patch.Rebase.Name: instance Commute (RebaseName p)
+ Darcs.Patch.Rebase.Name: instance Effect (RebaseName p)
+ Darcs.Patch.Rebase.Name: instance Invert (RebaseName p)
+ Darcs.Patch.Rebase.Name: instance MyEq (RebaseName p)
+ Darcs.Patch.Rebase.Name: instance PatchInspect (RebaseName p)
+ Darcs.Patch.Rebase.Name: instance PrimPatchBase p => PrimPatchBase (RebaseName p)
+ Darcs.Patch.Rebase.Name: instance ReadPatch (RebaseName p)
+ Darcs.Patch.Rebase.Name: instance Show (RebaseName p wX wY)
+ Darcs.Patch.Rebase.Name: instance Show1 (RebaseName p wX)
+ Darcs.Patch.Rebase.Name: instance Show2 (RebaseName p)
+ Darcs.Patch.Rebase.Name: instance ShowPatch (RebaseName p)
+ Darcs.Patch.Rebase.Name: instance ShowPatchBasic (RebaseName p)
+ Darcs.Patch.Rebase.NameHack: class NameHack p where nameHack = \ _ -> Nothing
+ Darcs.Patch.Rebase.NameHack: nameHack :: NameHack p => DiffAlgorithm -> Maybe (PatchInfo -> FL p wX wY -> FL p wX wY, PatchInfo -> FL p wW wZ -> FL p wW wZ)
+ Darcs.Patch.Rebase.Recontext: RecontextRebase1 :: (forall wY wZ. Named p wY wZ -> (EqCheck wY wZ, RecontextRebase2 p wY wZ)) -> RecontextRebase1 p
+ Darcs.Patch.Rebase.Recontext: RecontextRebase2 :: (forall wX. FL (RebaseFixup p) wX wY -> IO (Named p wX wX)) -> RecontextRebase2 p wY wZ
+ Darcs.Patch.Rebase.Recontext: class RecontextRebase p where recontextRebase = Nothing
+ Darcs.Patch.Rebase.Recontext: newtype RecontextRebase1 p
+ Darcs.Patch.Rebase.Recontext: newtype RecontextRebase2 p wY wZ
+ Darcs.Patch.Rebase.Recontext: recontextFunc1 :: RecontextRebase1 p -> forall wY wZ. Named p wY wZ -> (EqCheck wY wZ, RecontextRebase2 p wY wZ)
+ Darcs.Patch.Rebase.Recontext: recontextFunc2 :: RecontextRebase2 p wY wZ -> forall wX. FL (RebaseFixup p) wX wY -> IO (Named p wX wX)
+ Darcs.Patch.Rebase.Recontext: recontextRebase :: RecontextRebase p => Maybe (RecontextRebase1 p)
+ Darcs.Patch.Rebase.Viewing: RCFwd :: FL (RebaseFixup p) wX wY -> FL p wY wZ -> RebaseChange p wX wZ
+ Darcs.Patch.Rebase.Viewing: RCRev :: FL (RebaseFixup p) wX wY -> FL p wY wZ -> RebaseChange p wZ wX
+ Darcs.Patch.Rebase.Viewing: RSFwd :: FL (RebaseFixup p) wX wY -> Named p wY wZ -> RebaseSelect p wX wZ
+ Darcs.Patch.Rebase.Viewing: RSRev :: FL (RebaseFixup p) wX wY -> Named p wY wZ -> RebaseSelect p wZ wX
+ Darcs.Patch.Rebase.Viewing: WithDroppedDeps :: p wX wY -> [PatchInfo] -> WithDroppedDeps p wX wY
+ Darcs.Patch.Rebase.Viewing: commuterIdWDD :: CommuteFn p q -> CommuteFn p (WithDroppedDeps q)
+ Darcs.Patch.Rebase.Viewing: data RebaseChange p wX wY
+ Darcs.Patch.Rebase.Viewing: data RebaseSelect p wX wY
+ Darcs.Patch.Rebase.Viewing: data WithDroppedDeps p wX wY
+ Darcs.Patch.Rebase.Viewing: extractRebaseSelect :: (Commute p, Merge p, Invert p, Effect p, FromPrim p, PrimPatchBase p) => FL (RebaseSelect p) wX wY -> (FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY
+ Darcs.Patch.Rebase.Viewing: fromRebaseSelect :: FL (RebaseSelect p) wX wY -> FL (RebaseItem p) wX wY
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, Apply p, ApplyState p ~ ApplyState (PrimOf p), Invert p) => Patchy (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, Apply p, Invert p, PatchInspect p, ApplyState p ~ ApplyState (PrimOf p)) => Matchable (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, Commute p, MyEq p) => MyEq (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, FromPrim p, Conflict p, CommuteNoConflicts p, Invert p) => Conflict (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p, NameHack p) => Commute (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, Invert p, Apply p, ApplyState p ~ ApplyState (PrimOf p)) => Apply (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, Invert p, Apply p, ApplyState p ~ ApplyState (PrimOf p)) => Apply (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, Invert p, Effect p) => Effect (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, Invert p, Effect p) => Effect (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, Invert p, Effect p, FromPrim p, Merge p, Conflict p, CommuteNoConflicts p) => Conflict (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p) => ShowPatch (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, PatchListFormat p, Conflict p, FromPrim p, Effect p, CommuteNoConflicts p, IsHunk p, Patchy p, ApplyState p ~ ApplyState (PrimOf p), NameHack p) => Patchy (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p, Invert p, Effect p, Merge p, FromPrim p, Conflict p, CommuteNoConflicts p) => ShowPatch (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseChange p wX wY)
+ Darcs.Patch.Rebase.Viewing: instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseSelect p wX wY)
+ Darcs.Patch.Rebase.Viewing: instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseChange p wX)
+ Darcs.Patch.Rebase.Viewing: instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseSelect p wX)
+ Darcs.Patch.Rebase.Viewing: instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance Commute (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance CommuteNoConflicts (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance Effect p => Effect (WithDroppedDeps p)
+ Darcs.Patch.Rebase.Viewing: instance Invert (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance Invert p => Invert (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance IsHunk p => IsHunk (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance MaybeInternal (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance NameHack (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance PatchDebug p => PatchDebug (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance PatchDebug p => PatchDebug (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance PatchListFormat (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance PrimPatch (PrimOf p) => PrimPatchBase (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance PrimPatchBase p => PrimPatchBase (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: instance PrimPatchBase p => PrimPatchBase (WithDroppedDeps p)
+ Darcs.Patch.Rebase.Viewing: instance ReadPatch (RebaseChange p)
+ Darcs.Patch.Rebase.Viewing: instance ReadPatch p => ReadPatch (RebaseSelect p)
+ Darcs.Patch.Rebase.Viewing: partitionUnconflicted :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p, NameHack p) => FL (RebaseSelect p) wX wY -> (FL (RebaseSelect p) :> RL (RebaseSelect p)) wX wY
+ Darcs.Patch.Rebase.Viewing: reifyRebaseSelect :: (PrimPatchBase p, Commute p, Merge p, Invert p, Effect p, FromPrim p) => FL (RebaseSelect p) wX wY -> IO ((FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY)
+ Darcs.Patch.Rebase.Viewing: rsToNamed :: RebaseSelect p wX wY -> Sealed2 (Named p)
+ Darcs.Patch.Rebase.Viewing: toRebaseChanges :: PrimPatchBase p => FL (RebaseItem p) wX wY -> FL (PatchInfoAnd (RebaseChange p)) wX wY
+ Darcs.Patch.Rebase.Viewing: toRebaseSelect :: PrimPatchBase p => FL (RebaseItem p) wX wY -> FL (RebaseSelect p) wX wY
+ Darcs.Patch.Rebase.Viewing: type WDDNamed p = WithDroppedDeps (Named p)
+ Darcs.Patch.Rebase.Viewing: wddDependedOn :: WithDroppedDeps p wX wY -> [PatchInfo]
+ Darcs.Patch.Rebase.Viewing: wddPatch :: WithDroppedDeps p wX wY -> p wX wY
+ Darcs.Patch.Set: emptyPatchSet :: PatchSet p wX wX
+ Darcs.Patch.Set: instance Show2 p => Show (PatchSet p wStart wY)
+ Darcs.Patch.Set: instance Show2 p => Show (Tagged p wX wZ)
+ Darcs.Patch.Set: instance Show2 p => Show1 (PatchSet p wStart)
+ Darcs.Patch.Set: instance Show2 p => Show1 (Tagged p wX)
+ Darcs.Patch.Set: instance Show2 p => Show2 (PatchSet p)
+ Darcs.Patch.Set: instance Show2 p => Show2 (Tagged p)
+ Darcs.Patch.TokenReplace: breakOutToken :: String -> ByteString -> (ByteString, ByteString, ByteString)
+ Darcs.Patch.Type: PatchType :: PatchType
+ Darcs.Patch.Type: data PatchType (p :: * -> * -> *)
+ Darcs.Patch.Type: patchType :: p wX wY -> PatchType p
+ Darcs.Patch.V1: instance PrimPatch prim => Matchable (Patch prim)
+ Darcs.Patch.V1.Commute: instance Alternative Perhaps
+ Darcs.Patch.V1.Commute: instance Applicative Perhaps
+ Darcs.Patch.V1.Commute: instance Functor Perhaps
+ Darcs.Patch.V1.Commute: instance MyEq prim => Eq (Patch prim wX wY)
+ Darcs.Patch.V1.Core: instance MaybeInternal (Patch prim)
+ Darcs.Patch.V1.Core: instance NameHack (Patch prim)
+ Darcs.Patch.V1.Core: instance PatchDebug prim => PatchDebug (Patch prim)
+ Darcs.Patch.V1.Core: instance RecontextRebase (Patch prim)
+ Darcs.Patch.V1.Core: instance Show2 prim => Show (Patch prim wX wY)
+ Darcs.Patch.V1.Core: instance Show2 prim => Show1 (Patch prim wX)
+ Darcs.Patch.V1.Core: instance Show2 prim => Show2 (Patch prim)
+ Darcs.Patch.V2: instance PrimPatch prim => Matchable (RealPatch prim)
+ Darcs.Patch.V2.Non: instance (Commute p, MyEq p, MyEq (PrimOf p)) => Eq (Non p wX)
+ Darcs.Patch.V2.Non: instance (Show2 p, Show2 (PrimOf p)) => Show (Non p wX)
+ Darcs.Patch.V2.Real: instance MaybeInternal (RealPatch prim)
+ Darcs.Patch.V2.Real: instance NameHack (RealPatch prim)
+ Darcs.Patch.V2.Real: instance PatchDebug prim => PatchDebug (RealPatch prim)
+ Darcs.Patch.V2.Real: instance RecontextRebase (RealPatch prim)
+ Darcs.Patch.V2.Real: instance Show2 prim => Show (RealPatch prim wX wY)
+ Darcs.Patch.V2.Real: instance Show2 prim => Show1 (RealPatch prim wX)
+ Darcs.Patch.V2.Real: instance Show2 prim => Show2 (RealPatch prim)
+ Darcs.Patch.Witnesses.Eq: (=/\=) :: MyEq p => p wA wC -> p wB wC -> EqCheck wA wB
+ Darcs.Patch.Witnesses.Eq: (=\/=) :: MyEq p => p wA wB -> p wA wC -> EqCheck wB wC
+ Darcs.Patch.Witnesses.Eq: IsEq :: EqCheck wA wA
+ Darcs.Patch.Witnesses.Eq: NotEq :: EqCheck wA wB
+ Darcs.Patch.Witnesses.Eq: class MyEq p where unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b) a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq | otherwise = NotEq a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq | otherwise = NotEq
+ Darcs.Patch.Witnesses.Eq: data EqCheck wA wB
+ Darcs.Patch.Witnesses.Eq: instance Eq (EqCheck wA wB)
+ Darcs.Patch.Witnesses.Eq: instance Show (EqCheck wA wB)
+ Darcs.Patch.Witnesses.Eq: isIsEq :: EqCheck wA wB -> Bool
+ Darcs.Patch.Witnesses.Eq: unsafeCompare :: MyEq p => p wA wB -> p wC wD -> Bool
+ Darcs.Patch.Witnesses.Ordered: (+<+) :: RL a wY wZ -> RL a wX wY -> RL a wX wZ
+ Darcs.Patch.Witnesses.Ordered: (+>+) :: FL a wX wY -> FL a wY wZ -> FL a wX wZ
+ Darcs.Patch.Witnesses.Ordered: (:/\:) :: (a3 wX wZ) -> (a4 wY wZ) -> (:/\:) a3 a4 wX wY
+ Darcs.Patch.Witnesses.Ordered: (:<) :: (a1 wZ wY) -> (a2 wX wZ) -> (:<) a1 a2 wX wY
+ Darcs.Patch.Witnesses.Ordered: (:<:) :: a wY wZ -> RL a wX wY -> RL a wX wZ
+ Darcs.Patch.Witnesses.Ordered: (:>) :: (a1 wX wZ) -> (a2 wZ wY) -> (:>) a1 a2 wX wY
+ Darcs.Patch.Witnesses.Ordered: (:>:) :: a wX wY -> FL a wY wZ -> FL a wX wZ
+ Darcs.Patch.Witnesses.Ordered: (:\/:) :: (a1 wZ wX) -> (a2 wZ wY) -> (:\/:) a1 a2 wX wY
+ Darcs.Patch.Witnesses.Ordered: (:||:) :: (a1 wX wY) -> (a2 wX wY) -> (:||:) a1 a2 wX wY
+ Darcs.Patch.Witnesses.Ordered: Fork :: (common wA wU) -> (left wU wX) -> (right wU wY) -> Fork common left right wA wX wY
+ Darcs.Patch.Witnesses.Ordered: NilFL :: FL a wX wX
+ Darcs.Patch.Witnesses.Ordered: NilRL :: RL a wX wX
+ Darcs.Patch.Witnesses.Ordered: allFL :: (forall wX wY. a wX wY -> Bool) -> FL a wW wZ -> Bool
+ Darcs.Patch.Witnesses.Ordered: anyFL :: (forall wX wY. a wX wY -> Bool) -> FL a wW wZ -> Bool
+ Darcs.Patch.Witnesses.Ordered: bunchFL :: Int -> FL a wX wY -> FL (FL a) wX wY
+ Darcs.Patch.Witnesses.Ordered: concatFL :: FL (FL a) wX wZ -> FL a wX wZ
+ Darcs.Patch.Witnesses.Ordered: concatRL :: RL (RL a) wX wZ -> RL a wX wZ
+ Darcs.Patch.Witnesses.Ordered: consRLSealed :: a wY wZ -> FlippedSeal (RL a) wY -> FlippedSeal (RL a) wZ
+ Darcs.Patch.Witnesses.Ordered: data (:||:) a1 a2 wX wY
+ Darcs.Patch.Witnesses.Ordered: data FL a wX wZ
+ Darcs.Patch.Witnesses.Ordered: data Fork common left right wA wX wY
+ Darcs.Patch.Witnesses.Ordered: data RL a wX wZ
+ Darcs.Patch.Witnesses.Ordered: dropWhileFL :: (forall wX wY. a wX wY -> Bool) -> FL a wR wV -> FlippedSeal (FL a) wV
+ Darcs.Patch.Witnesses.Ordered: dropWhileRL :: (forall wX wY. a wX wY -> Bool) -> RL a wR wV -> Sealed (RL a wR)
+ Darcs.Patch.Witnesses.Ordered: eqFL :: MyEq a => FL a wX wY -> FL a wX wZ -> EqCheck wY wZ
+ Darcs.Patch.Witnesses.Ordered: eqFLRev :: MyEq a => FL a wX wZ -> FL a wY wZ -> EqCheck wX wY
+ Darcs.Patch.Witnesses.Ordered: eqFLUnsafe :: MyEq a => FL a wX wY -> FL a wZ wW -> Bool
+ Darcs.Patch.Witnesses.Ordered: filterFL :: (forall wX wY. a wX wY -> Bool) -> FL a wW wZ -> [Sealed2 a]
+ Darcs.Patch.Witnesses.Ordered: filterOutFLFL :: (forall wX wY. p wX wY -> EqCheck wX wY) -> FL p wW wZ -> FL p wW wZ
+ Darcs.Patch.Witnesses.Ordered: filterOutRLRL :: (forall wX wY. p wX wY -> EqCheck wX wY) -> RL p wW wZ -> RL p wW wZ
+ Darcs.Patch.Witnesses.Ordered: filterRL :: (forall wX wY. p wX wY -> Bool) -> RL p wA wB -> [Sealed2 p]
+ Darcs.Patch.Witnesses.Ordered: foldlFL :: (forall wW wY. a -> b wW wY -> a) -> a -> FL b wX wZ -> a
+ Darcs.Patch.Witnesses.Ordered: foldlRL :: (forall wW wY. a -> b wW wY -> a) -> a -> RL b wX wZ -> a
+ Darcs.Patch.Witnesses.Ordered: instance (MyEq a, MyEq b) => Eq ((:<) a b wX wY)
+ Darcs.Patch.Witnesses.Ordered: instance (MyEq a, MyEq b) => Eq ((:>) a b wX wY)
+ Darcs.Patch.Witnesses.Ordered: instance (MyEq a, MyEq b) => MyEq (a :< b)
+ Darcs.Patch.Witnesses.Ordered: instance (MyEq a, MyEq b) => MyEq (a :> b)
+ Darcs.Patch.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show ((:/\:) a b wX wY)
+ Darcs.Patch.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show ((:>) a b wX wY)
+ Darcs.Patch.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show ((:\/:) a b wX wY)
+ Darcs.Patch.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show1 ((:>) a b wX)
+ Darcs.Patch.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show2 (a :/\: b)
+ Darcs.Patch.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show2 (a :> b)
+ Darcs.Patch.Witnesses.Ordered: instance (Show2 a, Show2 b) => Show2 (a :\/: b)
+ Darcs.Patch.Witnesses.Ordered: instance Show2 a => Show (FL a wX wZ)
+ Darcs.Patch.Witnesses.Ordered: instance Show2 a => Show (RL a wX wZ)
+ Darcs.Patch.Witnesses.Ordered: instance Show2 a => Show1 (FL a wX)
+ Darcs.Patch.Witnesses.Ordered: instance Show2 a => Show1 (RL a wX)
+ Darcs.Patch.Witnesses.Ordered: instance Show2 a => Show2 (FL a)
+ Darcs.Patch.Witnesses.Ordered: instance Show2 a => Show2 (RL a)
+ Darcs.Patch.Witnesses.Ordered: isShorterThanRL :: RL a wX wY -> Int -> Bool
+ Darcs.Patch.Witnesses.Ordered: lengthFL :: FL a wX wZ -> Int
+ Darcs.Patch.Witnesses.Ordered: lengthRL :: RL a wX wZ -> Int
+ Darcs.Patch.Witnesses.Ordered: mapFL :: (forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
+ Darcs.Patch.Witnesses.Ordered: mapFL_FL :: (forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
+ Darcs.Patch.Witnesses.Ordered: mapFL_FL_M :: Monad m => (forall wW wY. a wW wY -> m (b wW wY)) -> FL a wX wZ -> m (FL b wX wZ)
+ Darcs.Patch.Witnesses.Ordered: mapRL :: (forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
+ Darcs.Patch.Witnesses.Ordered: mapRL_RL :: (forall wW wY. a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ
+ Darcs.Patch.Witnesses.Ordered: nullFL :: FL a wX wZ -> Bool
+ Darcs.Patch.Witnesses.Ordered: nullRL :: RL a wX wZ -> Bool
+ Darcs.Patch.Witnesses.Ordered: reverseFL :: FL a wX wZ -> RL a wX wZ
+ Darcs.Patch.Witnesses.Ordered: reverseRL :: RL a wX wZ -> FL a wX wZ
+ Darcs.Patch.Witnesses.Ordered: spanFL :: (forall wW wY. a wW wY -> Bool) -> FL a wX wZ -> (FL a :> FL a) wX wZ
+ Darcs.Patch.Witnesses.Ordered: spanFL_M :: Monad m => (forall wW wY. a wW wY -> m Bool) -> FL a wX wZ -> m ((FL a :> FL a) wX wZ)
+ Darcs.Patch.Witnesses.Ordered: splitAtFL :: Int -> FL a wX wZ -> (FL a :> FL a) wX wZ
+ Darcs.Patch.Witnesses.Ordered: splitAtRL :: Int -> RL a wX wZ -> (RL a :< RL a) wX wZ
+ Darcs.Patch.Witnesses.Ordered: toFL :: [FreeLeft a] -> Sealed (FL a wX)
+ Darcs.Patch.Witnesses.Ordered: zipWithFL :: (forall wX wY. a -> p wX wY -> q wX wY) -> [a] -> FL p wW wZ -> FL q wW wZ
+ Darcs.Patch.Witnesses.Sealed: FLInternal :: (Poly (Stepped Sealed p)) -> FreeLeft p
+ Darcs.Patch.Witnesses.Sealed: FRInternal :: (Poly (FlippedSeal p)) -> FreeRight p
+ Darcs.Patch.Witnesses.Sealed: FlippedSeal :: !(a wX wY) -> FlippedSeal a wY
+ Darcs.Patch.Witnesses.Sealed: Poly :: (forall wX. a wX) -> Poly a
+ Darcs.Patch.Witnesses.Sealed: Sealed :: a wX -> Sealed a
+ Darcs.Patch.Witnesses.Sealed: Sealed2 :: !(a wX wY) -> Sealed2 a
+ Darcs.Patch.Witnesses.Sealed: Stepped :: f (a wX) -> Stepped a wX
+ Darcs.Patch.Witnesses.Sealed: class Gap w
+ Darcs.Patch.Witnesses.Sealed: data FlippedSeal a wY
+ Darcs.Patch.Witnesses.Sealed: data Sealed a
+ Darcs.Patch.Witnesses.Sealed: data Sealed2 a
+ Darcs.Patch.Witnesses.Sealed: emptyGap :: Gap w => (forall wX. p wX wX) -> w p
+ Darcs.Patch.Witnesses.Sealed: flipSeal :: a wX wY -> FlippedSeal a wY
+ Darcs.Patch.Witnesses.Sealed: freeGap :: Gap w => (forall wX wY. p wX wY) -> w p
+ Darcs.Patch.Witnesses.Sealed: instance Gap FreeLeft
+ Darcs.Patch.Witnesses.Sealed: instance Gap FreeRight
+ Darcs.Patch.Witnesses.Sealed: instance MyEq a => Eq (Sealed (a wX))
+ Darcs.Patch.Witnesses.Sealed: instance Show1 a => Show (Sealed a)
+ Darcs.Patch.Witnesses.Sealed: instance Show2 a => Show (Sealed2 a)
+ Darcs.Patch.Witnesses.Sealed: joinGap :: Gap w => (forall wX wY wZ. p wX wY -> q wY wZ -> r wX wZ) -> w p -> w q -> w r
+ Darcs.Patch.Witnesses.Sealed: liftSM :: Monad m => (forall wX. a wX -> b) -> m (Sealed a) -> m b
+ Darcs.Patch.Witnesses.Sealed: mapFlipped :: (forall wX. a wX wY -> b wX wZ) -> FlippedSeal a wY -> FlippedSeal b wZ
+ Darcs.Patch.Witnesses.Sealed: mapSeal :: (forall wX. a wX -> b wX) -> Sealed a -> Sealed b
+ Darcs.Patch.Witnesses.Sealed: mapSeal2 :: (forall wX wY. a wX wY -> b wX wY) -> Sealed2 a -> Sealed2 b
+ Darcs.Patch.Witnesses.Sealed: newtype FreeLeft p
+ Darcs.Patch.Witnesses.Sealed: newtype FreeRight p
+ Darcs.Patch.Witnesses.Sealed: newtype Poly a
+ Darcs.Patch.Witnesses.Sealed: newtype Stepped (f :: (* -> *) -> *) a wX
+ Darcs.Patch.Witnesses.Sealed: seal :: a wX -> Sealed a
+ Darcs.Patch.Witnesses.Sealed: seal2 :: a wX wY -> Sealed2 a
+ Darcs.Patch.Witnesses.Sealed: unFreeLeft :: FreeLeft p -> Sealed (p wX)
+ Darcs.Patch.Witnesses.Sealed: unFreeRight :: FreeRight p -> FlippedSeal p wX
+ Darcs.Patch.Witnesses.Sealed: unPoly :: Poly a -> forall wX. a wX
+ Darcs.Patch.Witnesses.Sealed: unStepped :: Stepped a wX -> f (a wX)
+ Darcs.Patch.Witnesses.Sealed: unsafeUnseal :: Sealed a -> a wX
+ Darcs.Patch.Witnesses.Sealed: unsafeUnseal2 :: Sealed2 a -> a wX wY
+ Darcs.Patch.Witnesses.Sealed: unsafeUnsealFlipped :: FlippedSeal a wY -> a wX wY
+ Darcs.Patch.Witnesses.Sealed: unseal :: (forall wX. a wX -> b) -> Sealed a -> b
+ Darcs.Patch.Witnesses.Sealed: unseal2 :: (forall wX wY. a wX wY -> b) -> Sealed2 a -> b
+ Darcs.Patch.Witnesses.Sealed: unsealFlipped :: (forall wX wY. a wX wY -> b) -> FlippedSeal a wZ -> b
+ Darcs.Patch.Witnesses.Sealed: unsealM :: Monad m => m (Sealed a) -> (forall wX. a wX -> m b) -> m b
+ Darcs.Patch.Witnesses.Show: ShowDictClass :: ShowDict a
+ Darcs.Patch.Witnesses.Show: ShowDictRecord :: (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> ShowDict a
+ Darcs.Patch.Witnesses.Show: appPrec :: Int
+ Darcs.Patch.Witnesses.Show: class Show1 a
+ Darcs.Patch.Witnesses.Show: class Show2 a
+ Darcs.Patch.Witnesses.Show: data ShowDict a
+ Darcs.Patch.Witnesses.Show: show1 :: Show1 a => a wX -> String
+ Darcs.Patch.Witnesses.Show: show2 :: Show2 a => a wX wY -> String
+ Darcs.Patch.Witnesses.Show: showD :: ShowDict a -> a -> String
+ Darcs.Patch.Witnesses.Show: showDict1 :: Show1 a => ShowDict (a wX)
+ Darcs.Patch.Witnesses.Show: showDict2 :: Show2 a => ShowDict (a wX wY)
+ Darcs.Patch.Witnesses.Show: showListD :: ShowDict a -> [a] -> ShowS
+ Darcs.Patch.Witnesses.Show: showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a wW wX -> b wY wZ -> String -> String
+ Darcs.Patch.Witnesses.Show: showsPrec1 :: Show1 a => Int -> a wX -> ShowS
+ Darcs.Patch.Witnesses.Show: showsPrec2 :: Show2 a => Int -> a wX wY -> ShowS
+ Darcs.Patch.Witnesses.Show: showsPrecD :: ShowDict a -> Int -> a -> ShowS
+ Darcs.Patch.Witnesses.Unsafe: unsafeCoerceP :: a wX wY -> a wB wC
+ Darcs.Patch.Witnesses.Unsafe: unsafeCoerceP1 :: a wX -> a wY
+ Darcs.Patch.Witnesses.Unsafe: unsafeCoerceP2 :: t wW wX wY wZ -> t wA wB wC wD
+ Darcs.Patch.Witnesses.Unsafe: unsafeCoercePEnd :: a wX wY1 -> a wX wY2
+ Darcs.Patch.Witnesses.Unsafe: unsafeCoercePStart :: a wX1 wY -> a wX2 wY
+ Darcs.Patch.Witnesses.WZipper: FZipper :: RL a wX wY -> FL a wY wZ -> FZipper a wX wZ
+ Darcs.Patch.Witnesses.WZipper: clowns :: FZipper a wX wY -> Sealed ((RL a) wX)
+ Darcs.Patch.Witnesses.WZipper: data FZipper a wX wZ
+ Darcs.Patch.Witnesses.WZipper: flToZipper :: FL a wX wY -> FZipper a wX wY
+ Darcs.Patch.Witnesses.WZipper: focus :: FZipper a wX wY -> Maybe (Sealed2 a)
+ Darcs.Patch.Witnesses.WZipper: jokers :: FZipper a wX wY -> FlippedSeal (FL a) wY
+ Darcs.Patch.Witnesses.WZipper: left :: FZipper p wX wY -> FZipper p wX wY
+ Darcs.Patch.Witnesses.WZipper: leftmost :: FZipper p wX wY -> Bool
+ Darcs.Patch.Witnesses.WZipper: lengthFZ :: FZipper a wX wY -> Int
+ Darcs.Patch.Witnesses.WZipper: nullFZ :: FZipper a wX wY -> Bool
+ Darcs.Patch.Witnesses.WZipper: right :: FZipper p wX wY -> FZipper p wX wY
+ Darcs.Patch.Witnesses.WZipper: rightmost :: FZipper p wX wY -> Bool
+ Darcs.Patch.Witnesses.WZipper: toEnd :: FZipper p wX wY -> FZipper p wX wY
+ Darcs.Patch.Witnesses.WZipper: toStart :: FZipper p wX wY -> FZipper p wX wY
+ Darcs.Repository: RebaseAwareJob :: Compression -> Verbosity -> UpdateWorking -> (forall p wR wU. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository p wR wU wR -> IO a) -> RepoJob a
+ Darcs.Repository: RebaseJob :: Compression -> Verbosity -> UpdateWorking -> (forall p wR wU. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a) -> RepoJob a
+ Darcs.Repository: StartRebaseJob :: Compression -> Verbosity -> UpdateWorking -> (forall p wR wU. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a) -> RepoJob a
+ Darcs.Repository: addPendingDiffToPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> UpdateWorking -> FreeLeft (FL (PrimOf p)) -> IO ()
+ Darcs.Repository: cloneRepository :: String -> String -> Verbosity -> UseCache -> CloneKind -> UMask -> RemoteDarcs -> SetScriptsExecutable -> RemoteRepos -> SetDefault -> [MatchFlag] -> RepoFormat -> WithWorkingDir -> WithPatchIndex -> Bool -> Bool -> ForgetParent -> IO ()
+ Darcs.Repository: filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree) => RL (PatchInfoAnd p) wX wT -> Repository p wR wU wT -> FL (PatchInfoAnd p) wX wZ -> IO (Bool, Sealed (FL (PatchInfoAnd p) wX))
+ Darcs.Repository: listFiles :: Bool -> IO [String]
+ Darcs.Repository: listRegisteredFiles :: IO [String]
+ Darcs.Repository: listUnregisteredFiles :: Bool -> IO [String]
+ Darcs.Repository: reorderInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wR -> Compression -> UpdateWorking -> Verbosity -> IO ()
+ Darcs.Repository: repoPatchType :: Repository p wR wU wT -> PatchType p
+ Darcs.Repository: unrecordedChangesWithPatches :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT -> Maybe [SubPath] -> FL (PrimOf p) wX wT -> FL (PrimOf p) wT wT -> IO (FL (PrimOf p) wT wU)
+ Darcs.Repository: withManualRebaseUpdate :: (RepoPatch p, ApplyState p ~ Tree) => Compression -> Verbosity -> UpdateWorking -> Repository p wR wU wT1 -> (Repository p wR wU wT1 -> IO (Repository p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x)) -> IO (Repository p wR wU wT2, x)
+ Darcs.Repository: withRepoLockCanFail :: UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
+ Darcs.Repository.ApplyPatches: data DefaultIO a
+ Darcs.Repository.ApplyPatches: instance Applicative DefaultIO
+ Darcs.Repository.ApplyPatches: instance Applicative SilentIO
+ Darcs.Repository.ApplyPatches: instance Applicative TolerantIO
+ Darcs.Repository.ApplyPatches: instance Applicative m => Applicative (TolerantWrapper m)
+ Darcs.Repository.ApplyPatches: instance ApplyMonad DefaultIO Tree
+ Darcs.Repository.ApplyPatches: instance Functor DefaultIO
+ Darcs.Repository.ApplyPatches: instance Functor SilentIO
+ Darcs.Repository.ApplyPatches: instance Functor TolerantIO
+ Darcs.Repository.ApplyPatches: instance Functor m => Functor (TolerantWrapper m)
+ Darcs.Repository.ApplyPatches: instance Monad DefaultIO
+ Darcs.Repository.ApplyPatches: instance Monad SilentIO
+ Darcs.Repository.ApplyPatches: instance Monad TolerantIO
+ Darcs.Repository.ApplyPatches: instance Monad m => Monad (TolerantWrapper m)
+ Darcs.Repository.ApplyPatches: instance MonadProgress DefaultIO
+ Darcs.Repository.ApplyPatches: instance TolerantMonad SilentIO
+ Darcs.Repository.ApplyPatches: instance TolerantMonad TolerantIO
+ Darcs.Repository.ApplyPatches: instance TolerantMonad m => ApplyMonad (TolerantWrapper m) Tree
+ Darcs.Repository.ApplyPatches: instance TolerantMonad m => TolerantMonad (TolerantWrapper m)
+ Darcs.Repository.ApplyPatches: runDefault :: DefaultIO a -> IO a
+ Darcs.Repository.ApplyPatches: runSilently :: TolerantWrapper SilentIO a -> IO a
+ Darcs.Repository.ApplyPatches: runTolerantly :: TolerantWrapper TolerantIO a -> IO a
+ Darcs.Repository.Cache: bucketFolder :: String -> String
+ Darcs.Repository.Cache: instance Eq WritableOrNot
+ Darcs.Repository.Cache: isThisRepo :: CacheLoc -> Bool
+ Darcs.Repository.Compat: atomicCreate :: FilePath -> IO ()
+ Darcs.Repository.Compat: canonFilename :: FilePath -> IO FilePath
+ Darcs.Repository.Compat: maybeRelink :: String -> String -> IO Bool
+ Darcs.Repository.Compat: mkStdoutTemp :: String -> IO String
+ Darcs.Repository.Compat: sloppyAtomicCreate :: FilePath -> IO ()
+ Darcs.Repository.Compat: stdoutIsAPipe :: IO Bool
+ Darcs.Repository.Diff: treeDiff :: (Functor m, Monad m, Gap w, PrimPatch prim) => DiffAlgorithm -> (FilePath -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
+ Darcs.Repository.External: Cachable :: Cachable
+ Darcs.Repository.External: MaxAge :: !CInt -> Cachable
+ Darcs.Repository.External: Uncachable :: Cachable
+ Darcs.Repository.External: backupByCopying :: FilePath -> IO ()
+ Darcs.Repository.External: backupByRenaming :: FilePath -> IO ()
+ Darcs.Repository.External: cloneFile :: FilePath -> FilePath -> IO ()
+ Darcs.Repository.External: cloneTree :: FilePath -> FilePath -> IO ()
+ Darcs.Repository.External: copyFileOrUrl :: RemoteDarcs -> FilePath -> FilePath -> Cachable -> IO ()
+ Darcs.Repository.External: data Cachable
+ Darcs.Repository.External: environmentHelpProtocols :: ([String], [String])
+ Darcs.Repository.External: fetchFileLazyPS :: String -> Cachable -> IO ByteString
+ Darcs.Repository.External: fetchFilePS :: String -> Cachable -> IO ByteString
+ Darcs.Repository.External: gzFetchFilePS :: String -> Cachable -> IO ByteString
+ Darcs.Repository.External: speculateFileOrUrl :: String -> FilePath -> IO ()
+ Darcs.Repository.Flags: CompleteClone :: CloneKind
+ Darcs.Repository.Flags: DefaultRemoteDarcs :: RemoteDarcs
+ Darcs.Repository.Flags: GzipCompression :: Compression
+ Darcs.Repository.Flags: IgnoreIndex :: UseIndex
+ Darcs.Repository.Flags: LazyClone :: CloneKind
+ Darcs.Repository.Flags: MyersDiff :: DiffAlgorithm
+ Darcs.Repository.Flags: NoAllowConflicts :: AllowConflicts
+ Darcs.Repository.Flags: NoCompression :: Compression
+ Darcs.Repository.Flags: NoDryRun :: DryRun
+ Darcs.Repository.Flags: NoExternalMerge :: ExternalMerge
+ Darcs.Repository.Flags: NoForgetParent :: ForgetParent
+ Darcs.Repository.Flags: NoLeaveTestDir :: LeaveTestDir
+ Darcs.Repository.Flags: NoLookForAdds :: LookForAdds
+ Darcs.Repository.Flags: NoLookForMoves :: LookForMoves
+ Darcs.Repository.Flags: NoLookForReplaces :: LookForReplaces
+ Darcs.Repository.Flags: NoPatchIndex :: WithPatchIndex
+ Darcs.Repository.Flags: NoReorder :: Reorder
+ Darcs.Repository.Flags: NoRunTest :: RunTest
+ Darcs.Repository.Flags: NoSetDefault :: Bool -> SetDefault
+ Darcs.Repository.Flags: NoSetScriptsExecutable :: SetScriptsExecutable
+ Darcs.Repository.Flags: NoUMask :: UMask
+ Darcs.Repository.Flags: NoUpdateWorking :: UpdateWorking
+ Darcs.Repository.Flags: NoUseCache :: UseCache
+ Darcs.Repository.Flags: NoWantGuiPause :: WantGuiPause
+ Darcs.Repository.Flags: NoWorkingDir :: WithWorkingDir
+ Darcs.Repository.Flags: NormalClone :: CloneKind
+ Darcs.Repository.Flags: NormalVerbosity :: Verbosity
+ Darcs.Repository.Flags: PatienceDiff :: DiffAlgorithm
+ Darcs.Repository.Flags: Quiet :: Verbosity
+ Darcs.Repository.Flags: RemoteDarcs :: String -> RemoteDarcs
+ Darcs.Repository.Flags: RemoteRepos :: [String] -> RemoteRepos
+ Darcs.Repository.Flags: Reorder :: Reorder
+ Darcs.Repository.Flags: ScanAll :: ScanKnown
+ Darcs.Repository.Flags: ScanBoring :: ScanKnown
+ Darcs.Repository.Flags: ScanKnown :: ScanKnown
+ Darcs.Repository.Flags: UseIndex :: UseIndex
+ Darcs.Repository.Flags: Verbose :: Verbosity
+ Darcs.Repository.Flags: WithWorkingDir :: WithWorkingDir
+ Darcs.Repository.Flags: WorkRepoCurrentDir :: WorkRepo
+ Darcs.Repository.Flags: WorkRepoDir :: String -> WorkRepo
+ Darcs.Repository.Flags: WorkRepoPossibleURL :: String -> WorkRepo
+ Darcs.Repository.Flags: YesAllowConflicts :: AllowConflicts
+ Darcs.Repository.Flags: YesAllowConflictsAndMark :: AllowConflicts
+ Darcs.Repository.Flags: YesDryRun :: DryRun
+ Darcs.Repository.Flags: YesExternalMerge :: String -> ExternalMerge
+ Darcs.Repository.Flags: YesForgetParent :: ForgetParent
+ Darcs.Repository.Flags: YesLeaveTestDir :: LeaveTestDir
+ Darcs.Repository.Flags: YesLookForAdds :: LookForAdds
+ Darcs.Repository.Flags: YesLookForMoves :: LookForMoves
+ Darcs.Repository.Flags: YesLookForReplaces :: LookForReplaces
+ Darcs.Repository.Flags: YesPatchIndex :: WithPatchIndex
+ Darcs.Repository.Flags: YesRunTest :: RunTest
+ Darcs.Repository.Flags: YesSetDefault :: Bool -> SetDefault
+ Darcs.Repository.Flags: YesSetScriptsExecutable :: SetScriptsExecutable
+ Darcs.Repository.Flags: YesUMask :: String -> UMask
+ Darcs.Repository.Flags: YesUpdateWorking :: UpdateWorking
+ Darcs.Repository.Flags: YesUseCache :: UseCache
+ Darcs.Repository.Flags: YesWantGuiPause :: WantGuiPause
+ Darcs.Repository.Flags: data AllowConflicts
+ Darcs.Repository.Flags: data CloneKind
+ Darcs.Repository.Flags: data Compression
+ Darcs.Repository.Flags: data DiffAlgorithm
+ Darcs.Repository.Flags: data DryRun
+ Darcs.Repository.Flags: data ExternalMerge
+ Darcs.Repository.Flags: data ForgetParent
+ Darcs.Repository.Flags: data LeaveTestDir
+ Darcs.Repository.Flags: data LookForAdds
+ Darcs.Repository.Flags: data LookForMoves
+ Darcs.Repository.Flags: data LookForReplaces
+ Darcs.Repository.Flags: data RemoteDarcs
+ Darcs.Repository.Flags: data RemoteRepos
+ Darcs.Repository.Flags: data Reorder
+ Darcs.Repository.Flags: data RunTest
+ Darcs.Repository.Flags: data ScanKnown
+ Darcs.Repository.Flags: data SetDefault
+ Darcs.Repository.Flags: data SetScriptsExecutable
+ Darcs.Repository.Flags: data UMask
+ Darcs.Repository.Flags: data UpdateWorking
+ Darcs.Repository.Flags: data UseCache
+ Darcs.Repository.Flags: data UseIndex
+ Darcs.Repository.Flags: data Verbosity
+ Darcs.Repository.Flags: data WantGuiPause
+ Darcs.Repository.Flags: data WithPatchIndex
+ Darcs.Repository.Flags: data WithWorkingDir
+ Darcs.Repository.Flags: data WorkRepo
+ Darcs.Repository.Flags: instance Eq AllowConflicts
+ Darcs.Repository.Flags: instance Eq CloneKind
+ Darcs.Repository.Flags: instance Eq Compression
+ Darcs.Repository.Flags: instance Eq DryRun
+ Darcs.Repository.Flags: instance Eq ExternalMerge
+ Darcs.Repository.Flags: instance Eq ForgetParent
+ Darcs.Repository.Flags: instance Eq LeaveTestDir
+ Darcs.Repository.Flags: instance Eq LookForAdds
+ Darcs.Repository.Flags: instance Eq LookForMoves
+ Darcs.Repository.Flags: instance Eq LookForReplaces
+ Darcs.Repository.Flags: instance Eq RemoteDarcs
+ Darcs.Repository.Flags: instance Eq RemoteRepos
+ Darcs.Repository.Flags: instance Eq Reorder
+ Darcs.Repository.Flags: instance Eq RunTest
+ Darcs.Repository.Flags: instance Eq SetDefault
+ Darcs.Repository.Flags: instance Eq SetScriptsExecutable
+ Darcs.Repository.Flags: instance Eq UMask
+ Darcs.Repository.Flags: instance Eq UpdateWorking
+ Darcs.Repository.Flags: instance Eq UseCache
+ Darcs.Repository.Flags: instance Eq UseIndex
+ Darcs.Repository.Flags: instance Eq Verbosity
+ Darcs.Repository.Flags: instance Eq WantGuiPause
+ Darcs.Repository.Flags: instance Eq WithPatchIndex
+ Darcs.Repository.Flags: instance Eq WithWorkingDir
+ Darcs.Repository.Flags: instance Eq WorkRepo
+ Darcs.Repository.Flags: instance Show AllowConflicts
+ Darcs.Repository.Flags: instance Show CloneKind
+ Darcs.Repository.Flags: instance Show Compression
+ Darcs.Repository.Flags: instance Show DryRun
+ Darcs.Repository.Flags: instance Show ExternalMerge
+ Darcs.Repository.Flags: instance Show ForgetParent
+ Darcs.Repository.Flags: instance Show LeaveTestDir
+ Darcs.Repository.Flags: instance Show LookForAdds
+ Darcs.Repository.Flags: instance Show LookForMoves
+ Darcs.Repository.Flags: instance Show LookForReplaces
+ Darcs.Repository.Flags: instance Show RemoteDarcs
+ Darcs.Repository.Flags: instance Show RemoteRepos
+ Darcs.Repository.Flags: instance Show RunTest
+ Darcs.Repository.Flags: instance Show SetDefault
+ Darcs.Repository.Flags: instance Show SetScriptsExecutable
+ Darcs.Repository.Flags: instance Show UMask
+ Darcs.Repository.Flags: instance Show UpdateWorking
+ Darcs.Repository.Flags: instance Show UseCache
+ Darcs.Repository.Flags: instance Show UseIndex
+ Darcs.Repository.Flags: instance Show Verbosity
+ Darcs.Repository.Flags: instance Show WantGuiPause
+ Darcs.Repository.Flags: instance Show WithPatchIndex
+ Darcs.Repository.Flags: instance Show WithWorkingDir
+ Darcs.Repository.Flags: instance Show WorkRepo
+ Darcs.Repository.Format: Darcs1 :: RepoProperty
+ Darcs.Repository.Format: RebaseInProgress :: RepoProperty
+ Darcs.Repository.Format: UnknownFormat :: String -> RepoProperty
+ Darcs.Repository.Format: addToFormat :: RepoProperty -> RepoFormat -> RepoFormat
+ Darcs.Repository.Format: instance Eq RepoProperty
+ Darcs.Repository.Format: removeFromFormat :: RepoProperty -> RepoFormat -> RepoFormat
+ Darcs.Repository.Format: transferProblem :: RepoFormat -> RepoFormat -> Maybe String
+ Darcs.Repository.HashedIO: getHashedFiles :: String -> [String] -> IO [String]
+ Darcs.Repository.HashedIO: pathsAndContents :: FilePath -> Cache -> String -> IO [(FilePath, ByteString)]
+ Darcs.Repository.HashedRepo: cleanInventories :: Repository p wR wU wT -> IO ()
+ Darcs.Repository.HashedRepo: cleanPatches :: Repository p wR wU wT -> IO ()
+ Darcs.Repository.HashedRepo: copyHashedInventory :: RepoPatch p => Repository p wR wU wT -> RemoteDarcs -> String -> IO ()
+ Darcs.Repository.HashedRepo: filterDirContents :: FilePath -> (FilePath -> Bool) -> IO [FilePath]
+ Darcs.Repository.HashedRepo: hashedInventory :: String
+ Darcs.Repository.HashedRepo: inv2pris :: ByteString -> String
+ Darcs.Repository.HashedRepo: inventoriesDir :: String
+ Darcs.Repository.HashedRepo: listInventoriesLocal :: IO [String]
+ Darcs.Repository.HashedRepo: listInventoriesRepoDir :: String -> IO [String]
+ Darcs.Repository.HashedRepo: listPatchesLocalBucketed :: String -> String -> IO [String]
+ Darcs.Repository.HashedRepo: patchesDir :: String
+ Darcs.Repository.HashedRepo: pristineDir :: String
+ Darcs.Repository.HashedRepo: set :: [String] -> Set ByteString
+ Darcs.Repository.HashedRepo: unset :: Set ByteString -> [String]
+ Darcs.Repository.Internal: DontUpdatePristineNorRevert :: UpdatePristine
+ Darcs.Repository.Internal: identifyRepository :: UseCache -> String -> IO (Repository p wR wU wT)
+ Darcs.Repository.Internal: reorderInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wR -> Compression -> UpdateWorking -> Verbosity -> IO ()
+ Darcs.Repository.Internal: tentativelyAddPatches_ :: (RepoPatch p, ApplyState p ~ Tree) => UpdatePristine -> Repository p wR wU wT -> Compression -> Verbosity -> UpdateWorking -> FL (PatchInfoAnd p) wT wY -> IO (Repository p wR wU wY)
+ Darcs.Repository.Internal: tentativelyRemoveFromPending :: RepoPatch p => Repository p wR wU wT -> UpdateWorking -> PatchInfoAnd p wX wY -> IO ()
+ Darcs.Repository.Internal: tentativelyRemovePatches_ :: (RepoPatch p, ApplyState p ~ Tree) => UpdatePristine -> Repository p wR wU wT -> Compression -> UpdateWorking -> FL (PatchInfoAnd p) wX wT -> IO (Repository p wR wU wX)
+ Darcs.Repository.Internal: withTentative :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a
+ Darcs.Repository.InternalTypes: instance Show (Repository p wRecordedstate wUnrecordedstate wTentativestate)
+ Darcs.Repository.Job: PrimV1Job :: (forall p wR wU. (RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim) => Repository p wR wU wR -> IO a) -> RepoJob a
+ Darcs.Repository.Job: RebaseAwareJob :: Compression -> Verbosity -> UpdateWorking -> (forall p wR wU. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository p wR wU wR -> IO a) -> RepoJob a
+ Darcs.Repository.Job: RebaseJob :: Compression -> Verbosity -> UpdateWorking -> (forall p wR wU. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a) -> RepoJob a
+ Darcs.Repository.Job: RepoJob :: (forall p wR wU. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository p wR wU wR -> IO a) -> RepoJob a
+ Darcs.Repository.Job: StartRebaseJob :: Compression -> Verbosity -> UpdateWorking -> (forall p wR wU. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a) -> RepoJob a
+ Darcs.Repository.Job: V1Job :: (forall wR wU. Repository (Patch Prim) wR wU wR -> IO a) -> RepoJob a
+ Darcs.Repository.Job: V2Job :: (forall wR wU. Repository (RealPatch Prim) wR wU wR -> IO a) -> RepoJob a
+ Darcs.Repository.Job: data RepoJob a
+ Darcs.Repository.Job: withRepoLock :: DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
+ Darcs.Repository.Job: withRepoLockCanFail :: UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
+ Darcs.Repository.Job: withRepository :: UseCache -> RepoJob a -> IO a
+ Darcs.Repository.Job: withRepositoryDirectory :: UseCache -> String -> RepoJob a -> IO a
+ Darcs.Repository.Lock: addToErrorLoc :: IOException -> String -> IOException
+ Darcs.Repository.Lock: appendBinFile :: FilePathLike p => p -> String -> IO ()
+ Darcs.Repository.Lock: appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()
+ Darcs.Repository.Lock: appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()
+ Darcs.Repository.Lock: canonFilename :: FilePath -> IO FilePath
+ Darcs.Repository.Lock: environmentHelpKeepTmpdir :: ([String], [String])
+ Darcs.Repository.Lock: environmentHelpLocks :: ([String], [String])
+ Darcs.Repository.Lock: environmentHelpTmpdir :: ([String], [String])
+ Darcs.Repository.Lock: gzWriteAtomicFilePS :: FilePathLike p => p -> ByteString -> IO ()
+ Darcs.Repository.Lock: gzWriteAtomicFilePSs :: FilePathLike p => p -> [ByteString] -> IO ()
+ Darcs.Repository.Lock: gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()
+ Darcs.Repository.Lock: maybeRelink :: String -> String -> IO Bool
+ Darcs.Repository.Lock: readBinFile :: FilePathLike p => p -> IO String
+ Darcs.Repository.Lock: readDocBinFile :: FilePathLike p => p -> IO Doc
+ Darcs.Repository.Lock: readLocaleFile :: FilePathLike p => p -> IO String
+ Darcs.Repository.Lock: removeFileMayNotExist :: FilePathLike p => p -> IO ()
+ Darcs.Repository.Lock: rmRecursive :: FilePath -> IO ()
+ Darcs.Repository.Lock: tempdirLoc :: IO FilePath
+ Darcs.Repository.Lock: withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a
+ Darcs.Repository.Lock: withLock :: String -> IO a -> IO a
+ Darcs.Repository.Lock: withLockCanFail :: String -> IO a -> IO (Either () a)
+ Darcs.Repository.Lock: withNamedTemp :: String -> (String -> IO a) -> IO a
+ Darcs.Repository.Lock: withOpenTemp :: ((Handle, String) -> IO a) -> IO a
+ Darcs.Repository.Lock: withPermDir :: String -> (AbsolutePath -> IO a) -> IO a
+ Darcs.Repository.Lock: withStdoutTemp :: (String -> IO a) -> IO a
+ Darcs.Repository.Lock: withTemp :: (String -> IO a) -> IO a
+ Darcs.Repository.Lock: withTempDir :: String -> (AbsolutePath -> IO a) -> IO a
+ Darcs.Repository.Lock: worldReadableTemp :: String -> IO String
+ Darcs.Repository.Lock: writeAtomicFilePS :: FilePathLike p => p -> ByteString -> IO ()
+ Darcs.Repository.Lock: writeBinFile :: FilePathLike p => p -> String -> IO ()
+ Darcs.Repository.Lock: writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()
+ Darcs.Repository.Lock: writeLocaleFile :: FilePathLike p => p -> String -> IO ()
+ Darcs.Repository.Lock: writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()
+ Darcs.Repository.Match: getFirstMatch :: (ApplyMonad DefaultIO (ApplyState p), RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [MatchFlag] -> IO ()
+ Darcs.Repository.Match: getNonrangeMatch :: (ApplyMonad DefaultIO (ApplyState p), RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [MatchFlag] -> IO ()
+ Darcs.Repository.Match: getOnePatchset :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [MatchFlag] -> IO (SealedPatchSet p Origin)
+ Darcs.Repository.Match: getPartialNonrangeMatch :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree) => Repository p wR wU wT -> [MatchFlag] -> [FileName] -> IO ()
+ Darcs.Repository.PatchIndex: attemptCreatePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()
+ Darcs.Repository.PatchIndex: canCreatePI :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO Bool
+ Darcs.Repository.PatchIndex: canUsePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO Bool
+ Darcs.Repository.PatchIndex: createOrUpdatePatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()
+ Darcs.Repository.PatchIndex: createPIWithInterrupt :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()
+ Darcs.Repository.PatchIndex: deletePatchIndex :: FilePath -> IO ()
+ Darcs.Repository.PatchIndex: doesPatchIndexExist :: FilePath -> IO Bool
+ Darcs.Repository.PatchIndex: dumpPatchIndex :: FilePath -> IO ()
+ Darcs.Repository.PatchIndex: dumpPatchIndexFiles :: FilePath -> IO ()
+ Darcs.Repository.PatchIndex: filterPatches :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) => Repository p wR wU wT -> [FilePath] -> [Sealed2 a] -> IO [Sealed2 a]
+ Darcs.Repository.PatchIndex: getRelevantSubsequence :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) => Sealed ((RL a) wK) -> Repository p wR wU wR -> [FileName] -> IO (Sealed ((RL a) Origin))
+ Darcs.Repository.PatchIndex: instance Eq FileIdSpan
+ Darcs.Repository.PatchIndex: instance Eq FileInfo
+ Darcs.Repository.PatchIndex: instance Eq FilePathSpan
+ Darcs.Repository.PatchIndex: instance Ord FileIdSpan
+ Darcs.Repository.PatchIndex: instance Ord FileInfo
+ Darcs.Repository.PatchIndex: instance Ord FilePathSpan
+ Darcs.Repository.PatchIndex: instance Show FileIdSpan
+ Darcs.Repository.PatchIndex: instance Show FileInfo
+ Darcs.Repository.PatchIndex: instance Show FilePathSpan
+ Darcs.Repository.PatchIndex: isPatchIndexDisabled :: FilePath -> IO Bool
+ Darcs.Repository.PatchIndex: isPatchIndexInSync :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO Bool
+ Darcs.Repository.PatchIndex: maybeFilterPatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> PatchFilter p
+ Darcs.Repository.PatchIndex: piTest :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()
+ Darcs.Repository.PatchIndex: type PatchFilter p = [FilePath] -> [Sealed2 (PatchInfoAnd p)] -> IO [Sealed2 (PatchInfoAnd p)]
+ Darcs.Repository.Prefs: addRepoSource :: String -> DryRun -> RemoteRepos -> SetDefault -> IO ()
+ Darcs.Repository.Prefs: deleteSources :: IO ()
+ Darcs.Repository.Prefs: getDefaultRepoPath :: IO (Maybe String)
+ Darcs.Repository.Prefs: globalPrefsDir :: IO (Maybe FilePath)
+ Darcs.Repository.Prefs: oldGlobalCacheDir :: IO (Maybe FilePath)
+ Darcs.Repository.Read: readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (PatchSet p Origin wR)
+ Darcs.Repository.Rebase: rebaseJob :: (RepoPatch p, ApplyState p ~ Tree) => (Repository (Rebasing p) wR wU wR -> IO a) -> Repository (Rebasing p) wR wU wR -> Compression -> Verbosity -> UpdateWorking -> IO a
+ Darcs.Repository.Rebase: repoJobOnRebaseRepo :: (RepoPatch p, ApplyState p ~ Tree) => (Repository (Rebasing p) wR wU wR -> IO a) -> Repository (Rebasing p) wR wU wR -> IO a
+ Darcs.Repository.Rebase: startRebaseJob :: (RepoPatch p, ApplyState p ~ Tree) => (Repository (Rebasing p) wR wU wR -> IO a) -> Repository (Rebasing p) wR wU wR -> Compression -> Verbosity -> UpdateWorking -> IO a
+ Darcs.Repository.Rebase: withManualRebaseUpdate :: (RepoPatch p, ApplyState p ~ Tree) => Compression -> Verbosity -> UpdateWorking -> Repository p wR wU wT1 -> (Repository p wR wU wT1 -> IO (Repository p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x)) -> IO (Repository p wR wU wT2, x)
+ Darcs.Repository.Resolution: externalResolution :: (RepoPatch p, ApplyState p ~ Tree) => DiffAlgorithm -> Tree IO -> String -> WantGuiPause -> FL (PrimOf p) wX wY -> FL (PrimOf p) wX wZ -> FL p wY wA -> IO (Sealed (FL (PrimOf p) wA))
+ Darcs.Repository.Resolution: patchsetConflictResolutions :: RepoPatch p => PatchSet p Origin wX -> Sealed (FL (PrimOf p) wX)
+ Darcs.Repository.Resolution: standardResolution :: (PrimPatchBase p, Conflict p, CommuteNoConflicts p) => FL p wX wY -> Sealed (FL (PrimOf p) wY)
+ Darcs.Repository.Ssh: SCP :: SSHCmd
+ Darcs.Repository.Ssh: SFTP :: SSHCmd
+ Darcs.Repository.Ssh: SSH :: SSHCmd
+ Darcs.Repository.Ssh: copySSH :: RemoteDarcs -> SshFilePath -> FilePath -> IO ()
+ Darcs.Repository.Ssh: data SSHCmd
+ Darcs.Repository.Ssh: environmentHelpScp :: ([String], [String])
+ Darcs.Repository.Ssh: environmentHelpSsh :: ([String], [String])
+ Darcs.Repository.Ssh: environmentHelpSshPort :: ([String], [String])
+ Darcs.Repository.Ssh: getSSH :: SSHCmd -> IO (String, [String])
+ Darcs.Repository.Ssh: remoteDarcs :: RemoteDarcs -> String
+ Darcs.Repository.State: filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree) => RL (PatchInfoAnd p) wX wT -> Repository p wR wU wT -> FL (PatchInfoAnd p) wX wZ -> IO (Bool, Sealed (FL (PatchInfoAnd p) wX))
+ Darcs.Repository.State: readPendingAndWorking :: (RepoPatch p, ApplyState p ~ Tree) => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT -> Maybe [SubPath] -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU)
+ Darcs.Repository.State: restrictDarcsdir :: TreeFilter m
+ Darcs.Repository.State: unrecordedChangesWithPatches :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT -> Maybe [SubPath] -> FL (PrimOf p) wX wT -> FL (PrimOf p) wT wT -> IO (FL (PrimOf p) wT wU)
+ Darcs.Repository.State: updateIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()
+ Darcs.Repository.Test: getTest :: Verbosity -> IO (IO ExitCode)
+ Darcs.Repository.Test: runPosthook :: Maybe String -> Bool -> Verbosity -> AbsolutePath -> IO ExitCode
+ Darcs.Repository.Test: runPrehook :: Maybe String -> Bool -> Verbosity -> AbsolutePath -> IO ExitCode
+ Darcs.Repository.Test: testTentative :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> RunTest -> LeaveTestDir -> SetScriptsExecutable -> Verbosity -> IO ExitCode
+ Darcs.Repository.Util: defaultToks :: String
+ Darcs.Repository.Util: floatSubPath :: SubPath -> AnchoredPath
+ Darcs.Repository.Util: getMovesPs :: (PrimConstruct prim, PrimCanonize prim, RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository p wR wU wR -> Maybe [SubPath] -> IO (FL prim wB wB)
+ Darcs.Repository.Util: getRecursiveDarcsRepos :: FilePath -> IO [FilePath]
+ Darcs.Repository.Util: getReplaces :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, wX ~ wR) => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT -> Maybe [SubPath] -> IO (Sealed (FL (PrimOf p) wX))
+ Darcs.Repository.Util: maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Tree IO -> IO (Maybe (Tree IO))
+ Darcs.Repository.Util: patchSetfMap :: (forall wW wZ. PatchInfoAnd p wW wZ -> IO a) -> PatchSet p wW' wZ' -> IO [a]
+ Darcs.UI.ApplyPatches: PatchProxy :: PatchProxy
+ Darcs.UI.ApplyPatches: StandardPatchApplier :: StandardPatchApplier
+ Darcs.UI.ApplyPatches: applyPatches :: (PatchApplier pa, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree) => pa -> PatchProxy p -> String -> [DarcsFlag] -> String -> Repository (CarrierType pa p) wR wU wT -> FL (PatchInfoAnd (CarrierType pa p)) wX wT -> FL (PatchInfoAnd (CarrierType pa p)) wX wZ -> IO ()
+ Darcs.UI.ApplyPatches: class PatchApplier pa where type family CarrierType pa (p :: * -> * -> *) :: * -> * -> *
+ Darcs.UI.ApplyPatches: data PatchProxy (p :: * -> * -> *)
+ Darcs.UI.ApplyPatches: data StandardPatchApplier
+ Darcs.UI.ApplyPatches: instance PatchApplier StandardPatchApplier
+ Darcs.UI.ApplyPatches: repoJob :: PatchApplier pa => pa -> [DarcsFlag] -> (forall p wR wU. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, RepoPatch (CarrierType pa p), ApplyState (CarrierType pa p) ~ Tree, ApplyState (PrimOf (CarrierType pa p)) ~ Tree) => (PatchProxy p -> Repository (CarrierType pa p) wR wU wR -> IO ())) -> RepoJob ()
+ Darcs.UI.Commands: CommandData :: WrappedCommand -> CommandControl
+ Darcs.UI.Commands: CommandOnly :: DarcsCommand parsedFlags -> CommandArgs
+ Darcs.UI.Commands: DarcsCommand :: String -> String -> String -> String -> Int -> [String] -> ((AbsolutePath, AbsolutePath) -> parsedFlags -> [String] -> IO ()) -> ([DarcsFlag] -> IO (Either String ())) -> IO [String] -> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String]) -> [DarcsOptDescr DarcsFlag] -> [DarcsOptDescr DarcsFlag] -> [DarcsFlag] -> ([DarcsFlag] -> [String]) -> ([DarcsFlag] -> parsedFlags) -> DarcsCommand parsedFlags
+ Darcs.UI.Commands: GroupName :: String -> CommandControl
+ Darcs.UI.Commands: HiddenCommand :: WrappedCommand -> CommandControl
+ Darcs.UI.Commands: SuperCommand :: String -> String -> String -> String -> ([DarcsFlag] -> IO (Either String ())) -> [CommandControl] -> DarcsCommand parsedFlags
+ Darcs.UI.Commands: SuperCommandOnly :: DarcsCommand parsedFlags -> CommandArgs
+ Darcs.UI.Commands: SuperCommandSub :: DarcsCommand parsedFlags1 -> DarcsCommand parsedFlags2 -> CommandArgs
+ Darcs.UI.Commands: WrappedCommand :: DarcsCommand parsedFlags -> WrappedCommand
+ Darcs.UI.Commands: abortRun :: [DarcsFlag] -> Doc -> IO ()
+ Darcs.UI.Commands: amInHashedRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.UI.Commands: amInRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.UI.Commands: amNotInRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.UI.Commands: commandAdvancedOptions :: DarcsCommand parsedFlags -> [DarcsOptDescr DarcsFlag]
+ Darcs.UI.Commands: commandAlias :: String -> Maybe (DarcsCommand pf) -> DarcsCommand pf -> DarcsCommand pf
+ Darcs.UI.Commands: commandAlloptions :: DarcsCommand pf -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
+ Darcs.UI.Commands: commandArgdefaults :: DarcsCommand parsedFlags -> [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
+ Darcs.UI.Commands: commandBasicOptions :: DarcsCommand parsedFlags -> [DarcsOptDescr DarcsFlag]
+ Darcs.UI.Commands: commandCheckOptions :: DarcsCommand parsedFlags -> [DarcsFlag] -> [String]
+ Darcs.UI.Commands: commandCommand :: DarcsCommand parsedFlags -> (AbsolutePath, AbsolutePath) -> parsedFlags -> [String] -> IO ()
+ Darcs.UI.Commands: commandDefaults :: DarcsCommand parsedFlags -> [DarcsFlag]
+ Darcs.UI.Commands: commandDescription :: DarcsCommand parsedFlags -> String
+ Darcs.UI.Commands: commandExtraArgHelp :: DarcsCommand parsedFlags -> [String]
+ Darcs.UI.Commands: commandExtraArgs :: DarcsCommand parsedFlags -> Int
+ Darcs.UI.Commands: commandGetArgPossibilities :: DarcsCommand parsedFlags -> IO [String]
+ Darcs.UI.Commands: commandGroup :: String -> CommandControl
+ Darcs.UI.Commands: commandHelp :: DarcsCommand parsedFlags -> String
+ Darcs.UI.Commands: commandName :: DarcsCommand parsedFlags -> String
+ Darcs.UI.Commands: commandOptions :: AbsolutePath -> DarcsCommand pf -> [OptDescr DarcsFlag]
+ Darcs.UI.Commands: commandParseOptions :: DarcsCommand parsedFlags -> [DarcsFlag] -> parsedFlags
+ Darcs.UI.Commands: commandPrereq :: DarcsCommand parsedFlags -> [DarcsFlag] -> IO (Either String ())
+ Darcs.UI.Commands: commandProgramName :: DarcsCommand parsedFlags -> String
+ Darcs.UI.Commands: commandStub :: String -> String -> String -> DarcsCommand pf -> DarcsCommand pf
+ Darcs.UI.Commands: commandSubCommands :: DarcsCommand parsedFlags -> [CommandControl]
+ Darcs.UI.Commands: data CommandArgs
+ Darcs.UI.Commands: data CommandControl
+ Darcs.UI.Commands: data DarcsCommand parsedFlags
+ Darcs.UI.Commands: data WrappedCommand
+ Darcs.UI.Commands: defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
+ Darcs.UI.Commands: disambiguateCommands :: [CommandControl] -> String -> [String] -> Either String (CommandArgs, [String])
+ Darcs.UI.Commands: extractAllCommands :: [CommandControl] -> [WrappedCommand]
+ Darcs.UI.Commands: extractCommands :: [CommandControl] -> [WrappedCommand]
+ Darcs.UI.Commands: findRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.UI.Commands: formatPath :: String -> String
+ Darcs.UI.Commands: getCommandHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String
+ Darcs.UI.Commands: getCommandMiniHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String
+ Darcs.UI.Commands: getSubcommands :: DarcsCommand pf -> [CommandControl]
+ Darcs.UI.Commands: hiddenCommand :: DarcsCommand parsedFlags -> CommandControl
+ Darcs.UI.Commands: nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
+ Darcs.UI.Commands: normalCommand :: DarcsCommand parsedFlags -> CommandControl
+ Darcs.UI.Commands: printDryRunMessageAndExit :: (RepoPatch p, ApplyState p ~ Tree) => String -> Verbosity -> Summary -> DryRun -> XmlOutput -> Bool -> FL (PatchInfoAnd p) wX wY -> IO ()
+ Darcs.UI.Commands: putInfo :: [DarcsFlag] -> Doc -> IO ()
+ Darcs.UI.Commands: putVerbose :: [DarcsFlag] -> Doc -> IO ()
+ Darcs.UI.Commands: putVerboseWarning :: [DarcsFlag] -> Doc -> IO ()
+ Darcs.UI.Commands: putWarning :: [DarcsFlag] -> Doc -> IO ()
+ Darcs.UI.Commands: setEnvDarcsFiles :: (PatchInspect p, Patchy p) => p wX wY -> IO ()
+ Darcs.UI.Commands: setEnvDarcsPatches :: (RepoPatch p, ApplyState p ~ Tree) => FL (PatchInfoAnd p) wX wY -> IO ()
+ Darcs.UI.Commands: subusage :: DarcsCommand pf -> String
+ Darcs.UI.Commands: superName :: Maybe (DarcsCommand pf) -> String
+ Darcs.UI.Commands: usage :: [CommandControl] -> String
+ Darcs.UI.Commands: usageHelper :: [CommandControl] -> String
+ Darcs.UI.Commands: withStdOpts :: DarcsOption (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c -> DarcsOption (UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) b -> DarcsOption a c
+ Darcs.UI.Commands: wrappedCommandName :: WrappedCommand -> String
+ Darcs.UI.Commands.Add: add :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Add: expandDirs :: Bool -> [SubPath] -> IO [SubPath]
+ Darcs.UI.Commands.Amend: amend :: DarcsCommand AmendConfig
+ Darcs.UI.Commands.Amend: amendrecord :: DarcsCommand AmendConfig
+ Darcs.UI.Commands.Amend: updatePatchHeader :: (RepoPatch p, ApplyState p ~ Tree) => Bool -> PatchSelectionOptions -> Bool -> Bool -> Maybe String -> Maybe String -> Maybe AskLongComment -> Repository p wR wU wT -> PatchInfoAnd p wT wX -> FL (PrimOf p) wX wY -> IO (Maybe String, PatchInfoAnd p wT wY)
+ Darcs.UI.Commands.Annotate: annotate :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Apply: apply :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Apply: applyCmd :: PatchApplier pa => pa -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
+ Darcs.UI.Commands.Apply: getPatchBundle :: RepoPatch p => [DarcsFlag] -> ByteString -> IO (Either String (SealedPatchSet p Origin))
+ Darcs.UI.Commands.Clone: clone :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Clone: cloneToSSH :: [DarcsFlag] -> Maybe String
+ Darcs.UI.Commands.Clone: get :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Clone: makeRepoName :: Bool -> [DarcsFlag] -> FilePath -> IO String
+ Darcs.UI.Commands.Clone: put :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Convert: convert :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Convert: instance Show Object
+ Darcs.UI.Commands.Convert: instance Show RefId
+ Darcs.UI.Commands.Convert: instance Show State
+ Darcs.UI.Commands.Diff: diffCommand :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Dist: dist :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Dist: doFastZip :: [DarcsFlag] -> IO ()
+ Darcs.UI.Commands.GZCRCs: doCRCWarnings :: Bool -> IO ()
+ Darcs.UI.Commands.GZCRCs: gzcrcs :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Help: commandControlList :: [CommandControl]
+ Darcs.UI.Commands.Help: environmentHelp :: [([String], [String])]
+ Darcs.UI.Commands.Help: helpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
+ Darcs.UI.Commands.Help: listAvailableCommands :: IO ()
+ Darcs.UI.Commands.Help: printVersion :: IO ()
+ Darcs.UI.Commands.Init: initialize :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Init: initializeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
+ Darcs.UI.Commands.Log: changelog :: (Apply p, ApplyState p ~ Tree, ShowPatch p, IsHunk p, PrimPatchBase p, PatchListFormat p, Conflict p, CommuteNoConflicts p) => [DarcsFlag] -> PatchSet p wStart wX -> ([(Sealed2 (PatchInfoAnd p), [FilePath])], [(FilePath, FilePath)], Maybe Doc) -> Doc
+ Darcs.UI.Commands.Log: changes :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Log: getLogInfo :: (Matchable p, ApplyState p ~ Tree) => Maybe Int -> [MatchFlag] -> Bool -> Maybe [FilePath] -> PatchFilter p -> PatchSet p wX wY -> IO ([(Sealed2 (PatchInfoAnd p), [FilePath])], [(FilePath, FilePath)], Maybe Doc)
+ Darcs.UI.Commands.Log: log :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.MarkConflicts: markconflicts :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Move: instance Eq FileKind
+ Darcs.UI.Commands.Move: instance Show FileKind
+ Darcs.UI.Commands.Move: instance Show FileStatus
+ Darcs.UI.Commands.Move: move :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Move: mv :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Optimize: doOptimizeHTTP :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()
+ Darcs.UI.Commands.Optimize: optimize :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Pull: data StandardPatchApplier
+ Darcs.UI.Commands.Pull: fetch :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Pull: fetchPatches :: (RepoPatch p, ApplyState p ~ Tree) => AbsolutePath -> [DarcsFlag] -> [String] -> String -> Repository p wR wU wR -> IO (SealedPatchSet p Origin, Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wR))
+ Darcs.UI.Commands.Pull: pull :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Pull: pullCmd :: PatchApplier pa => pa -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
+ Darcs.UI.Commands.Pull: revertable :: IO a -> IO a
+ Darcs.UI.Commands.Push: push :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Rebase: instance PatchApplier RebasePatchApplier
+ Darcs.UI.Commands.Rebase: rebase :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Record: RecordConfig :: Maybe String -> Maybe String -> TestChanges -> Maybe Bool -> Bool -> Bool -> Maybe AskLongComment -> LookFor -> Maybe String -> WithContext -> DiffAlgorithm -> Verbosity -> Logfile -> Compression -> UseIndex -> UMask -> SetScriptsExecutable -> UseCache -> RecordConfig
+ Darcs.UI.Commands.Record: _workingRepoDir :: RecordConfig -> Maybe String
+ Darcs.UI.Commands.Record: askDeps :: RecordConfig -> Bool
+ Darcs.UI.Commands.Record: askLongComment :: RecordConfig -> Maybe AskLongComment
+ Darcs.UI.Commands.Record: author :: RecordConfig -> Maybe String
+ Darcs.UI.Commands.Record: commit :: DarcsCommand RecordConfig
+ Darcs.UI.Commands.Record: compress :: RecordConfig -> Compression
+ Darcs.UI.Commands.Record: data RecordConfig
+ Darcs.UI.Commands.Record: diffAlgorithm :: RecordConfig -> DiffAlgorithm
+ Darcs.UI.Commands.Record: getLog :: (Patchy prim, PrimPatch prim) => Maybe String -> Bool -> Logfile -> Maybe AskLongComment -> Maybe (String, [String]) -> FL prim wX wY -> IO (String, [String], Maybe String)
+ Darcs.UI.Commands.Record: interactive :: RecordConfig -> Maybe Bool
+ Darcs.UI.Commands.Record: logfile :: RecordConfig -> Logfile
+ Darcs.UI.Commands.Record: lookfor :: RecordConfig -> LookFor
+ Darcs.UI.Commands.Record: patchname :: RecordConfig -> Maybe String
+ Darcs.UI.Commands.Record: pipe :: RecordConfig -> Bool
+ Darcs.UI.Commands.Record: record :: DarcsCommand RecordConfig
+ Darcs.UI.Commands.Record: recordConfig :: [DarcsFlag] -> RecordConfig
+ Darcs.UI.Commands.Record: sse :: RecordConfig -> SetScriptsExecutable
+ Darcs.UI.Commands.Record: testChanges :: RecordConfig -> TestChanges
+ Darcs.UI.Commands.Record: umask :: RecordConfig -> UMask
+ Darcs.UI.Commands.Record: useCache :: RecordConfig -> UseCache
+ Darcs.UI.Commands.Record: useIndex :: RecordConfig -> UseIndex
+ Darcs.UI.Commands.Record: verbosity :: RecordConfig -> Verbosity
+ Darcs.UI.Commands.Record: withContext :: RecordConfig -> WithContext
+ Darcs.UI.Commands.Remove: remove :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Remove: rm :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Remove: unadd :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Repair: check :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Repair: repair :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Replace: defaultToks :: String
+ Darcs.UI.Commands.Replace: replace :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Revert: revert :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Rollback: rollback :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Send: send :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.SetPref: setpref :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Show: list :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Show: query :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Show: showCommand :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.ShowAuthors: canonizeAuthor :: [Spelling] -> String -> String
+ Darcs.UI.Commands.ShowAuthors: compiledAuthorSpellings :: [DarcsFlag] -> IO [Spelling]
+ Darcs.UI.Commands.ShowAuthors: data Spelling
+ Darcs.UI.Commands.ShowAuthors: rankAuthors :: [Spelling] -> [String] -> [String]
+ Darcs.UI.Commands.ShowAuthors: showAuthors :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.ShowBug: showBug :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.ShowContents: showContents :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.ShowFiles: manifest :: [DarcsFlag] -> [String] -> IO [FilePath]
+ Darcs.UI.Commands.ShowFiles: manifestCmd :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
+ Darcs.UI.Commands.ShowFiles: showFiles :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.ShowFiles: toListManifest :: [DarcsFlag] -> Tree m -> [FilePath]
+ Darcs.UI.Commands.ShowIndex: showIndex :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.ShowIndex: showPristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
+ Darcs.UI.Commands.ShowPatchIndex: patchIndexTest :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.ShowPatchIndex: showPatchIndexAll :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.ShowPatchIndex: showPatchIndexFiles :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.ShowPatchIndex: showPatchIndexStatus :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.ShowRepo: showRepo :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.ShowTags: showTags :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Tag: getTags :: MaybeInternal p => PatchSet p wW wR -> IO [String]
+ Darcs.UI.Commands.Tag: tag :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Test: instance Show BisectDir
+ Darcs.UI.Commands.Test: test :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.TransferMode: transferMode :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Unrecord: getLastPatches :: RepoPatch p => [MatchFlag] -> PatchSet p Origin wR -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR
+ Darcs.UI.Commands.Unrecord: matchingHead :: RepoPatch p => [MatchFlag] -> PatchSet p Origin wR -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR
+ Darcs.UI.Commands.Unrecord: obliterate :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Unrecord: unpull :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Unrecord: unrecord :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Unrevert: unrevert :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.Unrevert: writeUnrevert :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> FL (PrimOf p) wX wY -> Tree IO -> FL (PrimOf p) wR wX -> IO ()
+ Darcs.UI.Commands.Util: announceFiles :: Maybe [SubPath] -> String -> IO ()
+ Darcs.UI.Commands.Util: filterExistingFiles :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> LookForAdds -> [SubPath] -> IO [SubPath]
+ Darcs.UI.Commands.Util: getUniqueDPatchName :: FilePath -> IO FilePath
+ Darcs.UI.Commands.Util: getUniqueRepositoryName :: Bool -> FilePath -> IO FilePath
+ Darcs.UI.Commands.Util: testTentativeAndMaybeExit :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Verbosity -> TestChanges -> SetScriptsExecutable -> Bool -> String -> String -> Maybe String -> IO ()
+ Darcs.UI.Commands.Util.Tree: treeHas :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool
+ Darcs.UI.Commands.Util.Tree: treeHasAnycase :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool
+ Darcs.UI.Commands.Util.Tree: treeHasDir :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool
+ Darcs.UI.Commands.Util.Tree: treeHasFile :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool
+ Darcs.UI.Commands.WhatsNew: status :: DarcsCommand [DarcsFlag]
+ Darcs.UI.Commands.WhatsNew: whatsnew :: DarcsCommand [DarcsFlag]
+ Darcs.UI.CommandsAux: checkPaths :: PatchInspect p => [DarcsFlag] -> FL p wX wY -> IO ()
+ Darcs.UI.CommandsAux: hasMaliciousPath :: PatchInspect p => p wX wY -> Bool
+ Darcs.UI.CommandsAux: maliciousPatches :: PatchInspect p => [Sealed2 p] -> [Sealed2 p]
+ Darcs.UI.Defaults: applyDefaults :: Maybe String -> DarcsCommand pf -> [DarcsFlag] -> IO [DarcsFlag]
+ Darcs.UI.Email: formatHeader :: String -> String -> ByteString
+ Darcs.UI.Email: makeEmail :: String -> [(String, String)] -> Maybe Doc -> Maybe String -> Doc -> Maybe String -> Doc
+ Darcs.UI.Email: readEmail :: ByteString -> ByteString
+ Darcs.UI.External: catchall :: IO a -> IO a -> IO a
+ Darcs.UI.External: darcsProgram :: IO String
+ Darcs.UI.External: diffProgram :: IO String
+ Darcs.UI.External: editFile :: FilePathLike p => p -> IO (ExitCode, Bool)
+ Darcs.UI.External: editText :: String -> ByteString -> IO ByteString
+ Darcs.UI.External: execDocPipe :: RenderMode -> String -> [String] -> Doc -> IO Doc
+ Darcs.UI.External: execPipeIgnoreError :: RenderMode -> String -> [String] -> Doc -> IO Doc
+ Darcs.UI.External: generateEmail :: Handle -> String -> String -> String -> String -> Doc -> IO ()
+ Darcs.UI.External: getSystemEncoding :: IO String
+ Darcs.UI.External: haveSendmail :: IO Bool
+ Darcs.UI.External: isUTF8Locale :: String -> Bool
+ Darcs.UI.External: maybeURLCmd :: String -> String -> IO (Maybe String)
+ Darcs.UI.External: pipeDoc :: RenderMode -> String -> [String] -> Doc -> IO ExitCode
+ Darcs.UI.External: pipeDocSSH :: Compression -> RenderMode -> SshFilePath -> [String] -> Doc -> IO ExitCode
+ Darcs.UI.External: resendEmail :: String -> String -> ByteString -> IO ()
+ Darcs.UI.External: sendEmail :: String -> String -> String -> String -> String -> String -> IO ()
+ Darcs.UI.External: sendEmailDoc :: String -> String -> String -> String -> String -> Maybe (Doc, Doc) -> Doc -> IO ()
+ Darcs.UI.External: sendmailPath :: IO String
+ Darcs.UI.External: setDarcsEncodings :: IO ()
+ Darcs.UI.External: signString :: Sign -> Doc -> IO Doc
+ Darcs.UI.External: verifyPS :: Verify -> ByteString -> IO (Maybe ByteString)
+ Darcs.UI.External: viewDoc :: Doc -> IO ()
+ Darcs.UI.External: viewDocWith :: Printers -> RenderMode -> Doc -> IO ()
+ Darcs.UI.Flags: AfterHash :: String -> DarcsFlag
+ Darcs.UI.Flags: AfterPatch :: String -> DarcsFlag
+ Darcs.UI.Flags: AfterPattern :: String -> DarcsFlag
+ Darcs.UI.Flags: AfterTag :: String -> DarcsFlag
+ Darcs.UI.Flags: All :: DarcsFlag
+ Darcs.UI.Flags: AllowCaseOnly :: DarcsFlag
+ Darcs.UI.Flags: AllowConflicts :: DarcsFlag
+ Darcs.UI.Flags: AllowUnrelatedRepos :: DarcsFlag
+ Darcs.UI.Flags: AllowWindowsReserved :: DarcsFlag
+ Darcs.UI.Flags: AmendUnrecord :: DarcsFlag
+ Darcs.UI.Flags: ApplyAs :: String -> DarcsFlag
+ Darcs.UI.Flags: ApplyOnDisk :: DarcsFlag
+ Darcs.UI.Flags: AskDeps :: DarcsFlag
+ Darcs.UI.Flags: AskPosthook :: DarcsFlag
+ Darcs.UI.Flags: AskPrehook :: DarcsFlag
+ Darcs.UI.Flags: Author :: String -> DarcsFlag
+ Darcs.UI.Flags: Backoff :: DarcsFlag
+ Darcs.UI.Flags: Bisect :: DarcsFlag
+ Darcs.UI.Flags: Boring :: DarcsFlag
+ Darcs.UI.Flags: Cc :: String -> DarcsFlag
+ Darcs.UI.Flags: ChangesToAllFiles :: DarcsFlag
+ Darcs.UI.Flags: Charset :: String -> DarcsFlag
+ Darcs.UI.Flags: Check :: DarcsFlag
+ Darcs.UI.Flags: Complement :: DarcsFlag
+ Darcs.UI.Flags: Complete :: DarcsFlag
+ Darcs.UI.Flags: Compress :: DarcsFlag
+ Darcs.UI.Flags: Context :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Flags: Count :: DarcsFlag
+ Darcs.UI.Flags: Debug :: DarcsFlag
+ Darcs.UI.Flags: DebugHTTP :: DarcsFlag
+ Darcs.UI.Flags: DiffCmd :: String -> DarcsFlag
+ Darcs.UI.Flags: DiffFlags :: String -> DarcsFlag
+ Darcs.UI.Flags: Directories :: DarcsFlag
+ Darcs.UI.Flags: Disable :: DarcsFlag
+ Darcs.UI.Flags: DistName :: String -> DarcsFlag
+ Darcs.UI.Flags: DistZip :: DarcsFlag
+ Darcs.UI.Flags: DontAllowCaseOnly :: DarcsFlag
+ Darcs.UI.Flags: DontAllowWindowsReserved :: DarcsFlag
+ Darcs.UI.Flags: DontGrabDeps :: DarcsFlag
+ Darcs.UI.Flags: DontIgnoreTimes :: DarcsFlag
+ Darcs.UI.Flags: DontPromptForDependencies :: DarcsFlag
+ Darcs.UI.Flags: DontRestrictPaths :: DarcsFlag
+ Darcs.UI.Flags: DontRmLogFile :: DarcsFlag
+ Darcs.UI.Flags: DontSetScriptsExecutable :: DarcsFlag
+ Darcs.UI.Flags: DryRun :: DarcsFlag
+ Darcs.UI.Flags: EditDescription :: DarcsFlag
+ Darcs.UI.Flags: EditLongComment :: DarcsFlag
+ Darcs.UI.Flags: ExactVersion :: DarcsFlag
+ Darcs.UI.Flags: ExternalMerge :: String -> DarcsFlag
+ Darcs.UI.Flags: Files :: DarcsFlag
+ Darcs.UI.Flags: ForceReplace :: DarcsFlag
+ Darcs.UI.Flags: Forward :: DarcsFlag
+ Darcs.UI.Flags: GenContext :: DarcsFlag
+ Darcs.UI.Flags: HappyForwarding :: DarcsFlag
+ Darcs.UI.Flags: Hashed :: DarcsFlag
+ Darcs.UI.Flags: Help :: DarcsFlag
+ Darcs.UI.Flags: HumanReadable :: DarcsFlag
+ Darcs.UI.Flags: IgnoreTimes :: DarcsFlag
+ Darcs.UI.Flags: InReplyTo :: String -> DarcsFlag
+ Darcs.UI.Flags: Interactive :: DarcsFlag
+ Darcs.UI.Flags: Intersection :: DarcsFlag
+ Darcs.UI.Flags: JustThisRepo :: DarcsFlag
+ Darcs.UI.Flags: KeepDate :: DarcsFlag
+ Darcs.UI.Flags: LastN :: Int -> DarcsFlag
+ Darcs.UI.Flags: Lazy :: DarcsFlag
+ Darcs.UI.Flags: LeaveTestDir :: DarcsFlag
+ Darcs.UI.Flags: Linear :: DarcsFlag
+ Darcs.UI.Flags: ListCommands :: DarcsFlag
+ Darcs.UI.Flags: ListOptions :: DarcsFlag
+ Darcs.UI.Flags: LogFile :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Flags: LookForAdds :: DarcsFlag
+ Darcs.UI.Flags: LookForMoves :: DarcsFlag
+ Darcs.UI.Flags: LookForReplaces :: DarcsFlag
+ Darcs.UI.Flags: MachineReadable :: DarcsFlag
+ Darcs.UI.Flags: Mail :: DarcsFlag
+ Darcs.UI.Flags: MarkConflicts :: DarcsFlag
+ Darcs.UI.Flags: MaxCount :: Int -> DarcsFlag
+ Darcs.UI.Flags: Minimize :: DarcsFlag
+ Darcs.UI.Flags: NewRepo :: String -> DarcsFlag
+ Darcs.UI.Flags: NoAllowConflicts :: DarcsFlag
+ Darcs.UI.Flags: NoAmendUnrecord :: DarcsFlag
+ Darcs.UI.Flags: NoAskDeps :: DarcsFlag
+ Darcs.UI.Flags: NoCache :: DarcsFlag
+ Darcs.UI.Flags: NoCompress :: DarcsFlag
+ Darcs.UI.Flags: NoDirectories :: DarcsFlag
+ Darcs.UI.Flags: NoEditDescription :: DarcsFlag
+ Darcs.UI.Flags: NoEditLongComment :: DarcsFlag
+ Darcs.UI.Flags: NoFiles :: DarcsFlag
+ Darcs.UI.Flags: NoHTTPPipelining :: DarcsFlag
+ Darcs.UI.Flags: NoHappyForwarding :: DarcsFlag
+ Darcs.UI.Flags: NoKeepDate :: DarcsFlag
+ Darcs.UI.Flags: NoLeaveTestDir :: DarcsFlag
+ Darcs.UI.Flags: NoLookForAdds :: DarcsFlag
+ Darcs.UI.Flags: NoLookForMoves :: DarcsFlag
+ Darcs.UI.Flags: NoLookForReplaces :: DarcsFlag
+ Darcs.UI.Flags: NoMinimize :: DarcsFlag
+ Darcs.UI.Flags: NoPacks :: DarcsFlag
+ Darcs.UI.Flags: NoPatchIndexFlag :: DarcsFlag
+ Darcs.UI.Flags: NoPauseForGui :: DarcsFlag
+ Darcs.UI.Flags: NoPending :: DarcsFlag
+ Darcs.UI.Flags: NoPosthook :: DarcsFlag
+ Darcs.UI.Flags: NoPrehook :: DarcsFlag
+ Darcs.UI.Flags: NoRecursive :: DarcsFlag
+ Darcs.UI.Flags: NoReorder :: DarcsFlag
+ Darcs.UI.Flags: NoSetDefault :: DarcsFlag
+ Darcs.UI.Flags: NoSign :: DarcsFlag
+ Darcs.UI.Flags: NoSummary :: DarcsFlag
+ Darcs.UI.Flags: NoTest :: DarcsFlag
+ Darcs.UI.Flags: NonApply :: DarcsFlag
+ Darcs.UI.Flags: NonForce :: DarcsFlag
+ Darcs.UI.Flags: NonUnified :: DarcsFlag
+ Darcs.UI.Flags: NonVerify :: DarcsFlag
+ Darcs.UI.Flags: NormalVerbosity :: DarcsFlag
+ Darcs.UI.Flags: NotInRemote :: (Maybe String) -> DarcsFlag
+ Darcs.UI.Flags: NullFlag :: DarcsFlag
+ Darcs.UI.Flags: NumberPatches :: DarcsFlag
+ Darcs.UI.Flags: Once :: DarcsFlag
+ Darcs.UI.Flags: OneHash :: String -> DarcsFlag
+ Darcs.UI.Flags: OnePatch :: String -> DarcsFlag
+ Darcs.UI.Flags: OnePattern :: String -> DarcsFlag
+ Darcs.UI.Flags: OneTag :: String -> DarcsFlag
+ Darcs.UI.Flags: OnlyChangesToFiles :: DarcsFlag
+ Darcs.UI.Flags: Output :: AbsolutePathOrStd -> DarcsFlag
+ Darcs.UI.Flags: OutputAutoName :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Flags: Packs :: DarcsFlag
+ Darcs.UI.Flags: PatchIndexFlag :: DarcsFlag
+ Darcs.UI.Flags: PatchIndexRange :: Int -> Int -> DarcsFlag
+ Darcs.UI.Flags: PatchName :: String -> DarcsFlag
+ Darcs.UI.Flags: PauseForGui :: DarcsFlag
+ Darcs.UI.Flags: Pending :: DarcsFlag
+ Darcs.UI.Flags: Pipe :: DarcsFlag
+ Darcs.UI.Flags: PosthookCmd :: String -> DarcsFlag
+ Darcs.UI.Flags: PrehookCmd :: String -> DarcsFlag
+ Darcs.UI.Flags: PromptForDependencies :: DarcsFlag
+ Darcs.UI.Flags: PromptLongComment :: DarcsFlag
+ Darcs.UI.Flags: Quiet :: DarcsFlag
+ Darcs.UI.Flags: ReadMarks :: String -> DarcsFlag
+ Darcs.UI.Flags: Recursive :: DarcsFlag
+ Darcs.UI.Flags: RemoteDarcsOpt :: String -> DarcsFlag
+ Darcs.UI.Flags: RemoteRepo :: String -> DarcsFlag
+ Darcs.UI.Flags: Reorder :: DarcsFlag
+ Darcs.UI.Flags: Repair :: DarcsFlag
+ Darcs.UI.Flags: Reply :: String -> DarcsFlag
+ Darcs.UI.Flags: RestrictPaths :: DarcsFlag
+ Darcs.UI.Flags: Reverse :: DarcsFlag
+ Darcs.UI.Flags: RmLogFile :: DarcsFlag
+ Darcs.UI.Flags: RunPosthook :: DarcsFlag
+ Darcs.UI.Flags: RunPrehook :: DarcsFlag
+ Darcs.UI.Flags: SelectAuthor :: DarcsFlag
+ Darcs.UI.Flags: SendmailCmd :: String -> DarcsFlag
+ Darcs.UI.Flags: SetDefault :: DarcsFlag
+ Darcs.UI.Flags: SetScriptsExecutable :: DarcsFlag
+ Darcs.UI.Flags: SeveralPatch :: String -> DarcsFlag
+ Darcs.UI.Flags: SeveralPattern :: String -> DarcsFlag
+ Darcs.UI.Flags: Sibling :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Flags: Sign :: DarcsFlag
+ Darcs.UI.Flags: SignAs :: String -> DarcsFlag
+ Darcs.UI.Flags: SignSSL :: String -> DarcsFlag
+ Darcs.UI.Flags: SkipBoring :: DarcsFlag
+ Darcs.UI.Flags: SkipConflicts :: DarcsFlag
+ Darcs.UI.Flags: StoreInMemory :: DarcsFlag
+ Darcs.UI.Flags: Subject :: String -> DarcsFlag
+ Darcs.UI.Flags: Summary :: DarcsFlag
+ Darcs.UI.Flags: TagName :: String -> DarcsFlag
+ Darcs.UI.Flags: Target :: String -> DarcsFlag
+ Darcs.UI.Flags: Test :: DarcsFlag
+ Darcs.UI.Flags: Timings :: DarcsFlag
+ Darcs.UI.Flags: Toks :: String -> DarcsFlag
+ Darcs.UI.Flags: UMask :: String -> DarcsFlag
+ Darcs.UI.Flags: UnCompress :: DarcsFlag
+ Darcs.UI.Flags: Unified :: DarcsFlag
+ Darcs.UI.Flags: Union :: DarcsFlag
+ Darcs.UI.Flags: UpToHash :: String -> DarcsFlag
+ Darcs.UI.Flags: UpToPatch :: String -> DarcsFlag
+ Darcs.UI.Flags: UpToPattern :: String -> DarcsFlag
+ Darcs.UI.Flags: UpToTag :: String -> DarcsFlag
+ Darcs.UI.Flags: UseFormat1 :: DarcsFlag
+ Darcs.UI.Flags: UseFormat2 :: DarcsFlag
+ Darcs.UI.Flags: UseMyersDiff :: DarcsFlag
+ Darcs.UI.Flags: UseNoWorkingDir :: DarcsFlag
+ Darcs.UI.Flags: UsePatienceDiff :: DarcsFlag
+ Darcs.UI.Flags: UseWorkingDir :: DarcsFlag
+ Darcs.UI.Flags: Verbose :: DarcsFlag
+ Darcs.UI.Flags: Verify :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Flags: VerifySSL :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Flags: Version :: DarcsFlag
+ Darcs.UI.Flags: WorkRepoDir :: String -> DarcsFlag
+ Darcs.UI.Flags: WorkRepoUrl :: String -> DarcsFlag
+ Darcs.UI.Flags: WriteMarks :: String -> DarcsFlag
+ Darcs.UI.Flags: XMLOutput :: DarcsFlag
+ Darcs.UI.Flags: allowConflicts :: Config -> AllowConflicts
+ Darcs.UI.Flags: applyAs :: Config -> Maybe String
+ Darcs.UI.Flags: cloneKind :: Config -> CloneKind
+ Darcs.UI.Flags: compression :: Config -> Compression
+ Darcs.UI.Flags: data DarcsFlag
+ Darcs.UI.Flags: diffAlgorithm :: Config -> DiffAlgorithm
+ Darcs.UI.Flags: diffOpts :: UseIndex -> LookForAdds -> Bool -> DiffAlgorithm -> (UseIndex, ScanKnown, DiffAlgorithm)
+ Darcs.UI.Flags: diffingOpts :: Config -> (UseIndex, ScanKnown, DiffAlgorithm)
+ Darcs.UI.Flags: doAllowCaseOnly :: Config -> Bool
+ Darcs.UI.Flags: doAllowWindowsReserved :: Config -> Bool
+ Darcs.UI.Flags: doHappyForwarding :: Config -> Bool
+ Darcs.UI.Flags: doReverse :: Config -> Bool
+ Darcs.UI.Flags: dryRun :: Config -> DryRun
+ Darcs.UI.Flags: editDescription :: Config -> Bool
+ Darcs.UI.Flags: environmentHelpEmail :: ([String], [String])
+ Darcs.UI.Flags: environmentHelpSendmail :: ([String], [String])
+ Darcs.UI.Flags: externalMerge :: Config -> ExternalMerge
+ Darcs.UI.Flags: fileHelpAuthor :: [String]
+ Darcs.UI.Flags: fixRemoteRepos :: AbsolutePath -> Config -> IO Config
+ Darcs.UI.Flags: fixSubPaths :: (AbsolutePath, AbsolutePath) -> [FilePath] -> IO [SubPath]
+ Darcs.UI.Flags: fixUrl :: AbsolutePath -> String -> IO String
+ Darcs.UI.Flags: getAuthor :: Maybe String -> Bool -> IO String
+ Darcs.UI.Flags: getCc :: Config -> String
+ Darcs.UI.Flags: getCharset :: Config -> Maybe String
+ Darcs.UI.Flags: getDate :: Bool -> IO String
+ Darcs.UI.Flags: getEasyAuthor :: IO [String]
+ Darcs.UI.Flags: getInReplyTo :: Config -> Maybe String
+ Darcs.UI.Flags: getOutput :: Config -> FilePath -> Maybe AbsolutePathOrStd
+ Darcs.UI.Flags: getReply :: Config -> Maybe String
+ Darcs.UI.Flags: getRepourl :: Config -> Maybe String
+ Darcs.UI.Flags: getSendmailCmd :: Config -> IO String
+ Darcs.UI.Flags: getSubject :: Config -> Maybe String
+ Darcs.UI.Flags: hasAuthor :: Config -> Maybe String
+ Darcs.UI.Flags: hasLogfile :: Config -> Maybe AbsolutePath
+ Darcs.UI.Flags: hasSummary :: Summary -> Config -> Summary
+ Darcs.UI.Flags: hasXmlOutput :: Config -> XmlOutput
+ Darcs.UI.Flags: includeBoring :: Config -> Bool
+ Darcs.UI.Flags: isInteractive :: Config -> Bool
+ Darcs.UI.Flags: isUnified :: Config -> WithContext
+ Darcs.UI.Flags: leaveTestDir :: Config -> LeaveTestDir
+ Darcs.UI.Flags: lookForAdds :: Config -> LookForAdds
+ Darcs.UI.Flags: lookForMoves :: Config -> LookForMoves
+ Darcs.UI.Flags: lookForReplaces :: Config -> LookForReplaces
+ Darcs.UI.Flags: maxCount :: Config -> Maybe Int
+ Darcs.UI.Flags: maybeFixSubPaths :: (AbsolutePath, AbsolutePath) -> [FilePath] -> IO [Maybe SubPath]
+ Darcs.UI.Flags: minimize :: Config -> Bool
+ Darcs.UI.Flags: patchFormat :: Config -> PatchFormat
+ Darcs.UI.Flags: promptAuthor :: Bool -> Bool -> IO String
+ Darcs.UI.Flags: remoteDarcs :: Config -> RemoteDarcs
+ Darcs.UI.Flags: remoteRepos :: Config -> RemoteRepos
+ Darcs.UI.Flags: removeFromAmended :: Config -> Bool
+ Darcs.UI.Flags: reorder :: Config -> Reorder
+ Darcs.UI.Flags: runPatchIndex :: Config -> WithPatchIndex
+ Darcs.UI.Flags: runTest :: Config -> RunTest
+ Darcs.UI.Flags: selectDeps :: Config -> SelectDeps
+ Darcs.UI.Flags: setDefault :: Bool -> Config -> SetDefault
+ Darcs.UI.Flags: setScriptsExecutable :: Config -> SetScriptsExecutable
+ Darcs.UI.Flags: showChangesOnlyToFiles :: Config -> Bool
+ Darcs.UI.Flags: siblings :: Config -> [AbsolutePath]
+ Darcs.UI.Flags: testChanges :: Config -> TestChanges
+ Darcs.UI.Flags: toMatchFlags :: Config -> [MatchFlag]
+ Darcs.UI.Flags: umask :: Config -> UMask
+ Darcs.UI.Flags: useCache :: Config -> UseCache
+ Darcs.UI.Flags: useIndex :: Config -> UseIndex
+ Darcs.UI.Flags: usePacks :: Config -> Bool
+ Darcs.UI.Flags: verbosity :: Config -> Verbosity
+ Darcs.UI.Flags: wantGuiPause :: Config -> WantGuiPause
+ Darcs.UI.Flags: willRemoveLogFile :: Config -> Bool
+ Darcs.UI.Flags: withWorkingDir :: Config -> WithWorkingDir
+ Darcs.UI.Flags: workRepo :: Config -> WorkRepo
+ Darcs.UI.Message.Send: aborted :: Doc
+ Darcs.UI.Message.Send: aboutToEdit :: FilePath -> String
+ Darcs.UI.Message.Send: cannotSendToSelf :: String
+ Darcs.UI.Message.Send: charsetAborted :: Doc
+ Darcs.UI.Message.Send: charsetCouldNotGuess :: String
+ Darcs.UI.Message.Send: charsetUtf8MailDiffLocale :: String
+ Darcs.UI.Message.Send: cmdDescription :: String
+ Darcs.UI.Message.Send: cmdHelp :: String
+ Darcs.UI.Message.Send: creatingPatch :: String -> Doc
+ Darcs.UI.Message.Send: currentEncodingIs :: String -> String
+ Darcs.UI.Message.Send: emailBackedUp :: String -> Doc
+ Darcs.UI.Message.Send: noWorkingSendmail :: Doc
+ Darcs.UI.Message.Send: nothingSendable :: Doc
+ Darcs.UI.Message.Send: postingPatch :: String -> Doc
+ Darcs.UI.Message.Send: promptCharSetWarning :: String -> String
+ Darcs.UI.Message.Send: promptNoDescriptionChange :: String
+ Darcs.UI.Message.Send: promptTarget :: String
+ Darcs.UI.Message.Send: savedButNotSent :: String -> Doc
+ Darcs.UI.Message.Send: selectionIs :: [Doc] -> Doc
+ Darcs.UI.Message.Send: selectionIsNull :: Doc
+ Darcs.UI.Message.Send: success :: String -> String -> Doc
+ Darcs.UI.Message.Send: willSendTo :: DryRun -> [String] -> Doc
+ Darcs.UI.Message.Send: wroteBundle :: FilePathLike a => a -> Doc
+ Darcs.UI.Options: optDescr :: AbsolutePath -> DarcsOptDescr f -> OptDescr f
+ Darcs.UI.Options: type DarcsOptDescr = Compose OptDescr ((->) AbsolutePath)
+ Darcs.UI.Options: type DarcsOption = OptSpec DarcsOptDescr Flag
+ Darcs.UI.Options: type PrimDarcsOption v = forall a. PrimOptSpec DarcsOptDescr Flag a v
+ Darcs.UI.Options.All: AutoDeps :: SelectDeps
+ Darcs.UI.Options.All: Backoff :: TestStrategy
+ Darcs.UI.Options.All: Bisect :: TestStrategy
+ Darcs.UI.Options.All: Complement :: RepoCombinator
+ Darcs.UI.Options.All: CompleteClone :: CloneKind
+ Darcs.UI.Options.All: CountPatches :: ChangesFormat
+ Darcs.UI.Options.All: DefaultRemoteDarcs :: RemoteDarcs
+ Darcs.UI.Options.All: Disable :: StdCmdAction
+ Darcs.UI.Options.All: ExactVersion :: RootAction
+ Darcs.UI.Options.All: ExternalDiff :: Maybe String -> [String] -> ExternalDiff
+ Darcs.UI.Options.All: GenContext :: ChangesFormat
+ Darcs.UI.Options.All: GenXml :: ChangesFormat
+ Darcs.UI.Options.All: GzcrcsCheck :: GzcrcsAction
+ Darcs.UI.Options.All: GzcrcsRepair :: GzcrcsAction
+ Darcs.UI.Options.All: GzipCompression :: Compression
+ Darcs.UI.Options.All: HeaderFields :: [String] -> [String] -> Maybe String -> Maybe String -> Maybe String -> HeaderFields
+ Darcs.UI.Options.All: Help :: StdCmdAction
+ Darcs.UI.Options.All: HumanReadable :: ChangesFormat
+ Darcs.UI.Options.All: IgnoreIndex :: UseIndex
+ Darcs.UI.Options.All: Intersection :: RepoCombinator
+ Darcs.UI.Options.All: LazyClone :: CloneKind
+ Darcs.UI.Options.All: Linear :: TestStrategy
+ Darcs.UI.Options.All: ListCommands :: RootAction
+ Darcs.UI.Options.All: ListOptions :: StdCmdAction
+ Darcs.UI.Options.All: Logfile :: Maybe AbsolutePath -> Bool -> Logfile
+ Darcs.UI.Options.All: LookFor :: LookForAdds -> LookForReplaces -> LookForMoves -> LookFor
+ Darcs.UI.Options.All: MyersDiff :: DiffAlgorithm
+ Darcs.UI.Options.All: NetworkOptions :: Bool -> RemoteDarcs -> NetworkOptions
+ Darcs.UI.Options.All: NoAllowConflicts :: AllowConflicts
+ Darcs.UI.Options.All: NoCompression :: Compression
+ Darcs.UI.Options.All: NoContext :: WithContext
+ Darcs.UI.Options.All: NoDeps :: SelectDeps
+ Darcs.UI.Options.All: NoDryRun :: DryRun
+ Darcs.UI.Options.All: NoEditLongComment :: AskLongComment
+ Darcs.UI.Options.All: NoExternalMerge :: ExternalMerge
+ Darcs.UI.Options.All: NoLeaveTestDir :: LeaveTestDir
+ Darcs.UI.Options.All: NoLookForAdds :: LookForAdds
+ Darcs.UI.Options.All: NoLookForMoves :: LookForMoves
+ Darcs.UI.Options.All: NoLookForReplaces :: LookForReplaces
+ Darcs.UI.Options.All: NoPatchIndex :: WithPatchIndex
+ Darcs.UI.Options.All: NoReorder :: Reorder
+ Darcs.UI.Options.All: NoRunTest :: RunTest
+ Darcs.UI.Options.All: NoSetDefault :: Bool -> SetDefault
+ Darcs.UI.Options.All: NoSetScriptsExecutable :: SetScriptsExecutable
+ Darcs.UI.Options.All: NoSign :: Sign
+ Darcs.UI.Options.All: NoSummary :: Summary
+ Darcs.UI.Options.All: NoTestChanges :: TestChanges
+ Darcs.UI.Options.All: NoUMask :: UMask
+ Darcs.UI.Options.All: NoUseCache :: UseCache
+ Darcs.UI.Options.All: NoVerify :: Verify
+ Darcs.UI.Options.All: NoWantGuiPause :: WantGuiPause
+ Darcs.UI.Options.All: NoWorkingDir :: WithWorkingDir
+ Darcs.UI.Options.All: NoXml :: XmlOutput
+ Darcs.UI.Options.All: NormalClone :: CloneKind
+ Darcs.UI.Options.All: NormalVerbosity :: Verbosity
+ Darcs.UI.Options.All: NumberPatches :: ChangesFormat
+ Darcs.UI.Options.All: Once :: TestStrategy
+ Darcs.UI.Options.All: Output :: AbsolutePathOrStd -> Output
+ Darcs.UI.Options.All: OutputAutoName :: AbsolutePath -> Output
+ Darcs.UI.Options.All: PatchFormat1 :: PatchFormat
+ Darcs.UI.Options.All: PatchFormat2 :: PatchFormat
+ Darcs.UI.Options.All: PatienceDiff :: DiffAlgorithm
+ Darcs.UI.Options.All: PromptDeps :: SelectDeps
+ Darcs.UI.Options.All: PromptLongComment :: AskLongComment
+ Darcs.UI.Options.All: Quiet :: Verbosity
+ Darcs.UI.Options.All: RemoteDarcs :: String -> RemoteDarcs
+ Darcs.UI.Options.All: RemoteRepos :: [String] -> RemoteRepos
+ Darcs.UI.Options.All: Reorder :: Reorder
+ Darcs.UI.Options.All: RootHelp :: RootAction
+ Darcs.UI.Options.All: ScanAll :: ScanKnown
+ Darcs.UI.Options.All: ScanBoring :: ScanKnown
+ Darcs.UI.Options.All: ScanKnown :: ScanKnown
+ Darcs.UI.Options.All: Sign :: Sign
+ Darcs.UI.Options.All: SignAs :: String -> Sign
+ Darcs.UI.Options.All: SignSSL :: String -> Sign
+ Darcs.UI.Options.All: Union :: RepoCombinator
+ Darcs.UI.Options.All: UseIndex :: UseIndex
+ Darcs.UI.Options.All: Verbose :: Verbosity
+ Darcs.UI.Options.All: VerifyKeyring :: AbsolutePath -> Verify
+ Darcs.UI.Options.All: VerifySSL :: AbsolutePath -> Verify
+ Darcs.UI.Options.All: Version :: RootAction
+ Darcs.UI.Options.All: WithWorkingDir :: WithWorkingDir
+ Darcs.UI.Options.All: WorkRepoCurrentDir :: WorkRepo
+ Darcs.UI.Options.All: WorkRepoDir :: String -> WorkRepo
+ Darcs.UI.Options.All: WorkRepoPossibleURL :: String -> WorkRepo
+ Darcs.UI.Options.All: YesAllowConflicts :: AllowConflicts
+ Darcs.UI.Options.All: YesAllowConflictsAndMark :: AllowConflicts
+ Darcs.UI.Options.All: YesContext :: WithContext
+ Darcs.UI.Options.All: YesDryRun :: DryRun
+ Darcs.UI.Options.All: YesEditLongComment :: AskLongComment
+ Darcs.UI.Options.All: YesExternalMerge :: String -> ExternalMerge
+ Darcs.UI.Options.All: YesLeaveTestDir :: LeaveTestDir
+ Darcs.UI.Options.All: YesLookForAdds :: LookForAdds
+ Darcs.UI.Options.All: YesLookForMoves :: LookForMoves
+ Darcs.UI.Options.All: YesLookForReplaces :: LookForReplaces
+ Darcs.UI.Options.All: YesPatchIndex :: WithPatchIndex
+ Darcs.UI.Options.All: YesRunTest :: RunTest
+ Darcs.UI.Options.All: YesSetDefault :: Bool -> SetDefault
+ Darcs.UI.Options.All: YesSetScriptsExecutable :: SetScriptsExecutable
+ Darcs.UI.Options.All: YesSummary :: Summary
+ Darcs.UI.Options.All: YesTestChanges :: LeaveTestDir -> TestChanges
+ Darcs.UI.Options.All: YesUMask :: String -> UMask
+ Darcs.UI.Options.All: YesUseCache :: UseCache
+ Darcs.UI.Options.All: YesWantGuiPause :: WantGuiPause
+ Darcs.UI.Options.All: YesXml :: XmlOutput
+ Darcs.UI.Options.All: _cc :: HeaderFields -> [String]
+ Darcs.UI.Options.All: _diffCmd :: ExternalDiff -> Maybe String
+ Darcs.UI.Options.All: _diffOpts :: ExternalDiff -> [String]
+ Darcs.UI.Options.All: _from :: HeaderFields -> Maybe String
+ Darcs.UI.Options.All: _inReplyTo :: HeaderFields -> Maybe String
+ Darcs.UI.Options.All: _logfile :: Logfile -> Maybe AbsolutePath
+ Darcs.UI.Options.All: _rmlogfile :: Logfile -> Bool
+ Darcs.UI.Options.All: _subject :: HeaderFields -> Maybe String
+ Darcs.UI.Options.All: _to :: HeaderFields -> [String]
+ Darcs.UI.Options.All: adds :: LookFor -> LookForAdds
+ Darcs.UI.Options.All: allowCaseDifferingFilenames :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: allowProblematicFilenames :: DarcsOption a (Bool -> Bool -> a)
+ Darcs.UI.Options.All: allowUnrelatedRepos :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: allowWindowsReservedFilenames :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: amendUnrecord :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: anyVerbosity :: DarcsOption a (Bool -> Bool -> Verbosity -> Bool -> a)
+ Darcs.UI.Options.All: applyAs :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: askLongComment :: PrimDarcsOption (Maybe AskLongComment)
+ Darcs.UI.Options.All: askdeps :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: author :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: ccApply :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: changesFormat :: PrimDarcsOption (Maybe ChangesFormat)
+ Darcs.UI.Options.All: changesReverse :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: charset :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: compress :: PrimDarcsOption Compression
+ Darcs.UI.Options.All: conflicts :: AllowConflicts -> PrimDarcsOption (Maybe AllowConflicts)
+ Darcs.UI.Options.All: data AllowConflicts
+ Darcs.UI.Options.All: data AskLongComment
+ Darcs.UI.Options.All: data ChangesFormat
+ Darcs.UI.Options.All: data CloneKind
+ Darcs.UI.Options.All: data Compression
+ Darcs.UI.Options.All: data DiffAlgorithm
+ Darcs.UI.Options.All: data DryRun
+ Darcs.UI.Options.All: data ExternalDiff
+ Darcs.UI.Options.All: data ExternalMerge
+ Darcs.UI.Options.All: data GzcrcsAction
+ Darcs.UI.Options.All: data HeaderFields
+ Darcs.UI.Options.All: data LeaveTestDir
+ Darcs.UI.Options.All: data Logfile
+ Darcs.UI.Options.All: data LookFor
+ Darcs.UI.Options.All: data LookForAdds
+ Darcs.UI.Options.All: data LookForMoves
+ Darcs.UI.Options.All: data LookForReplaces
+ Darcs.UI.Options.All: data NetworkOptions
+ Darcs.UI.Options.All: data Output
+ Darcs.UI.Options.All: data PatchFormat
+ Darcs.UI.Options.All: data RemoteDarcs
+ Darcs.UI.Options.All: data RemoteRepos
+ Darcs.UI.Options.All: data Reorder
+ Darcs.UI.Options.All: data RepoCombinator
+ Darcs.UI.Options.All: data RootAction
+ Darcs.UI.Options.All: data RunTest
+ Darcs.UI.Options.All: data ScanKnown
+ Darcs.UI.Options.All: data SelectDeps
+ Darcs.UI.Options.All: data SetDefault
+ Darcs.UI.Options.All: data SetScriptsExecutable
+ Darcs.UI.Options.All: data Sign
+ Darcs.UI.Options.All: data StdCmdAction
+ Darcs.UI.Options.All: data Summary
+ Darcs.UI.Options.All: data TestChanges
+ Darcs.UI.Options.All: data TestStrategy
+ Darcs.UI.Options.All: data UMask
+ Darcs.UI.Options.All: data UseCache
+ Darcs.UI.Options.All: data UseIndex
+ Darcs.UI.Options.All: data Verbosity
+ Darcs.UI.Options.All: data Verify
+ Darcs.UI.Options.All: data WantGuiPause
+ Darcs.UI.Options.All: data WithContext
+ Darcs.UI.Options.All: data WithPatchIndex
+ Darcs.UI.Options.All: data WithWorkingDir
+ Darcs.UI.Options.All: data WorkRepo
+ Darcs.UI.Options.All: data XmlOutput
+ Darcs.UI.Options.All: debug :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: diffAlgorithm :: PrimDarcsOption DiffAlgorithm
+ Darcs.UI.Options.All: diffing :: PrimDarcsOption (UseIndex, ScanKnown, DiffAlgorithm)
+ Darcs.UI.Options.All: directories :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: distname :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: distzip :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: dryRun :: PrimDarcsOption DryRun
+ Darcs.UI.Options.All: dryRunXml :: DarcsOption a (DryRun -> XmlOutput -> a)
+ Darcs.UI.Options.All: editDescription :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: extDiff :: PrimDarcsOption ExternalDiff
+ Darcs.UI.Options.All: files :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: forceReplace :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: gzcrcsActions :: PrimDarcsOption (Maybe GzcrcsAction)
+ Darcs.UI.Options.All: happyForwarding :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: hashed :: PrimDarcsOption ()
+ Darcs.UI.Options.All: headerFields :: PrimDarcsOption HeaderFields
+ Darcs.UI.Options.All: hooks :: DarcsOption a (Maybe String -> Bool -> Maybe String -> Bool -> a)
+ Darcs.UI.Options.All: humanReadable :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: includeBoring :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: instance Eq AskLongComment
+ Darcs.UI.Options.All: instance Eq ChangesFormat
+ Darcs.UI.Options.All: instance Eq ExternalDiff
+ Darcs.UI.Options.All: instance Eq GzcrcsAction
+ Darcs.UI.Options.All: instance Eq Output
+ Darcs.UI.Options.All: instance Eq PatchFormat
+ Darcs.UI.Options.All: instance Eq RepoCombinator
+ Darcs.UI.Options.All: instance Eq RootAction
+ Darcs.UI.Options.All: instance Eq SelectDeps
+ Darcs.UI.Options.All: instance Eq Sign
+ Darcs.UI.Options.All: instance Eq StdCmdAction
+ Darcs.UI.Options.All: instance Eq Summary
+ Darcs.UI.Options.All: instance Eq TestChanges
+ Darcs.UI.Options.All: instance Eq TestStrategy
+ Darcs.UI.Options.All: instance Eq Verify
+ Darcs.UI.Options.All: instance Eq WithContext
+ Darcs.UI.Options.All: instance Eq XmlOutput
+ Darcs.UI.Options.All: instance Show AskLongComment
+ Darcs.UI.Options.All: instance Show ChangesFormat
+ Darcs.UI.Options.All: instance Show ExternalDiff
+ Darcs.UI.Options.All: instance Show GzcrcsAction
+ Darcs.UI.Options.All: instance Show Output
+ Darcs.UI.Options.All: instance Show PatchFormat
+ Darcs.UI.Options.All: instance Show RepoCombinator
+ Darcs.UI.Options.All: instance Show RootAction
+ Darcs.UI.Options.All: instance Show SelectDeps
+ Darcs.UI.Options.All: instance Show Sign
+ Darcs.UI.Options.All: instance Show StdCmdAction
+ Darcs.UI.Options.All: instance Show Summary
+ Darcs.UI.Options.All: instance Show TestStrategy
+ Darcs.UI.Options.All: instance Show Verify
+ Darcs.UI.Options.All: instance Show WithContext
+ Darcs.UI.Options.All: instance Show XmlOutput
+ Darcs.UI.Options.All: interactive :: PrimDarcsOption (Maybe Bool)
+ Darcs.UI.Options.All: justThisRepo :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: keepDate :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: leaveTestDir :: PrimDarcsOption LeaveTestDir
+ Darcs.UI.Options.All: logfile :: PrimDarcsOption Logfile
+ Darcs.UI.Options.All: lookfor :: PrimDarcsOption LookFor
+ Darcs.UI.Options.All: machineReadable :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: marks :: DarcsOption a (Maybe String -> Maybe String -> a)
+ Darcs.UI.Options.All: matchMaxcount :: PrimDarcsOption (Maybe Int)
+ Darcs.UI.Options.All: minimize :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: moves :: LookFor -> LookForMoves
+ Darcs.UI.Options.All: network :: PrimDarcsOption NetworkOptions
+ Darcs.UI.Options.All: noHttpPipelining :: NetworkOptions -> Bool
+ Darcs.UI.Options.All: notInRemote :: PrimDarcsOption [Maybe String]
+ Darcs.UI.Options.All: notInRemoteFlagName :: String
+ Darcs.UI.Options.All: nullFlag :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: onlyToFiles :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: optimizePatchIndex :: PrimDarcsOption (Maybe WithPatchIndex)
+ Darcs.UI.Options.All: output :: PrimDarcsOption (Maybe Output)
+ Darcs.UI.Options.All: partial :: PrimDarcsOption CloneKind
+ Darcs.UI.Options.All: patchFormat :: PrimDarcsOption PatchFormat
+ Darcs.UI.Options.All: patchIndex :: PrimDarcsOption WithPatchIndex
+ Darcs.UI.Options.All: patchIndexYes :: PrimDarcsOption WithPatchIndex
+ Darcs.UI.Options.All: patchname :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: pauseForGui :: PrimDarcsOption WantGuiPause
+ Darcs.UI.Options.All: pending :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: pipe :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: possiblyRemoteRepo :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: postHook :: DarcsOption a (Maybe String -> Bool -> a)
+ Darcs.UI.Options.All: preHook :: DarcsOption a (Maybe String -> Bool -> a)
+ Darcs.UI.Options.All: readMarks :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: recursive :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: remoteDarcs :: NetworkOptions -> RemoteDarcs
+ Darcs.UI.Options.All: remoteRepos :: PrimDarcsOption RemoteRepos
+ Darcs.UI.Options.All: reorder :: PrimDarcsOption Reorder
+ Darcs.UI.Options.All: reorderPatches :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: replaces :: LookFor -> LookForReplaces
+ Darcs.UI.Options.All: reply :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: repoCombinator :: PrimDarcsOption RepoCombinator
+ Darcs.UI.Options.All: reponame :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: restrictPaths :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: rootActions :: PrimDarcsOption (Maybe RootAction)
+ Darcs.UI.Options.All: selectAuthor :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: selectDeps :: PrimDarcsOption SelectDeps
+ Darcs.UI.Options.All: sendToContext :: PrimDarcsOption (Maybe AbsolutePath)
+ Darcs.UI.Options.All: sendmail :: PrimDarcsOption (Bool, Maybe String)
+ Darcs.UI.Options.All: sendmailCmd :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: setDefault :: PrimDarcsOption (Maybe Bool)
+ Darcs.UI.Options.All: setScriptsExecutable :: PrimDarcsOption SetScriptsExecutable
+ Darcs.UI.Options.All: siblings :: PrimDarcsOption [AbsolutePath]
+ Darcs.UI.Options.All: sign :: PrimDarcsOption Sign
+ Darcs.UI.Options.All: stdCmdActions :: PrimDarcsOption (Maybe StdCmdAction)
+ Darcs.UI.Options.All: storeInMemory :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: summary :: PrimDarcsOption (Maybe Summary)
+ Darcs.UI.Options.All: test :: PrimDarcsOption RunTest
+ Darcs.UI.Options.All: testChanges :: PrimDarcsOption TestChanges
+ Darcs.UI.Options.All: testStrategy :: PrimDarcsOption TestStrategy
+ Darcs.UI.Options.All: timings :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: tokens :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: type DarcsOption = OptSpec DarcsOptDescr Flag
+ Darcs.UI.Options.All: umask :: PrimDarcsOption UMask
+ Darcs.UI.Options.All: unidiff :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: useCache :: PrimDarcsOption UseCache
+ Darcs.UI.Options.All: useExternalMerge :: PrimDarcsOption ExternalMerge
+ Darcs.UI.Options.All: useIndex :: PrimDarcsOption UseIndex
+ Darcs.UI.Options.All: usePacks :: PrimDarcsOption Bool
+ Darcs.UI.Options.All: useWorkingDir :: PrimDarcsOption WithWorkingDir
+ Darcs.UI.Options.All: verbosity :: PrimDarcsOption Verbosity
+ Darcs.UI.Options.All: verify :: PrimDarcsOption Verify
+ Darcs.UI.Options.All: withContext :: PrimDarcsOption WithContext
+ Darcs.UI.Options.All: workRepo :: PrimDarcsOption WorkRepo
+ Darcs.UI.Options.All: workingRepoDir :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: writeMarks :: PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.All: xmloutput :: PrimDarcsOption XmlOutput
+ Darcs.UI.Options.Core: (^) :: OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
+ Darcs.UI.Options.Core: OptSpec :: (([f] -> a) -> b) -> (b -> ([f] -> a)) -> ([f] -> [String]) -> [d f] -> OptSpec d f a b
+ Darcs.UI.Options.Core: data OptSpec d f a b
+ Darcs.UI.Options.Core: defaultFlags :: OptSpec d f [f] b -> [f]
+ Darcs.UI.Options.Core: instance IsoFunctor (OptSpec d f a)
+ Darcs.UI.Options.Core: instance Monoid (PrimOptSpec d f a [v])
+ Darcs.UI.Options.Core: oappend :: PrimOptSpec d f a [v] -> PrimOptSpec d f a [v] -> PrimOptSpec d f a [v]
+ Darcs.UI.Options.Core: ocheck :: OptSpec d f a b -> [f] -> [String]
+ Darcs.UI.Options.Core: odesc :: OptSpec d f a b -> [d f]
+ Darcs.UI.Options.Core: oempty :: PrimOptSpec d f a [v]
+ Darcs.UI.Options.Core: oid :: OptSpec d f a a
+ Darcs.UI.Options.Core: oimap :: Iso b c -> OptSpec d f a b -> OptSpec d f a c
+ Darcs.UI.Options.Core: onormalise :: OptSpec d f [f] b -> [f] -> [f]
+ Darcs.UI.Options.Core: oparse :: OptSpec d f a b -> b -> ([f] -> a)
+ Darcs.UI.Options.Core: ounparse :: OptSpec d f a b -> ([f] -> a) -> b
+ Darcs.UI.Options.Core: parseFlags :: (forall a. PrimOptSpec d f a v) -> [f] -> v
+ Darcs.UI.Options.Core: type PrimOptSpec d f a v = OptSpec d f a (v -> a)
+ Darcs.UI.Options.Flags: AfterHash :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: AfterPatch :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: AfterPattern :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: AfterTag :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: All :: DarcsFlag
+ Darcs.UI.Options.Flags: AllowCaseOnly :: DarcsFlag
+ Darcs.UI.Options.Flags: AllowConflicts :: DarcsFlag
+ Darcs.UI.Options.Flags: AllowUnrelatedRepos :: DarcsFlag
+ Darcs.UI.Options.Flags: AllowWindowsReserved :: DarcsFlag
+ Darcs.UI.Options.Flags: AmendUnrecord :: DarcsFlag
+ Darcs.UI.Options.Flags: ApplyAs :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: ApplyOnDisk :: DarcsFlag
+ Darcs.UI.Options.Flags: AskDeps :: DarcsFlag
+ Darcs.UI.Options.Flags: AskPosthook :: DarcsFlag
+ Darcs.UI.Options.Flags: AskPrehook :: DarcsFlag
+ Darcs.UI.Options.Flags: Author :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: Backoff :: DarcsFlag
+ Darcs.UI.Options.Flags: Bisect :: DarcsFlag
+ Darcs.UI.Options.Flags: Boring :: DarcsFlag
+ Darcs.UI.Options.Flags: Cc :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: ChangesToAllFiles :: DarcsFlag
+ Darcs.UI.Options.Flags: Charset :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: Check :: DarcsFlag
+ Darcs.UI.Options.Flags: Complement :: DarcsFlag
+ Darcs.UI.Options.Flags: Complete :: DarcsFlag
+ Darcs.UI.Options.Flags: Compress :: DarcsFlag
+ Darcs.UI.Options.Flags: Context :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Options.Flags: Count :: DarcsFlag
+ Darcs.UI.Options.Flags: Debug :: DarcsFlag
+ Darcs.UI.Options.Flags: DebugHTTP :: DarcsFlag
+ Darcs.UI.Options.Flags: DiffCmd :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: DiffFlags :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: Directories :: DarcsFlag
+ Darcs.UI.Options.Flags: Disable :: DarcsFlag
+ Darcs.UI.Options.Flags: DistName :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: DistZip :: DarcsFlag
+ Darcs.UI.Options.Flags: DontAllowCaseOnly :: DarcsFlag
+ Darcs.UI.Options.Flags: DontAllowWindowsReserved :: DarcsFlag
+ Darcs.UI.Options.Flags: DontGrabDeps :: DarcsFlag
+ Darcs.UI.Options.Flags: DontIgnoreTimes :: DarcsFlag
+ Darcs.UI.Options.Flags: DontPromptForDependencies :: DarcsFlag
+ Darcs.UI.Options.Flags: DontRestrictPaths :: DarcsFlag
+ Darcs.UI.Options.Flags: DontRmLogFile :: DarcsFlag
+ Darcs.UI.Options.Flags: DontSetScriptsExecutable :: DarcsFlag
+ Darcs.UI.Options.Flags: DryRun :: DarcsFlag
+ Darcs.UI.Options.Flags: EditDescription :: DarcsFlag
+ Darcs.UI.Options.Flags: EditLongComment :: DarcsFlag
+ Darcs.UI.Options.Flags: ExactVersion :: DarcsFlag
+ Darcs.UI.Options.Flags: ExternalMerge :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: Files :: DarcsFlag
+ Darcs.UI.Options.Flags: ForceReplace :: DarcsFlag
+ Darcs.UI.Options.Flags: Forward :: DarcsFlag
+ Darcs.UI.Options.Flags: GenContext :: DarcsFlag
+ Darcs.UI.Options.Flags: HappyForwarding :: DarcsFlag
+ Darcs.UI.Options.Flags: Hashed :: DarcsFlag
+ Darcs.UI.Options.Flags: Help :: DarcsFlag
+ Darcs.UI.Options.Flags: HumanReadable :: DarcsFlag
+ Darcs.UI.Options.Flags: IgnoreTimes :: DarcsFlag
+ Darcs.UI.Options.Flags: InReplyTo :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: Interactive :: DarcsFlag
+ Darcs.UI.Options.Flags: Intersection :: DarcsFlag
+ Darcs.UI.Options.Flags: JustThisRepo :: DarcsFlag
+ Darcs.UI.Options.Flags: KeepDate :: DarcsFlag
+ Darcs.UI.Options.Flags: LastN :: Int -> DarcsFlag
+ Darcs.UI.Options.Flags: Lazy :: DarcsFlag
+ Darcs.UI.Options.Flags: LeaveTestDir :: DarcsFlag
+ Darcs.UI.Options.Flags: Linear :: DarcsFlag
+ Darcs.UI.Options.Flags: ListCommands :: DarcsFlag
+ Darcs.UI.Options.Flags: ListOptions :: DarcsFlag
+ Darcs.UI.Options.Flags: LogFile :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Options.Flags: LookForAdds :: DarcsFlag
+ Darcs.UI.Options.Flags: LookForMoves :: DarcsFlag
+ Darcs.UI.Options.Flags: LookForReplaces :: DarcsFlag
+ Darcs.UI.Options.Flags: MachineReadable :: DarcsFlag
+ Darcs.UI.Options.Flags: Mail :: DarcsFlag
+ Darcs.UI.Options.Flags: MarkConflicts :: DarcsFlag
+ Darcs.UI.Options.Flags: MaxCount :: Int -> DarcsFlag
+ Darcs.UI.Options.Flags: Minimize :: DarcsFlag
+ Darcs.UI.Options.Flags: NewRepo :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: NoAllowConflicts :: DarcsFlag
+ Darcs.UI.Options.Flags: NoAmendUnrecord :: DarcsFlag
+ Darcs.UI.Options.Flags: NoAskDeps :: DarcsFlag
+ Darcs.UI.Options.Flags: NoCache :: DarcsFlag
+ Darcs.UI.Options.Flags: NoCompress :: DarcsFlag
+ Darcs.UI.Options.Flags: NoDirectories :: DarcsFlag
+ Darcs.UI.Options.Flags: NoEditDescription :: DarcsFlag
+ Darcs.UI.Options.Flags: NoEditLongComment :: DarcsFlag
+ Darcs.UI.Options.Flags: NoFiles :: DarcsFlag
+ Darcs.UI.Options.Flags: NoHTTPPipelining :: DarcsFlag
+ Darcs.UI.Options.Flags: NoHappyForwarding :: DarcsFlag
+ Darcs.UI.Options.Flags: NoKeepDate :: DarcsFlag
+ Darcs.UI.Options.Flags: NoLeaveTestDir :: DarcsFlag
+ Darcs.UI.Options.Flags: NoLookForAdds :: DarcsFlag
+ Darcs.UI.Options.Flags: NoLookForMoves :: DarcsFlag
+ Darcs.UI.Options.Flags: NoLookForReplaces :: DarcsFlag
+ Darcs.UI.Options.Flags: NoMinimize :: DarcsFlag
+ Darcs.UI.Options.Flags: NoPacks :: DarcsFlag
+ Darcs.UI.Options.Flags: NoPatchIndexFlag :: DarcsFlag
+ Darcs.UI.Options.Flags: NoPauseForGui :: DarcsFlag
+ Darcs.UI.Options.Flags: NoPending :: DarcsFlag
+ Darcs.UI.Options.Flags: NoPosthook :: DarcsFlag
+ Darcs.UI.Options.Flags: NoPrehook :: DarcsFlag
+ Darcs.UI.Options.Flags: NoRecursive :: DarcsFlag
+ Darcs.UI.Options.Flags: NoReorder :: DarcsFlag
+ Darcs.UI.Options.Flags: NoSetDefault :: DarcsFlag
+ Darcs.UI.Options.Flags: NoSign :: DarcsFlag
+ Darcs.UI.Options.Flags: NoSummary :: DarcsFlag
+ Darcs.UI.Options.Flags: NoTest :: DarcsFlag
+ Darcs.UI.Options.Flags: NonApply :: DarcsFlag
+ Darcs.UI.Options.Flags: NonForce :: DarcsFlag
+ Darcs.UI.Options.Flags: NonUnified :: DarcsFlag
+ Darcs.UI.Options.Flags: NonVerify :: DarcsFlag
+ Darcs.UI.Options.Flags: NormalVerbosity :: DarcsFlag
+ Darcs.UI.Options.Flags: NotInRemote :: (Maybe String) -> DarcsFlag
+ Darcs.UI.Options.Flags: NullFlag :: DarcsFlag
+ Darcs.UI.Options.Flags: NumberPatches :: DarcsFlag
+ Darcs.UI.Options.Flags: Once :: DarcsFlag
+ Darcs.UI.Options.Flags: OneHash :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: OnePatch :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: OnePattern :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: OneTag :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: OnlyChangesToFiles :: DarcsFlag
+ Darcs.UI.Options.Flags: Output :: AbsolutePathOrStd -> DarcsFlag
+ Darcs.UI.Options.Flags: OutputAutoName :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Options.Flags: Packs :: DarcsFlag
+ Darcs.UI.Options.Flags: PatchIndexFlag :: DarcsFlag
+ Darcs.UI.Options.Flags: PatchIndexRange :: Int -> Int -> DarcsFlag
+ Darcs.UI.Options.Flags: PatchName :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: PauseForGui :: DarcsFlag
+ Darcs.UI.Options.Flags: Pending :: DarcsFlag
+ Darcs.UI.Options.Flags: Pipe :: DarcsFlag
+ Darcs.UI.Options.Flags: PosthookCmd :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: PrehookCmd :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: PromptForDependencies :: DarcsFlag
+ Darcs.UI.Options.Flags: PromptLongComment :: DarcsFlag
+ Darcs.UI.Options.Flags: Quiet :: DarcsFlag
+ Darcs.UI.Options.Flags: ReadMarks :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: Recursive :: DarcsFlag
+ Darcs.UI.Options.Flags: RemoteDarcsOpt :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: RemoteRepo :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: Reorder :: DarcsFlag
+ Darcs.UI.Options.Flags: Repair :: DarcsFlag
+ Darcs.UI.Options.Flags: Reply :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: RestrictPaths :: DarcsFlag
+ Darcs.UI.Options.Flags: Reverse :: DarcsFlag
+ Darcs.UI.Options.Flags: RmLogFile :: DarcsFlag
+ Darcs.UI.Options.Flags: RunPosthook :: DarcsFlag
+ Darcs.UI.Options.Flags: RunPrehook :: DarcsFlag
+ Darcs.UI.Options.Flags: SelectAuthor :: DarcsFlag
+ Darcs.UI.Options.Flags: SendmailCmd :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: SetDefault :: DarcsFlag
+ Darcs.UI.Options.Flags: SetScriptsExecutable :: DarcsFlag
+ Darcs.UI.Options.Flags: SeveralPatch :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: SeveralPattern :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: Sibling :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Options.Flags: Sign :: DarcsFlag
+ Darcs.UI.Options.Flags: SignAs :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: SignSSL :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: SkipBoring :: DarcsFlag
+ Darcs.UI.Options.Flags: SkipConflicts :: DarcsFlag
+ Darcs.UI.Options.Flags: StoreInMemory :: DarcsFlag
+ Darcs.UI.Options.Flags: Subject :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: Summary :: DarcsFlag
+ Darcs.UI.Options.Flags: TagName :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: Target :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: Test :: DarcsFlag
+ Darcs.UI.Options.Flags: Timings :: DarcsFlag
+ Darcs.UI.Options.Flags: Toks :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: UMask :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: UnCompress :: DarcsFlag
+ Darcs.UI.Options.Flags: Unified :: DarcsFlag
+ Darcs.UI.Options.Flags: Union :: DarcsFlag
+ Darcs.UI.Options.Flags: UpToHash :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: UpToPatch :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: UpToPattern :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: UpToTag :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: UseFormat1 :: DarcsFlag
+ Darcs.UI.Options.Flags: UseFormat2 :: DarcsFlag
+ Darcs.UI.Options.Flags: UseMyersDiff :: DarcsFlag
+ Darcs.UI.Options.Flags: UseNoWorkingDir :: DarcsFlag
+ Darcs.UI.Options.Flags: UsePatienceDiff :: DarcsFlag
+ Darcs.UI.Options.Flags: UseWorkingDir :: DarcsFlag
+ Darcs.UI.Options.Flags: Verbose :: DarcsFlag
+ Darcs.UI.Options.Flags: Verify :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Options.Flags: VerifySSL :: AbsolutePath -> DarcsFlag
+ Darcs.UI.Options.Flags: Version :: DarcsFlag
+ Darcs.UI.Options.Flags: WorkRepoDir :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: WorkRepoUrl :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: WriteMarks :: String -> DarcsFlag
+ Darcs.UI.Options.Flags: XMLOutput :: DarcsFlag
+ Darcs.UI.Options.Flags: data DarcsFlag
+ Darcs.UI.Options.Flags: instance Eq DarcsFlag
+ Darcs.UI.Options.Flags: instance Show DarcsFlag
+ Darcs.UI.Options.Iso: Iso :: (a -> b) -> (b -> a) -> Iso a b
+ Darcs.UI.Options.Iso: class IsoFunctor f
+ Darcs.UI.Options.Iso: cps :: Iso a b -> Iso (a -> c) (b -> c)
+ Darcs.UI.Options.Iso: data Iso a b
+ Darcs.UI.Options.Iso: imap :: IsoFunctor f => Iso a b -> f a -> f b
+ Darcs.UI.Options.Iso: under :: Functor f => Iso a b -> Iso (f a) (f b)
+ Darcs.UI.Options.Markdown: optionsMarkdown :: [DarcsOptDescr f] -> String
+ Darcs.UI.Options.Matching: AfterHash :: String -> MatchFlag
+ Darcs.UI.Options.Matching: AfterPatch :: String -> MatchFlag
+ Darcs.UI.Options.Matching: AfterPattern :: String -> MatchFlag
+ Darcs.UI.Options.Matching: AfterTag :: String -> MatchFlag
+ Darcs.UI.Options.Matching: Context :: AbsolutePath -> MatchFlag
+ Darcs.UI.Options.Matching: LastN :: Int -> MatchFlag
+ Darcs.UI.Options.Matching: OneHash :: String -> MatchFlag
+ Darcs.UI.Options.Matching: OnePatch :: String -> MatchFlag
+ Darcs.UI.Options.Matching: OnePattern :: String -> MatchFlag
+ Darcs.UI.Options.Matching: OneTag :: String -> MatchFlag
+ Darcs.UI.Options.Matching: PatchIndexRange :: Int -> Int -> MatchFlag
+ Darcs.UI.Options.Matching: SeveralPatch :: String -> MatchFlag
+ Darcs.UI.Options.Matching: SeveralPattern :: String -> MatchFlag
+ Darcs.UI.Options.Matching: UpToHash :: String -> MatchFlag
+ Darcs.UI.Options.Matching: UpToPatch :: String -> MatchFlag
+ Darcs.UI.Options.Matching: UpToPattern :: String -> MatchFlag
+ Darcs.UI.Options.Matching: UpToTag :: String -> MatchFlag
+ Darcs.UI.Options.Matching: context :: MatchOption
+ Darcs.UI.Options.Matching: data MatchFlag
+ Darcs.UI.Options.Matching: matchAny :: MatchOption
+ Darcs.UI.Options.Matching: matchOne :: MatchOption
+ Darcs.UI.Options.Matching: matchOneContext :: MatchOption
+ Darcs.UI.Options.Matching: matchOneNontag :: MatchOption
+ Darcs.UI.Options.Matching: matchRange :: MatchOption
+ Darcs.UI.Options.Matching: matchSeveral :: MatchOption
+ Darcs.UI.Options.Matching: matchSeveralOrFirst :: MatchOption
+ Darcs.UI.Options.Matching: matchSeveralOrLast :: MatchOption
+ Darcs.UI.Options.Matching: matchSeveralOrRange :: MatchOption
+ Darcs.UI.Options.Util: RawAbsPathArg :: [Char] -> [String] -> (AbsolutePath -> f) -> (f -> [AbsolutePath]) -> (AbsolutePath -> v) -> (v -> [AbsolutePath]) -> String -> String -> RawOptSpec f v
+ Darcs.UI.Options.Util: RawAbsPathOrStdArg :: [Char] -> [String] -> (AbsolutePathOrStd -> f) -> (f -> [AbsolutePathOrStd]) -> (AbsolutePathOrStd -> v) -> (v -> [AbsolutePathOrStd]) -> String -> String -> RawOptSpec f v
+ Darcs.UI.Options.Util: RawNoArg :: [Char] -> [String] -> f -> v -> String -> RawOptSpec f v
+ Darcs.UI.Options.Util: RawOptAbsPathArg :: [Char] -> [String] -> (AbsolutePath -> f) -> (f -> [AbsolutePath]) -> (AbsolutePath -> v) -> (v -> [AbsolutePath]) -> String -> String -> String -> RawOptSpec f v
+ Darcs.UI.Options.Util: RawStrArg :: [Char] -> [String] -> (String -> f) -> (f -> [String]) -> (String -> v) -> (v -> [String]) -> String -> String -> RawOptSpec f v
+ Darcs.UI.Options.Util: absPathArg :: SingleArgOptDescr AbsolutePath f
+ Darcs.UI.Options.Util: absPathOrStdArg :: SingleArgOptDescr AbsolutePathOrStd f
+ Darcs.UI.Options.Util: data AbsolutePath
+ Darcs.UI.Options.Util: data AbsolutePathOrStd
+ Darcs.UI.Options.Util: data RawOptSpec f v
+ Darcs.UI.Options.Util: deprecated :: [String] -> [RawOptSpec Flag v] -> PrimDarcsOption ()
+ Darcs.UI.Options.Util: instance IsoFunctor (RawOptSpec f)
+ Darcs.UI.Options.Util: makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath
+ Darcs.UI.Options.Util: makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd
+ Darcs.UI.Options.Util: multiAbsPathArg :: [Char] -> [String] -> (AbsolutePath -> Flag) -> ([Flag] -> [AbsolutePath]) -> String -> String -> PrimDarcsOption [AbsolutePath]
+ Darcs.UI.Options.Util: multiOptStrArg :: [Char] -> [String] -> (Maybe String -> Flag) -> ([Flag] -> [Maybe String]) -> String -> String -> PrimDarcsOption [Maybe String]
+ Darcs.UI.Options.Util: multiStrArg :: [Char] -> [String] -> (String -> Flag) -> ([Flag] -> [String]) -> String -> String -> PrimDarcsOption [String]
+ Darcs.UI.Options.Util: noArg :: [Char] -> [String] -> f -> String -> DarcsOptDescr f
+ Darcs.UI.Options.Util: optAbsPathArg :: [Char] -> [String] -> String -> (AbsolutePath -> f) -> String -> String -> DarcsOptDescr f
+ Darcs.UI.Options.Util: optStrArg :: SingleArgOptDescr (Maybe String) f
+ Darcs.UI.Options.Util: singleAbsPathArg :: [Char] -> [String] -> (AbsolutePath -> Flag) -> (Flag -> Maybe AbsolutePath) -> String -> String -> PrimDarcsOption (Maybe AbsolutePath)
+ Darcs.UI.Options.Util: singleNoArg :: [Char] -> [String] -> Flag -> String -> PrimDarcsOption Bool
+ Darcs.UI.Options.Util: singleStrArg :: [Char] -> [String] -> (String -> Flag) -> (Flag -> Maybe String) -> String -> String -> PrimDarcsOption (Maybe String)
+ Darcs.UI.Options.Util: strArg :: SingleArgOptDescr String f
+ Darcs.UI.Options.Util: type DarcsOptDescr = Compose OptDescr ((->) AbsolutePath)
+ Darcs.UI.Options.Util: type Flag = DarcsFlag
+ Darcs.UI.Options.Util: type PrimDarcsOption v = forall a. PrimOptSpec DarcsOptDescr Flag a v
+ Darcs.UI.Options.Util: withDefault :: Eq v => v -> [RawOptSpec Flag v] -> PrimDarcsOption v
+ Darcs.UI.PrintPatch: contextualPrintPatch :: (ShowPatch p, ApplyState p ~ Tree) => Tree IO -> p wX wY -> IO ()
+ Darcs.UI.PrintPatch: printFriendly :: (ShowPatch p, ApplyState p ~ Tree) => Maybe (Tree IO) -> Verbosity -> Summary -> WithContext -> p wX wY -> IO ()
+ Darcs.UI.PrintPatch: printPatch :: ShowPatch p => p wX wY -> IO ()
+ Darcs.UI.PrintPatch: printPatchPager :: ShowPatch p => p wX wY -> IO ()
+ Darcs.UI.PrintPatch: showFriendly :: ShowPatch p => Verbosity -> Summary -> p wX wY -> Doc
+ Darcs.UI.RemoteApply: remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode
+ Darcs.UI.RunCommand: runTheCommand :: [CommandControl] -> String -> [String] -> IO ()
+ Darcs.UI.SelectChanges: First :: WhichChanges
+ Darcs.UI.SelectChanges: FirstReversed :: WhichChanges
+ Darcs.UI.SelectChanges: ISC :: Int -> Int -> FZipper (LabelledPatch p) wX wY -> PatchChoices p wX wY -> InteractiveSelectionContext p wX wY
+ Darcs.UI.SelectChanges: KeyPress :: Char -> String -> KeyPress
+ Darcs.UI.SelectChanges: Last :: WhichChanges
+ Darcs.UI.SelectChanges: LastReversed :: WhichChanges
+ Darcs.UI.SelectChanges: PatchSelectionOptions :: Verbosity -> [MatchFlag] -> DiffAlgorithm -> Bool -> SelectDeps -> Summary -> WithContext -> PatchSelectionOptions
+ Darcs.UI.SelectChanges: askAboutDepends :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> FL (PrimOf p) wT wY -> PatchSelectionOptions -> [PatchInfo] -> IO [PatchInfo]
+ Darcs.UI.SelectChanges: backAll :: Patchy p => InteractiveSelectionM p wX wY ()
+ Darcs.UI.SelectChanges: backOne :: Patchy p => InteractiveSelectionM p wX wY ()
+ Darcs.UI.SelectChanges: choices :: InteractiveSelectionContext p wX wY -> PatchChoices p wX wY
+ Darcs.UI.SelectChanges: current :: InteractiveSelectionContext p wX wY -> Int
+ Darcs.UI.SelectChanges: currentFile :: (Patchy p, PatchInspect p) => InteractiveSelectionM p wX wY (Maybe FilePath)
+ Darcs.UI.SelectChanges: currentPatch :: Patchy p => InteractiveSelectionM p wX wY (Maybe (Sealed2 (LabelledPatch p)))
+ Darcs.UI.SelectChanges: data InteractiveSelectionContext p wX wY
+ Darcs.UI.SelectChanges: data KeyPress
+ Darcs.UI.SelectChanges: data PatchSelectionContext p
+ Darcs.UI.SelectChanges: data PatchSelectionOptions
+ Darcs.UI.SelectChanges: data WhichChanges
+ Darcs.UI.SelectChanges: decide :: Patchy p => Bool -> LabelledPatch p wT wU -> InteractiveSelectionM p wX wY ()
+ Darcs.UI.SelectChanges: decideWholeFile :: (Patchy p, PatchInspect p) => FilePath -> Bool -> InteractiveSelectionM p wX wY ()
+ Darcs.UI.SelectChanges: diffAlgorithm :: PatchSelectionOptions -> DiffAlgorithm
+ Darcs.UI.SelectChanges: helpFor :: String -> [[KeyPress]] -> [[KeyPress]] -> String
+ Darcs.UI.SelectChanges: instance Eq WhichChanges
+ Darcs.UI.SelectChanges: instance Show WhichChanges
+ Darcs.UI.SelectChanges: interactive :: PatchSelectionOptions -> Bool
+ Darcs.UI.SelectChanges: isSingleFile :: PatchInspect p => p wX wY -> Bool
+ Darcs.UI.SelectChanges: keysFor :: [[KeyPress]] -> [Char]
+ Darcs.UI.SelectChanges: kp :: KeyPress -> Char
+ Darcs.UI.SelectChanges: kpHelp :: KeyPress -> String
+ Darcs.UI.SelectChanges: lps :: InteractiveSelectionContext p wX wY -> FZipper (LabelledPatch p) wX wY
+ Darcs.UI.SelectChanges: matchFlags :: PatchSelectionOptions -> [MatchFlag]
+ Darcs.UI.SelectChanges: printSummary :: ShowPatch p => p wX wY -> IO ()
+ Darcs.UI.SelectChanges: prompt :: (Patchy p, ShowPatch p) => InteractiveSelectionM p wX wY String
+ Darcs.UI.SelectChanges: promptUser :: (Patchy p, ShowPatch p) => Bool -> Char -> InteractiveSelectionM p wX wY Char
+ Darcs.UI.SelectChanges: runSelection :: Patchy p => PatchSelection p wX wY -> PatchSelectionContext p -> IO ((FL p :> FL p) wX wY)
+ Darcs.UI.SelectChanges: selectChanges :: (Patchy p, PatchInspect p, ShowPatch p, ApplyState p ~ Tree) => FL p wX wY -> PatchSelection p wX wY
+ Darcs.UI.SelectChanges: selectDeps :: PatchSelectionOptions -> SelectDeps
+ Darcs.UI.SelectChanges: selectionContext :: RepoPatch p => WhichChanges -> String -> PatchSelectionOptions -> Maybe (Splitter (PatchInfoAnd p)) -> Maybe [FilePath] -> PatchSelectionContext (PatchInfoAnd p)
+ Darcs.UI.SelectChanges: selectionContextGeneric :: (RepoPatch p, Invert q) => (forall wX wY. q wX wY -> Sealed2 (Named p)) -> WhichChanges -> String -> PatchSelectionOptions -> Maybe [FilePath] -> PatchSelectionContext q
+ Darcs.UI.SelectChanges: selectionContextPrim :: PrimPatch prim => WhichChanges -> String -> PatchSelectionOptions -> Maybe (Splitter prim) -> Maybe [FilePath] -> Maybe (Tree IO) -> PatchSelectionContext prim
+ Darcs.UI.SelectChanges: showCur :: (Patchy p, ShowPatch p, ApplyState p ~ Tree) => InteractiveSelectionM p wX wY ()
+ Darcs.UI.SelectChanges: skipMundane :: (Patchy p, ShowPatch p) => InteractiveSelectionM p wX wY ()
+ Darcs.UI.SelectChanges: skipOne :: Patchy p => InteractiveSelectionM p wX wY ()
+ Darcs.UI.SelectChanges: summary :: PatchSelectionOptions -> Summary
+ Darcs.UI.SelectChanges: total :: InteractiveSelectionContext p wX wY -> Int
+ Darcs.UI.SelectChanges: type InteractiveSelectionM p wX wY a = StateT (InteractiveSelectionContext p wX wY) (PatchSelectionM p IO) a
+ Darcs.UI.SelectChanges: verbosity :: PatchSelectionOptions -> Verbosity
+ Darcs.UI.SelectChanges: viewChanges :: (Patchy p, ShowPatch p, ApplyState p ~ Tree) => PatchSelectionOptions -> [Sealed2 p] -> IO ()
+ Darcs.UI.SelectChanges: withContext :: PatchSelectionOptions -> WithContext
+ Darcs.UI.SelectChanges: withSelectedPatchFromRepo :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p wR wU wT -> PatchSelectionOptions -> (forall wA. (FL (PatchInfoAnd p) :> PatchInfoAnd p) wA wR -> IO ()) -> IO ()
+ Darcs.UI.TheCommands: commandControlList :: [CommandControl]
+ Darcs.UI.Usage: usageInfo :: String -> [DarcsOptDescr a] -> String
+ Darcs.Util.AtExit: atexit :: IO () -> IO ()
+ Darcs.Util.AtExit: withAtexit :: IO a -> IO a
+ Darcs.Util.Bug: _bug :: BugStuff -> String -> a
+ Darcs.Util.Bug: _bugDoc :: BugStuff -> Doc -> a
+ Darcs.Util.Bug: _fromJust :: BugStuff -> Maybe a -> a
+ Darcs.Util.Bug: _impossible :: BugStuff -> a
+ Darcs.Util.ByteString: betweenLinesPS :: ByteString -> ByteString -> ByteString -> Maybe ByteString
+ Darcs.Util.ByteString: breakAfterNthNewline :: Int -> ByteString -> Maybe (ByteString, ByteString)
+ Darcs.Util.ByteString: breakBeforeNthNewline :: Int -> ByteString -> (ByteString, ByteString)
+ Darcs.Util.ByteString: breakFirstPS :: Char -> ByteString -> Maybe (ByteString, ByteString)
+ Darcs.Util.ByteString: breakLastPS :: Char -> ByteString -> Maybe (ByteString, ByteString)
+ Darcs.Util.ByteString: breakSpace :: ByteString -> (ByteString, ByteString)
+ Darcs.Util.ByteString: decodeLocale :: ByteString -> String
+ Darcs.Util.ByteString: decodeString :: String -> IO String
+ Darcs.Util.ByteString: dropSpace :: ByteString -> ByteString
+ Darcs.Util.ByteString: encodeLocale :: String -> ByteString
+ Darcs.Util.ByteString: fromHex2PS :: ByteString -> ByteString
+ Darcs.Util.ByteString: fromPS2Hex :: ByteString -> ByteString
+ Darcs.Util.ByteString: gzDecompress :: Maybe Int -> ByteString -> ([ByteString], Bool)
+ Darcs.Util.ByteString: gzReadFilePS :: FilePath -> IO ByteString
+ Darcs.Util.ByteString: gzReadStdin :: IO ByteString
+ Darcs.Util.ByteString: gzWriteFilePS :: FilePath -> ByteString -> IO ()
+ Darcs.Util.ByteString: gzWriteFilePSs :: FilePath -> [ByteString] -> IO ()
+ Darcs.Util.ByteString: gzWriteHandle :: Handle -> [ByteString] -> IO ()
+ Darcs.Util.ByteString: hashPS :: ByteString -> Int32
+ Darcs.Util.ByteString: intercalate :: ByteString -> [ByteString] -> ByteString
+ Darcs.Util.ByteString: isAscii :: ByteString -> Bool
+ Darcs.Util.ByteString: isFunky :: ByteString -> Bool
+ Darcs.Util.ByteString: isGZFile :: FilePath -> IO (Maybe Int)
+ Darcs.Util.ByteString: linesPS :: ByteString -> [ByteString]
+ Darcs.Util.ByteString: mmapFilePS :: FilePath -> IO ByteString
+ Darcs.Util.ByteString: packStringToUTF8 :: String -> ByteString
+ Darcs.Util.ByteString: readIntPS :: ByteString -> Maybe (Int, ByteString)
+ Darcs.Util.ByteString: substrPS :: ByteString -> ByteString -> Maybe Int
+ Darcs.Util.ByteString: unlinesPS :: [ByteString] -> ByteString
+ Darcs.Util.ByteString: unpackPSFromUTF8 :: ByteString -> String
+ Darcs.Util.ByteString: unsafeWithInternals :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a
+ Darcs.Util.CommandLine: addUrlencoded :: FTable -> FTable
+ Darcs.Util.CommandLine: parseCmd :: FTable -> String -> Either ParseError ([String], Bool)
+ Darcs.Util.Crypt.SHA1: SHA1 :: !Word32 -> !Word32 -> !Word32 -> !Word32 -> !Word32 -> SHA1
+ Darcs.Util.Crypt.SHA1: data SHA1
+ Darcs.Util.Crypt.SHA1: instance Binary SHA1
+ Darcs.Util.Crypt.SHA1: instance Eq SHA1
+ Darcs.Util.Crypt.SHA1: instance Ord SHA1
+ Darcs.Util.Crypt.SHA1: instance Show SHA1
+ Darcs.Util.Crypt.SHA1: sha1PS :: ByteString -> SHA1
+ Darcs.Util.Crypt.SHA1: showAsHex :: Word32 -> String
+ Darcs.Util.Crypt.SHA256: sha256sum :: ByteString -> String
+ Darcs.Util.DateMatcher: DM :: String -> (Either ParseError d) -> (d -> CalendarTime -> Bool) -> DateMatcher
+ Darcs.Util.DateMatcher: data DateMatcher
+ Darcs.Util.DateMatcher: getMatchers :: String -> IO [DateMatcher]
+ Darcs.Util.DateMatcher: parseDateMatcher :: String -> IO (CalendarTime -> Bool)
+ Darcs.Util.DateTime: formatDateTime :: String -> UTCTime -> String
+ Darcs.Util.DateTime: fromClockTime :: ClockTime -> UTCTime
+ Darcs.Util.DateTime: getCurrentTime :: IO UTCTime
+ Darcs.Util.DateTime: parseDateTime :: String -> String -> Maybe UTCTime
+ Darcs.Util.DateTime: startOfTime :: UTCTime
+ Darcs.Util.DateTime: toSeconds :: UTCTime -> Integer
+ Darcs.Util.Diff: MyersDiff :: DiffAlgorithm
+ Darcs.Util.Diff: PatienceDiff :: DiffAlgorithm
+ Darcs.Util.Diff: data DiffAlgorithm
+ Darcs.Util.Diff: getChanges :: DiffAlgorithm -> [ByteString] -> [ByteString] -> [(Int, [ByteString], [ByteString])]
+ Darcs.Util.Diff: instance Eq DiffAlgorithm
+ Darcs.Util.Diff: instance Show DiffAlgorithm
+ Darcs.Util.Diff.Myers: aLen :: IArray a e => a Int e -> Int
+ Darcs.Util.Diff.Myers: getChanges :: [ByteString] -> [ByteString] -> [(Int, [ByteString], [ByteString])]
+ Darcs.Util.Diff.Myers: getSlice :: PArray -> Int -> Int -> [ByteString]
+ Darcs.Util.Diff.Myers: initP :: [ByteString] -> PArray
+ Darcs.Util.Diff.Myers: shiftBoundaries :: BSTArray s -> BSTArray s -> PArray -> Int -> Int -> ST s ()
+ Darcs.Util.Diff.Myers: type PArray = Array Int ByteString
+ Darcs.Util.Diff.Patience: getChanges :: [ByteString] -> [ByteString] -> [(Int, [ByteString], [ByteString])]
+ Darcs.Util.Download: Cachable :: Cachable
+ Darcs.Util.Download: CouldNotConnectToServer :: ConnectionError
+ Darcs.Util.Download: CouldNotResolveHost :: ConnectionError
+ Darcs.Util.Download: MaxAge :: !CInt -> Cachable
+ Darcs.Util.Download: OperationTimeout :: ConnectionError
+ Darcs.Util.Download: Uncachable :: Cachable
+ Darcs.Util.Download: copyUrl :: String -> FilePath -> Cachable -> IO ()
+ Darcs.Util.Download: copyUrlFirst :: String -> FilePath -> Cachable -> IO ()
+ Darcs.Util.Download: data Cachable
+ Darcs.Util.Download: data ConnectionError
+ Darcs.Util.Download: disableHTTPPipelining :: IO ()
+ Darcs.Util.Download: environmentHelpProxy :: ([String], [String])
+ Darcs.Util.Download: environmentHelpProxyPassword :: ([String], [String])
+ Darcs.Util.Download: maxPipelineLength :: IO Int
+ Darcs.Util.Download: setDebugHTTP :: IO ()
+ Darcs.Util.Download: waitUrl :: String -> IO ()
+ Darcs.Util.Download.HTTP: fetchUrl :: String -> IO String
+ Darcs.Util.Download.HTTP: postUrl :: String -> String -> String -> IO ()
+ Darcs.Util.Download.HTTP: requestUrl :: String -> FilePath -> a -> IO String
+ Darcs.Util.Download.HTTP: waitNextUrl :: IO (String, String, Maybe ConnectionError)
+ Darcs.Util.Download.Request: Cachable :: Cachable
+ Darcs.Util.Download.Request: CouldNotConnectToServer :: ConnectionError
+ Darcs.Util.Download.Request: CouldNotResolveHost :: ConnectionError
+ Darcs.Util.Download.Request: High :: Priority
+ Darcs.Util.Download.Request: Low :: Priority
+ Darcs.Util.Download.Request: MaxAge :: !CInt -> Cachable
+ Darcs.Util.Download.Request: OperationTimeout :: ConnectionError
+ Darcs.Util.Download.Request: Q :: [a] -> [a] -> Q a
+ Darcs.Util.Download.Request: Uncachable :: Cachable
+ Darcs.Util.Download.Request: UrlRequest :: String -> FilePath -> Cachable -> Priority -> UrlRequest
+ Darcs.Util.Download.Request: UrlState :: Map String InProgressStatus -> Q String -> Int -> String -> UrlState
+ Darcs.Util.Download.Request: addUsingPriority :: Priority -> a -> Q a -> Q a
+ Darcs.Util.Download.Request: cachable :: UrlRequest -> Cachable
+ Darcs.Util.Download.Request: data Cachable
+ Darcs.Util.Download.Request: data ConnectionError
+ Darcs.Util.Download.Request: data Priority
+ Darcs.Util.Download.Request: data Q a
+ Darcs.Util.Download.Request: data UrlRequest
+ Darcs.Util.Download.Request: data UrlState
+ Darcs.Util.Download.Request: deleteQ :: Eq a => a -> Q a -> Q a
+ Darcs.Util.Download.Request: elemQ :: Eq a => a -> Q a -> Bool
+ Darcs.Util.Download.Request: emptyQ :: Q a
+ Darcs.Util.Download.Request: file :: UrlRequest -> FilePath
+ Darcs.Util.Download.Request: inProgress :: UrlState -> Map String InProgressStatus
+ Darcs.Util.Download.Request: insertQ :: a -> Q a -> Q a
+ Darcs.Util.Download.Request: instance Eq Cachable
+ Darcs.Util.Download.Request: instance Eq ConnectionError
+ Darcs.Util.Download.Request: instance Eq Priority
+ Darcs.Util.Download.Request: instance Read ConnectionError
+ Darcs.Util.Download.Request: instance Show Cachable
+ Darcs.Util.Download.Request: instance Show ConnectionError
+ Darcs.Util.Download.Request: nullQ :: Q a -> Bool
+ Darcs.Util.Download.Request: pipeLength :: UrlState -> Int
+ Darcs.Util.Download.Request: priority :: UrlRequest -> Priority
+ Darcs.Util.Download.Request: pushQ :: a -> Q a -> Q a
+ Darcs.Util.Download.Request: randomJunk :: UrlState -> String
+ Darcs.Util.Download.Request: readQ :: Q a -> Maybe (a, Q a)
+ Darcs.Util.Download.Request: url :: UrlRequest -> String
+ Darcs.Util.Download.Request: waitToStart :: UrlState -> Q String
+ Darcs.Util.English: It :: Pronoun
+ Darcs.Util.English: Noun :: String -> Noun
+ Darcs.Util.English: This :: Noun -> This
+ Darcs.Util.English: andClauses :: [String] -> String
+ Darcs.Util.English: class Countable a
+ Darcs.Util.English: data Pronoun
+ Darcs.Util.English: data This
+ Darcs.Util.English: englishNum :: Countable n => Int -> n -> ShowS
+ Darcs.Util.English: instance Countable Noun
+ Darcs.Util.English: instance Countable Pronoun
+ Darcs.Util.English: instance Countable This
+ Darcs.Util.English: intersperseLast :: String -> String -> [String] -> String
+ Darcs.Util.English: newtype Noun
+ Darcs.Util.English: orClauses :: [String] -> String
+ Darcs.Util.English: plural :: Countable a => a -> ShowS
+ Darcs.Util.English: presentParticiple :: String -> String
+ Darcs.Util.English: singular :: Countable a => a -> ShowS
+ Darcs.Util.Environment: maybeGetEnv :: String -> IO (Maybe String)
+ Darcs.Util.Exception: catchall :: IO a -> IO a -> IO a
+ Darcs.Util.Exception: clarifyErrors :: IO a -> String -> IO a
+ Darcs.Util.Exception: firstJustIO :: [IO (Maybe a)] -> IO (Maybe a)
+ Darcs.Util.Exception: prettyError :: IOError -> String
+ Darcs.Util.Exception: prettyException :: SomeException -> String
+ Darcs.Util.Exec: AsIs :: Redirect
+ Darcs.Util.Exec: ExecException :: String -> [String] -> Redirects -> String -> ExecException
+ Darcs.Util.Exec: File :: FilePath -> Redirect
+ Darcs.Util.Exec: Null :: Redirect
+ Darcs.Util.Exec: Stdout :: Redirect
+ Darcs.Util.Exec: data ExecException
+ Darcs.Util.Exec: data Redirect
+ Darcs.Util.Exec: exec :: String -> [String] -> Redirects -> IO ExitCode
+ Darcs.Util.Exec: execInteractive :: String -> String -> IO ExitCode
+ Darcs.Util.Exec: instance Exception ExecException
+ Darcs.Util.Exec: instance Show ExecException
+ Darcs.Util.Exec: instance Show Redirect
+ Darcs.Util.Exec: instance Typeable ExecException
+ Darcs.Util.Exec: readInteractiveProcess :: FilePath -> [String] -> IO (ExitCode, String)
+ Darcs.Util.Exec: renderExecException :: ExecException -> String
+ Darcs.Util.Exec: type Redirects = (Redirect, Redirect, Redirect)
+ Darcs.Util.Exec: withoutNonBlock :: IO a -> IO a
+ Darcs.Util.File: doesDirectoryReallyExist :: FilePath -> IO Bool
+ Darcs.Util.File: getDirectoryContents :: FilePath -> IO [FilePath]
+ Darcs.Util.File: getFileStatus :: FilePath -> IO (Maybe FileStatus)
+ Darcs.Util.File: getRecursiveContents :: FilePath -> IO [FilePath]
+ Darcs.Util.File: getRecursiveContentsFullPath :: FilePath -> IO [FilePath]
+ Darcs.Util.File: osxCacheDir :: IO (Maybe FilePath)
+ Darcs.Util.File: removeFileMayNotExist :: FilePathLike p => p -> IO ()
+ Darcs.Util.File: withCurrentDirectory :: FilePathLike p => p -> IO a -> IO a
+ Darcs.Util.File: xdgCacheDir :: IO (Maybe FilePath)
+ Darcs.Util.Global: addBadSource :: String -> IO ()
+ Darcs.Util.Global: addCRCWarning :: FilePath -> IO ()
+ Darcs.Util.Global: addReachableSource :: String -> IO ()
+ Darcs.Util.Global: darcsLastMessage :: String
+ Darcs.Util.Global: darcsSendMessage :: String
+ Darcs.Util.Global: darcsSendMessageFinal :: String
+ Darcs.Util.Global: darcsdir :: String
+ Darcs.Util.Global: debugFail :: String -> IO a
+ Darcs.Util.Global: debugMessage :: String -> IO ()
+ Darcs.Util.Global: getBadSourcesList :: IO [String]
+ Darcs.Util.Global: getCRCWarnings :: IO [FilePath]
+ Darcs.Util.Global: isBadSource :: IO (String -> Bool)
+ Darcs.Util.Global: isReachableSource :: IO (String -> Bool)
+ Darcs.Util.Global: putTiming :: IO ()
+ Darcs.Util.Global: resetCRCWarnings :: IO ()
+ Darcs.Util.Global: setDebugMode :: IO ()
+ Darcs.Util.Global: setTimingsMode :: IO ()
+ Darcs.Util.Global: timingsMode :: Bool
+ Darcs.Util.Global: whenDebugMode :: IO () -> IO ()
+ Darcs.Util.Global: withDebugMode :: (Bool -> IO a) -> IO a
+ Darcs.Util.IsoDate: MCalendarTime :: Maybe Int -> Maybe Month -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Integer -> Maybe Day -> Maybe Int -> Maybe String -> Maybe Int -> Maybe Bool -> Bool -> MCalendarTime
+ Darcs.Util.IsoDate: addToMCal :: TimeDiff -> MCalendarTime -> MCalendarTime
+ Darcs.Util.IsoDate: cleanLocalDate :: String -> IO String
+ Darcs.Util.IsoDate: data MCalendarTime
+ Darcs.Util.IsoDate: englishDateTime :: CalendarTime -> CharParser a CalendarTime
+ Darcs.Util.IsoDate: englishInterval :: CalendarTime -> CharParser a TimeInterval
+ Darcs.Util.IsoDate: englishLast :: CalendarTime -> CharParser a (CalendarTime, CalendarTime)
+ Darcs.Util.IsoDate: getIsoDateTime :: IO String
+ Darcs.Util.IsoDate: getLocalTz :: IO Int
+ Darcs.Util.IsoDate: instance Show MCalendarTime
+ Darcs.Util.IsoDate: iso8601Duration :: CharParser a TimeDiff
+ Darcs.Util.IsoDate: iso8601Interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime))
+ Darcs.Util.IsoDate: mctDay :: MCalendarTime -> Maybe Int
+ Darcs.Util.IsoDate: mctHour :: MCalendarTime -> Maybe Int
+ Darcs.Util.IsoDate: mctIsDST :: MCalendarTime -> Maybe Bool
+ Darcs.Util.IsoDate: mctMin :: MCalendarTime -> Maybe Int
+ Darcs.Util.IsoDate: mctMonth :: MCalendarTime -> Maybe Month
+ Darcs.Util.IsoDate: mctPicosec :: MCalendarTime -> Maybe Integer
+ Darcs.Util.IsoDate: mctSec :: MCalendarTime -> Maybe Int
+ Darcs.Util.IsoDate: mctTZ :: MCalendarTime -> Maybe Int
+ Darcs.Util.IsoDate: mctTZName :: MCalendarTime -> Maybe String
+ Darcs.Util.IsoDate: mctWDay :: MCalendarTime -> Maybe Day
+ Darcs.Util.IsoDate: mctWeek :: MCalendarTime -> Bool
+ Darcs.Util.IsoDate: mctYDay :: MCalendarTime -> Maybe Int
+ Darcs.Util.IsoDate: mctYear :: MCalendarTime -> Maybe Int
+ Darcs.Util.IsoDate: parseDate :: Int -> String -> Either ParseError MCalendarTime
+ Darcs.Util.IsoDate: readUTCDate :: String -> CalendarTime
+ Darcs.Util.IsoDate: resetCalendar :: CalendarTime -> CalendarTime
+ Darcs.Util.IsoDate: subtractFromMCal :: TimeDiff -> MCalendarTime -> MCalendarTime
+ Darcs.Util.IsoDate: toMCalendarTime :: CalendarTime -> MCalendarTime
+ Darcs.Util.IsoDate: type TimeInterval = (Maybe CalendarTime, Maybe CalendarTime)
+ Darcs.Util.IsoDate: unsafeToCalendarTime :: MCalendarTime -> CalendarTime
+ Darcs.Util.IsoDate: unsetTime :: CalendarTime -> CalendarTime
+ Darcs.Util.Path: breakOnDir :: FileName -> Maybe (FileName, FileName)
+ Darcs.Util.Path: class FilePathOrURL a => FilePathLike a
+ Darcs.Util.Path: class FilePathOrURL a
+ Darcs.Util.Path: data AbsoluteOrRemotePath
+ Darcs.Util.Path: data AbsolutePath
+ Darcs.Util.Path: data AbsolutePathOrStd
+ Darcs.Util.Path: data FileName
+ Darcs.Util.Path: data SubPath
+ Darcs.Util.Path: decodeWhite :: String -> FilePath
+ Darcs.Util.Path: doesPathExist :: FilePath -> IO Bool
+ Darcs.Util.Path: encodeWhite :: FilePath -> String
+ Darcs.Util.Path: filterFilePaths :: [FilePath] -> AnchoredPath -> t -> Bool
+ Darcs.Util.Path: filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool
+ Darcs.Util.Path: floatSubPath :: SubPath -> AnchoredPath
+ Darcs.Util.Path: fn2fp :: FileName -> FilePath
+ Darcs.Util.Path: fn2niceps :: FileName -> ByteString
+ Darcs.Util.Path: fn2ps :: FileName -> ByteString
+ Darcs.Util.Path: fp2fn :: FilePath -> FileName
+ Darcs.Util.Path: getCurrentDirectory :: IO AbsolutePath
+ Darcs.Util.Path: getUniquePathName :: Bool -> (FilePath -> String) -> (Int -> FilePath) -> IO FilePath
+ Darcs.Util.Path: instance Binary FileName
+ Darcs.Util.Path: instance CharLike Char
+ Darcs.Util.Path: instance CharLike c => FilePathLike [c]
+ Darcs.Util.Path: instance CharLike c => FilePathOrURL [c]
+ Darcs.Util.Path: instance Eq AbsoluteOrRemotePath
+ Darcs.Util.Path: instance Eq AbsolutePath
+ Darcs.Util.Path: instance Eq AbsolutePathOrStd
+ Darcs.Util.Path: instance Eq FileName
+ Darcs.Util.Path: instance Eq SubPath
+ Darcs.Util.Path: instance FilePathLike AbsolutePath
+ Darcs.Util.Path: instance FilePathLike FileName
+ Darcs.Util.Path: instance FilePathLike SubPath
+ Darcs.Util.Path: instance FilePathOrURL AbsoluteOrRemotePath
+ Darcs.Util.Path: instance FilePathOrURL AbsolutePath
+ Darcs.Util.Path: instance FilePathOrURL FileName
+ Darcs.Util.Path: instance FilePathOrURL SubPath
+ Darcs.Util.Path: instance Ord AbsoluteOrRemotePath
+ Darcs.Util.Path: instance Ord AbsolutePath
+ Darcs.Util.Path: instance Ord AbsolutePathOrStd
+ Darcs.Util.Path: instance Ord FileName
+ Darcs.Util.Path: instance Ord SubPath
+ Darcs.Util.Path: instance Show AbsoluteOrRemotePath
+ Darcs.Util.Path: instance Show AbsolutePath
+ Darcs.Util.Path: instance Show AbsolutePathOrStd
+ Darcs.Util.Path: instance Show FileName
+ Darcs.Util.Path: instance Show SubPath
+ Darcs.Util.Path: ioAbsolute :: FilePath -> IO AbsolutePath
+ Darcs.Util.Path: ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath
+ Darcs.Util.Path: ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd
+ Darcs.Util.Path: isMaliciousPath :: String -> Bool
+ Darcs.Util.Path: isMaliciousSubPath :: String -> Bool
+ Darcs.Util.Path: isParentOrEqOf :: FileName -> FileName -> Bool
+ Darcs.Util.Path: isRemote :: AbsoluteOrRemotePath -> Bool
+ Darcs.Util.Path: isSubPathOf :: SubPath -> SubPath -> Bool
+ Darcs.Util.Path: makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath
+ Darcs.Util.Path: makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd
+ Darcs.Util.Path: makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath
+ Darcs.Util.Path: movedirfilename :: FileName -> FileName -> FileName -> FileName
+ Darcs.Util.Path: niceps2fn :: ByteString -> FileName
+ Darcs.Util.Path: normPath :: FileName -> FileName
+ Darcs.Util.Path: ownName :: FileName -> FileName
+ Darcs.Util.Path: ps2fn :: ByteString -> FileName
+ Darcs.Util.Path: rootDirectory :: AbsolutePath
+ Darcs.Util.Path: setCurrentDirectory :: FilePathLike p => p -> IO ()
+ Darcs.Util.Path: simpleSubPath :: FilePath -> Maybe SubPath
+ Darcs.Util.Path: sp2fn :: SubPath -> FileName
+ Darcs.Util.Path: stdOut :: AbsolutePathOrStd
+ Darcs.Util.Path: superName :: FileName -> FileName
+ Darcs.Util.Path: toFilePath :: FilePathLike a => a -> FilePath
+ Darcs.Util.Path: toPath :: FilePathOrURL a => a -> String
+ Darcs.Util.Path: useAbsoluteOrStd :: (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a
+ Darcs.Util.Printer: ($$) :: Doc -> Doc -> Doc
+ Darcs.Util.Printer: (<+>) :: Doc -> Doc -> Doc
+ Darcs.Util.Printer: (<>) :: Doc -> Doc -> Doc
+ Darcs.Util.Printer: (<?>) :: Doc -> Doc -> Doc
+ Darcs.Util.Printer: Blue :: Color
+ Darcs.Util.Printer: Both :: !String -> !ByteString -> Printable
+ Darcs.Util.Printer: Cyan :: Color
+ Darcs.Util.Printer: Doc :: (St -> Document) -> Doc
+ Darcs.Util.Printer: Encode :: RenderMode
+ Darcs.Util.Printer: Green :: Color
+ Darcs.Util.Printer: Magenta :: Color
+ Darcs.Util.Printer: PS :: !ByteString -> Printable
+ Darcs.Util.Printer: Printers :: !(Color -> Printer) -> !Printer -> !Printer -> !Printer -> !Printer -> !(Color -> Doc -> Doc) -> !([Printable] -> [Printable]) -> Printers'
+ Darcs.Util.Printer: Red :: Color
+ Darcs.Util.Printer: S :: !String -> Printable
+ Darcs.Util.Printer: Standard :: RenderMode
+ Darcs.Util.Printer: backslash :: Doc
+ Darcs.Util.Printer: blueText :: String -> Doc
+ Darcs.Util.Printer: colorP :: Printers' -> !(Color -> Printer)
+ Darcs.Util.Printer: colorText :: Color -> String -> Doc
+ Darcs.Util.Printer: cyanText :: String -> Doc
+ Darcs.Util.Printer: data Color
+ Darcs.Util.Printer: data Printable
+ Darcs.Util.Printer: data Printers'
+ Darcs.Util.Printer: data RenderMode
+ Darcs.Util.Printer: defP :: Printers' -> !Printer
+ Darcs.Util.Printer: doc :: ([Printable] -> [Printable]) -> Doc
+ Darcs.Util.Printer: empty :: Doc
+ Darcs.Util.Printer: errorDoc :: Doc -> a
+ Darcs.Util.Printer: greenText :: String -> Doc
+ Darcs.Util.Printer: hPutDoc :: RenderMode -> Handle -> Doc -> IO ()
+ Darcs.Util.Printer: hPutDocCompr :: RenderMode -> Handle -> Doc -> IO ()
+ Darcs.Util.Printer: hPutDocLn :: RenderMode -> Handle -> Doc -> IO ()
+ Darcs.Util.Printer: hPutDocLnWith :: Printers -> RenderMode -> Handle -> Doc -> IO ()
+ Darcs.Util.Printer: hPutDocWith :: Printers -> RenderMode -> Handle -> Doc -> IO ()
+ Darcs.Util.Printer: hcat :: [Doc] -> Doc
+ Darcs.Util.Printer: hiddenP :: Printers' -> !Printer
+ Darcs.Util.Printer: hiddenPrefix :: String -> Doc -> Doc
+ Darcs.Util.Printer: hiddenText :: String -> Doc
+ Darcs.Util.Printer: insertBeforeLastline :: Doc -> Doc -> Doc
+ Darcs.Util.Printer: instance IsString Doc
+ Darcs.Util.Printer: invisibleP :: Printers' -> !Printer
+ Darcs.Util.Printer: invisiblePS :: ByteString -> Doc
+ Darcs.Util.Printer: invisiblePrinter :: Printer
+ Darcs.Util.Printer: invisibleText :: String -> Doc
+ Darcs.Util.Printer: lineColor :: Color -> Doc -> Doc
+ Darcs.Util.Printer: lineColorS :: Printers' -> !([Printable] -> [Printable])
+ Darcs.Util.Printer: lineColorT :: Printers' -> !(Color -> Doc -> Doc)
+ Darcs.Util.Printer: lparen :: Doc
+ Darcs.Util.Printer: magentaText :: String -> Doc
+ Darcs.Util.Printer: minus :: Doc
+ Darcs.Util.Printer: newline :: Doc
+ Darcs.Util.Printer: newtype Doc
+ Darcs.Util.Printer: packedString :: ByteString -> Doc
+ Darcs.Util.Printer: parens :: Doc -> Doc
+ Darcs.Util.Printer: plus :: Doc
+ Darcs.Util.Printer: prefix :: String -> Doc -> Doc
+ Darcs.Util.Printer: prefixLines :: Doc -> Doc -> Doc
+ Darcs.Util.Printer: printable :: Printable -> Doc
+ Darcs.Util.Printer: putDoc :: Doc -> IO ()
+ Darcs.Util.Printer: putDocLn :: Doc -> IO ()
+ Darcs.Util.Printer: putDocLnWith :: Printers -> Doc -> IO ()
+ Darcs.Util.Printer: putDocWith :: Printers -> Doc -> IO ()
+ Darcs.Util.Printer: redText :: String -> Doc
+ Darcs.Util.Printer: renderPS :: RenderMode -> Doc -> ByteString
+ Darcs.Util.Printer: renderPSWith :: Printers' -> RenderMode -> Doc -> ByteString
+ Darcs.Util.Printer: renderPSs :: RenderMode -> Doc -> [ByteString]
+ Darcs.Util.Printer: renderPSsWith :: Printers' -> RenderMode -> Doc -> [ByteString]
+ Darcs.Util.Printer: renderString :: RenderMode -> Doc -> String
+ Darcs.Util.Printer: renderStringWith :: Printers' -> RenderMode -> Doc -> String
+ Darcs.Util.Printer: rparen :: Doc
+ Darcs.Util.Printer: simplePrinter :: Printer
+ Darcs.Util.Printer: simplePrinters :: Printers
+ Darcs.Util.Printer: space :: Doc
+ Darcs.Util.Printer: text :: String -> Doc
+ Darcs.Util.Printer: type Printer = Printable -> St -> Document
+ Darcs.Util.Printer: type Printers = Handle -> Printers'
+ Darcs.Util.Printer: unDoc :: Doc -> St -> Document
+ Darcs.Util.Printer: unsafeBoth :: String -> ByteString -> Doc
+ Darcs.Util.Printer: unsafeBothText :: String -> Doc
+ Darcs.Util.Printer: unsafeChar :: Char -> Doc
+ Darcs.Util.Printer: unsafePackedString :: ByteString -> Doc
+ Darcs.Util.Printer: unsafeText :: String -> Doc
+ Darcs.Util.Printer: userchunk :: String -> Doc
+ Darcs.Util.Printer: userchunkP :: Printers' -> !Printer
+ Darcs.Util.Printer: userchunkPS :: ByteString -> Doc
+ Darcs.Util.Printer: vcat :: [Doc] -> Doc
+ Darcs.Util.Printer: vsep :: [Doc] -> Doc
+ Darcs.Util.Printer: wrapText :: Int -> String -> Doc
+ Darcs.Util.Printer.Color: assertDoc :: Maybe Doc -> a -> a
+ Darcs.Util.Printer.Color: environmentHelpColor :: ([String], [String])
+ Darcs.Util.Printer.Color: environmentHelpEscape :: ([String], [String])
+ Darcs.Util.Printer.Color: environmentHelpEscapeWhite :: ([String], [String])
+ Darcs.Util.Printer.Color: errorDoc :: Doc -> a
+ Darcs.Util.Printer.Color: fancyPrinters :: Printers
+ Darcs.Util.Printer.Color: showDoc :: RenderMode -> Doc -> String
+ Darcs.Util.Printer.Color: traceDoc :: Doc -> a -> a
+ Darcs.Util.Progress: beginTedious :: String -> IO ()
+ Darcs.Util.Progress: debugFail :: String -> IO a
+ Darcs.Util.Progress: debugMessage :: String -> IO ()
+ Darcs.Util.Progress: endTedious :: String -> IO ()
+ Darcs.Util.Progress: finishedOne :: String -> String -> a -> a
+ Darcs.Util.Progress: finishedOneIO :: String -> String -> IO ()
+ Darcs.Util.Progress: minlist :: Int
+ Darcs.Util.Progress: progress :: String -> a -> a
+ Darcs.Util.Progress: progressKeepLatest :: String -> a -> a
+ Darcs.Util.Progress: progressList :: String -> [a] -> [a]
+ Darcs.Util.Progress: setProgressMode :: Bool -> IO ()
+ Darcs.Util.Progress: tediousSize :: String -> Int -> IO ()
+ Darcs.Util.Progress: withoutProgress :: IO a -> IO a
+ Darcs.Util.Prompt: PromptConfig :: String -> [Char] -> [Char] -> Maybe Char -> [Char] -> PromptConfig
+ Darcs.Util.Prompt: askEnter :: String -> IO ()
+ Darcs.Util.Prompt: askUser :: String -> IO String
+ Darcs.Util.Prompt: askUserListItem :: String -> [String] -> IO String
+ Darcs.Util.Prompt: data PromptConfig
+ Darcs.Util.Prompt: pAdvancedCharacters :: PromptConfig -> [Char]
+ Darcs.Util.Prompt: pBasicCharacters :: PromptConfig -> [Char]
+ Darcs.Util.Prompt: pDefault :: PromptConfig -> Maybe Char
+ Darcs.Util.Prompt: pHelp :: PromptConfig -> [Char]
+ Darcs.Util.Prompt: pPrompt :: PromptConfig -> String
+ Darcs.Util.Prompt: promptChar :: PromptConfig -> IO Char
+ Darcs.Util.Prompt: promptYorn :: String -> IO Bool
+ Darcs.Util.Ratified: hGetContents :: Handle -> IO String
+ Darcs.Util.Ratified: readFile :: FilePath -> IO String
+ Darcs.Util.Show: BSWrapper :: ByteString -> BSWrapper
+ Darcs.Util.Show: appPrec :: Int
+ Darcs.Util.Show: instance Show BSWrapper
+ Darcs.Util.Show: newtype BSWrapper
+ Darcs.Util.SignalHandler: catchInterrupt :: IO a -> IO a -> IO a
+ Darcs.Util.SignalHandler: catchNonSignal :: IO a -> (SomeException -> IO a) -> IO a
+ Darcs.Util.SignalHandler: instance Exception SignalException
+ Darcs.Util.SignalHandler: instance Show SignalException
+ Darcs.Util.SignalHandler: instance Typeable SignalException
+ Darcs.Util.SignalHandler: stdoutIsAPipe :: IO Bool
+ Darcs.Util.SignalHandler: tryNonSignal :: IO a -> IO (Either SomeException a)
+ Darcs.Util.SignalHandler: withSignalsBlocked :: IO a -> IO a
+ Darcs.Util.SignalHandler: withSignalsHandled :: IO a -> IO a
+ Darcs.Util.Ssh: SshSettings :: String -> String -> String -> SshSettings
+ Darcs.Util.Ssh: data SshSettings
+ Darcs.Util.Ssh: defaultSsh :: SshSettings
+ Darcs.Util.Ssh: instance Eq SshSettings
+ Darcs.Util.Ssh: instance Show SshSettings
+ Darcs.Util.Ssh: scp :: SshSettings -> String
+ Darcs.Util.Ssh: sftp :: SshSettings -> String
+ Darcs.Util.Ssh: ssh :: SshSettings -> String
+ Darcs.Util.Ssh: windows :: Bool
+ Darcs.Util.Text: breakCommand :: String -> (String, [String])
+ Darcs.Util.Text: chompTrailingNewline :: String -> String
+ Darcs.Util.Text: formatPara :: Int -> [[a]] -> [[[a]]]
+ Darcs.Util.Text: formatParas :: Int -> [String] -> [String]
+ Darcs.Util.Text: formatText :: Int -> [String] -> String
+ Darcs.Util.Text: sentence :: Doc -> Doc
+ Darcs.Util.URL: data SshFilePath
+ Darcs.Util.URL: isAbsolute :: String -> Bool
+ Darcs.Util.URL: isHttpUrl :: String -> Bool
+ Darcs.Util.URL: isRelative :: String -> Bool
+ Darcs.Util.URL: isSshNopath :: String -> Bool
+ Darcs.Util.URL: isSshUrl :: String -> Bool
+ Darcs.Util.URL: isValidLocalPath :: String -> Bool
+ Darcs.Util.URL: splitSshUrl :: String -> SshFilePath
+ Darcs.Util.URL: sshFile :: SshFilePath -> String
+ Darcs.Util.URL: sshRepo :: SshFilePath -> String
+ Darcs.Util.URL: sshUhost :: SshFilePath -> String
+ Darcs.Util.URL: urlOf :: SshFilePath -> String
+ Darcs.Util.Workaround: Catch :: IO () -> Handler
+ Darcs.Util.Workaround: CatchInfo :: (SignalInfo -> IO ()) -> Handler
+ Darcs.Util.Workaround: CatchInfoOnce :: (SignalInfo -> IO ()) -> Handler
+ Darcs.Util.Workaround: CatchOnce :: IO () -> Handler
+ Darcs.Util.Workaround: Default :: Handler
+ Darcs.Util.Workaround: Ignore :: Handler
+ Darcs.Util.Workaround: data Handler :: *
+ Darcs.Util.Workaround: getCurrentDirectory :: IO FilePath
+ Darcs.Util.Workaround: installHandler :: Signal -> Handler -> Maybe SignalSet -> IO Handler
+ Darcs.Util.Workaround: raiseSignal :: Signal -> IO ()
+ Darcs.Util.Workaround: renameFile :: FilePath -> FilePath -> IO ()
+ Darcs.Util.Workaround: setExecutable :: FilePath -> Bool -> IO ()
+ Darcs.Util.Workaround: sigABRT :: CInt
+ Darcs.Util.Workaround: sigALRM :: CInt
+ Darcs.Util.Workaround: sigHUP :: CInt
+ Darcs.Util.Workaround: sigINT :: CInt
+ Darcs.Util.Workaround: sigPIPE :: CInt
+ Darcs.Util.Workaround: sigTERM :: CInt
+ Darcs.Util.Workaround: type Signal = CInt
+ Storage.Hashed: floatPath :: FilePath -> AnchoredPath
+ Storage.Hashed: printPath :: Tree IO -> FilePath -> IO ()
+ Storage.Hashed: readBlob :: Blob m -> m ByteString
+ Storage.Hashed: readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO)
+ Storage.Hashed: readPlainTree :: FilePath -> IO (Tree IO)
+ Storage.Hashed: writeDarcsHashed :: Tree IO -> FilePath -> IO Hash
+ Storage.Hashed: writePlainTree :: Tree IO -> FilePath -> IO ()
+ Storage.Hashed.AnchoredPath: AnchoredPath :: [Name] -> AnchoredPath
+ Storage.Hashed.AnchoredPath: Name :: ByteString -> Name
+ Storage.Hashed.AnchoredPath: anchorPath :: FilePath -> AnchoredPath -> FilePath
+ Storage.Hashed.AnchoredPath: anchoredRoot :: AnchoredPath
+ Storage.Hashed.AnchoredPath: appendPath :: AnchoredPath -> Name -> AnchoredPath
+ Storage.Hashed.AnchoredPath: appendToName :: AnchoredPath -> String -> AnchoredPath
+ Storage.Hashed.AnchoredPath: catPaths :: AnchoredPath -> AnchoredPath -> AnchoredPath
+ Storage.Hashed.AnchoredPath: flatten :: AnchoredPath -> ByteString
+ Storage.Hashed.AnchoredPath: floatBS :: ByteString -> AnchoredPath
+ Storage.Hashed.AnchoredPath: floatPath :: FilePath -> AnchoredPath
+ Storage.Hashed.AnchoredPath: instance Eq AnchoredPath
+ Storage.Hashed.AnchoredPath: instance Eq Name
+ Storage.Hashed.AnchoredPath: instance Ord AnchoredPath
+ Storage.Hashed.AnchoredPath: instance Ord Name
+ Storage.Hashed.AnchoredPath: instance Show AnchoredPath
+ Storage.Hashed.AnchoredPath: instance Show Name
+ Storage.Hashed.AnchoredPath: isPrefix :: AnchoredPath -> AnchoredPath -> Bool
+ Storage.Hashed.AnchoredPath: makeName :: String -> Name
+ Storage.Hashed.AnchoredPath: newtype AnchoredPath
+ Storage.Hashed.AnchoredPath: newtype Name
+ Storage.Hashed.AnchoredPath: parent :: AnchoredPath -> AnchoredPath
+ Storage.Hashed.AnchoredPath: parents :: AnchoredPath -> [AnchoredPath]
+ Storage.Hashed.AnchoredPath: replacePrefixPath :: AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
+ Storage.Hashed.Darcs: darcsAddMissingHashes :: (Monad m, Functor m) => Tree m -> m (Tree m)
+ Storage.Hashed.Darcs: darcsCheckExpand :: Tree IO -> IO (Either [(FilePath, Hash, Maybe Hash)] (Tree IO))
+ Storage.Hashed.Darcs: darcsDecodeWhite :: String -> FilePath
+ Storage.Hashed.Darcs: darcsEncodeWhite :: FilePath -> String
+ Storage.Hashed.Darcs: darcsEncodeWhiteBS :: ByteString -> ByteString
+ Storage.Hashed.Darcs: darcsFormatDir :: Tree m -> Maybe ByteString
+ Storage.Hashed.Darcs: darcsHash :: (Monad m, Functor m) => TreeItem m -> m Hash
+ Storage.Hashed.Darcs: darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment
+ Storage.Hashed.Darcs: darcsParseDir :: ByteString -> [(ItemType, Name, Maybe Int, Hash)]
+ Storage.Hashed.Darcs: darcsPristineRefs :: FileSegment -> IO [Hash]
+ Storage.Hashed.Darcs: darcsTreeHash :: Tree m -> Hash
+ Storage.Hashed.Darcs: darcsUpdateDirHashes :: Tree m -> Tree m
+ Storage.Hashed.Darcs: darcsUpdateHashes :: (Monad m, Functor m) => Tree m -> m (Tree m)
+ Storage.Hashed.Darcs: decodeDarcsHash :: ByteString -> Hash
+ Storage.Hashed.Darcs: decodeDarcsSize :: ByteString -> Maybe Int
+ Storage.Hashed.Darcs: fsCreateHashedFile :: FilePath -> ByteString -> TreeIO ()
+ Storage.Hashed.Darcs: hashedTreeIO :: TreeIO a -> Tree IO -> FilePath -> IO (a, Tree IO)
+ Storage.Hashed.Darcs: readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO)
+ Storage.Hashed.Darcs: readDarcsHashed' :: Bool -> FilePath -> (Maybe Int, Hash) -> IO (Tree IO)
+ Storage.Hashed.Darcs: readDarcsHashedDir :: FilePath -> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]
+ Storage.Hashed.Darcs: readDarcsHashedNosize :: FilePath -> Hash -> IO (Tree IO)
+ Storage.Hashed.Darcs: readPackedDarcsPristine :: OS -> Hash -> IO (Tree IO)
+ Storage.Hashed.Darcs: storePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash)
+ Storage.Hashed.Darcs: writeDarcsHashed :: Tree IO -> FilePath -> IO Hash
+ Storage.Hashed.Darcs: writePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash)
+ Storage.Hashed.Hash: NoHash :: Hash
+ Storage.Hashed.Hash: SHA1 :: !ByteString -> Hash
+ Storage.Hashed.Hash: SHA256 :: !ByteString -> Hash
+ Storage.Hashed.Hash: data Hash
+ Storage.Hashed.Hash: decodeBase16 :: ByteString -> Hash
+ Storage.Hashed.Hash: decodeBase64u :: ByteString -> Hash
+ Storage.Hashed.Hash: encodeBase16 :: Hash -> ByteString
+ Storage.Hashed.Hash: encodeBase64u :: Hash -> ByteString
+ Storage.Hashed.Hash: instance Data Hash
+ Storage.Hashed.Hash: instance Eq Hash
+ Storage.Hashed.Hash: instance Ord Hash
+ Storage.Hashed.Hash: instance Read Hash
+ Storage.Hashed.Hash: instance Show Hash
+ Storage.Hashed.Hash: instance Typeable Hash
+ Storage.Hashed.Hash: match :: Hash -> Hash -> Bool
+ Storage.Hashed.Hash: rawHash :: Hash -> ByteString
+ Storage.Hashed.Hash: sha256 :: ByteString -> Hash
+ Storage.Hashed.Index: filter :: FilterTree a m => (AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
+ Storage.Hashed.Index: getFileID :: AnchoredPath -> IO (Maybe FileID)
+ Storage.Hashed.Index: indexFormatValid :: FilePath -> IO Bool
+ Storage.Hashed.Index: instance FilterTree IndexM IO
+ Storage.Hashed.Index: instance Show Item
+ Storage.Hashed.Index: listFileIDs :: Index -> IO ([((AnchoredPath, ItemType), FileID)])
+ Storage.Hashed.Index: readIndex :: FilePath -> (Tree IO -> Hash) -> IO Index
+ Storage.Hashed.Index: type Index = IndexM IO
+ Storage.Hashed.Index: updateIndex :: Index -> IO (Tree IO)
+ Storage.Hashed.Index: updateIndexFrom :: FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index
+ Storage.Hashed.Monad: class (Functor m, Monad m) => TreeRO m
+ Storage.Hashed.Monad: class TreeRO m => TreeRW m
+ Storage.Hashed.Monad: copy :: TreeRW m => AnchoredPath -> AnchoredPath -> m ()
+ Storage.Hashed.Monad: createDirectory :: TreeRW m => AnchoredPath -> m ()
+ Storage.Hashed.Monad: currentDirectory :: TreeRO m => m AnchoredPath
+ Storage.Hashed.Monad: data TreeState m
+ Storage.Hashed.Monad: directoryExists :: TreeRO m => AnchoredPath -> m Bool
+ Storage.Hashed.Monad: exists :: TreeRO m => AnchoredPath -> m Bool
+ Storage.Hashed.Monad: fileExists :: TreeRO m => AnchoredPath -> m Bool
+ Storage.Hashed.Monad: findFileM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Blob m))
+ Storage.Hashed.Monad: findM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (TreeItem m))
+ Storage.Hashed.Monad: findTreeM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Tree m))
+ Storage.Hashed.Monad: initialState :: Tree m -> (TreeItem m -> m Hash) -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)) -> TreeState m
+ Storage.Hashed.Monad: instance (Functor m, Monad m) => TreeRO (TreeMonad m)
+ Storage.Hashed.Monad: instance (Functor m, Monad m) => TreeRW (TreeMonad m)
+ Storage.Hashed.Monad: readFile :: TreeRO m => AnchoredPath -> m ByteString
+ Storage.Hashed.Monad: rename :: TreeRW m => AnchoredPath -> AnchoredPath -> m ()
+ Storage.Hashed.Monad: replaceItem :: (Functor m, Monad m) => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
+ Storage.Hashed.Monad: runTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m)
+ Storage.Hashed.Monad: tree :: TreeState m -> (Tree m)
+ Storage.Hashed.Monad: type TreeIO = TreeMonad IO
+ Storage.Hashed.Monad: type TreeMonad m = RWST AnchoredPath () (TreeState m) m
+ Storage.Hashed.Monad: unlink :: TreeRW m => AnchoredPath -> m ()
+ Storage.Hashed.Monad: virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO)
+ Storage.Hashed.Monad: virtualTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m)
+ Storage.Hashed.Monad: withDirectory :: TreeRO m => AnchoredPath -> m a -> m a
+ Storage.Hashed.Monad: writeFile :: TreeRW m => AnchoredPath -> ByteString -> m ()
+ Storage.Hashed.Packed: Compact :: Format
+ Storage.Hashed.Packed: Loose :: Format
+ Storage.Hashed.Packed: Pack :: Format
+ Storage.Hashed.Packed: blockLookup :: Block -> Hash -> IO (Maybe FileSegment)
+ Storage.Hashed.Packed: compact :: OS -> IO OS
+ Storage.Hashed.Packed: create :: FilePath -> Format -> IO OS
+ Storage.Hashed.Packed: data Block
+ Storage.Hashed.Packed: data Format
+ Storage.Hashed.Packed: data OS
+ Storage.Hashed.Packed: format :: Block -> Format
+ Storage.Hashed.Packed: hatch :: OS -> [ByteString] -> IO OS
+ Storage.Hashed.Packed: hatchery :: OS -> Block
+ Storage.Hashed.Packed: instance Eq Format
+ Storage.Hashed.Packed: instance Show Format
+ Storage.Hashed.Packed: live :: OS -> [Block] -> IO (Map Hash FileSegment)
+ Storage.Hashed.Packed: load :: FilePath -> IO OS
+ Storage.Hashed.Packed: lookup :: OS -> Hash -> IO (Maybe FileSegment)
+ Storage.Hashed.Packed: mature :: OS -> [Block]
+ Storage.Hashed.Packed: references :: OS -> FileSegment -> IO [Hash]
+ Storage.Hashed.Packed: repack :: OS -> IO OS
+ Storage.Hashed.Packed: rootdir :: OS -> FilePath
+ Storage.Hashed.Packed: roots :: OS -> [Hash]
+ Storage.Hashed.Plain: plainTreeIO :: TreeIO a -> Tree IO -> FilePath -> IO (a, Tree IO)
+ Storage.Hashed.Plain: readPlainTree :: FilePath -> IO (Tree IO)
+ Storage.Hashed.Plain: writePlainTree :: Tree IO -> FilePath -> IO ()
+ Storage.Hashed.Tree: Blob :: !(m ByteString) -> !Hash -> Blob m
+ Storage.Hashed.Tree: BlobType :: ItemType
+ Storage.Hashed.Tree: File :: !(Blob m) -> TreeItem m
+ Storage.Hashed.Tree: NoHash :: Hash
+ Storage.Hashed.Tree: SHA1 :: !ByteString -> Hash
+ Storage.Hashed.Tree: SHA256 :: !ByteString -> Hash
+ Storage.Hashed.Tree: Stub :: !(m (Tree m)) -> !Hash -> TreeItem m
+ Storage.Hashed.Tree: SubTree :: !(Tree m) -> TreeItem m
+ Storage.Hashed.Tree: TreeType :: ItemType
+ Storage.Hashed.Tree: addMissingHashes :: (Monad m, Functor m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m)
+ Storage.Hashed.Tree: checkExpand :: (TreeItem IO -> IO Hash) -> Tree IO -> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))
+ Storage.Hashed.Tree: class Monad m => FilterTree a m
+ Storage.Hashed.Tree: data Blob m
+ Storage.Hashed.Tree: data Hash
+ Storage.Hashed.Tree: data ItemType
+ Storage.Hashed.Tree: data Tree m
+ Storage.Hashed.Tree: data TreeItem m
+ Storage.Hashed.Tree: diffTrees :: (Functor m, Monad m) => Tree m -> Tree m -> m (Tree m, Tree m)
+ Storage.Hashed.Tree: emptyBlob :: Monad m => Blob m
+ Storage.Hashed.Tree: emptyTree :: Monad m => Tree m
+ Storage.Hashed.Tree: expand :: Monad m => Tree m -> m (Tree m)
+ Storage.Hashed.Tree: expandPath :: Monad m => Tree m -> AnchoredPath -> m (Tree m)
+ Storage.Hashed.Tree: expandUpdate :: Monad m => (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m)
+ Storage.Hashed.Tree: filter :: FilterTree a m => (AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
+ Storage.Hashed.Tree: find :: Tree m -> AnchoredPath -> Maybe (TreeItem m)
+ Storage.Hashed.Tree: findFile :: Tree m -> AnchoredPath -> Maybe (Blob m)
+ Storage.Hashed.Tree: findTree :: Tree m -> AnchoredPath -> Maybe (Tree m)
+ Storage.Hashed.Tree: instance Eq ItemType
+ Storage.Hashed.Tree: instance Monad m => FilterTree Tree m
+ Storage.Hashed.Tree: instance Ord ItemType
+ Storage.Hashed.Tree: instance Show ItemType
+ Storage.Hashed.Tree: itemHash :: TreeItem m -> Hash
+ Storage.Hashed.Tree: itemType :: TreeItem m -> ItemType
+ Storage.Hashed.Tree: items :: Tree m -> (Map Name (TreeItem m))
+ Storage.Hashed.Tree: list :: Tree m -> [(AnchoredPath, TreeItem m)]
+ Storage.Hashed.Tree: listImmediate :: Tree m -> [(Name, TreeItem m)]
+ Storage.Hashed.Tree: lookup :: Tree m -> Name -> Maybe (TreeItem m)
+ Storage.Hashed.Tree: makeBlob :: Monad m => ByteString -> Blob m
+ Storage.Hashed.Tree: makeBlobBS :: Monad m => ByteString -> Blob m
+ Storage.Hashed.Tree: makeTree :: Monad m => [(Name, TreeItem m)] -> Tree m
+ Storage.Hashed.Tree: makeTreeWithHash :: Monad m => [(Name, TreeItem m)] -> Hash -> Tree m
+ Storage.Hashed.Tree: modifyTree :: Monad m => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
+ Storage.Hashed.Tree: overlay :: (Functor m, Monad m) => Tree m -> Tree m -> Tree m
+ Storage.Hashed.Tree: partiallyUpdateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) -> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m)
+ Storage.Hashed.Tree: readBlob :: Blob m -> m ByteString
+ Storage.Hashed.Tree: restrict :: (FilterTree t m, Monad n) => Tree n -> t m -> t m
+ Storage.Hashed.Tree: treeHash :: Tree m -> Hash
+ Storage.Hashed.Tree: updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m
+ Storage.Hashed.Tree: updateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m)
+ Storage.Hashed.Tree: zipCommonFiles :: (AnchoredPath -> Blob m -> Blob m -> a) -> Tree m -> Tree m -> [a]
+ Storage.Hashed.Tree: zipFiles :: (AnchoredPath -> Maybe (Blob m) -> Maybe (Blob m) -> a) -> Tree m -> Tree m -> [a]
+ Storage.Hashed.Tree: zipTrees :: (AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a) -> Tree m -> Tree m -> [a]
- Darcs.Patch: adddeps :: Named p x y -> [PatchInfo] -> Named p x y
+ Darcs.Patch: adddeps :: Named p wX wY -> [PatchInfo] -> Named p wX wY
- Darcs.Patch: adddir :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch: adddir :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch: addfile :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch: addfile :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch: anonymous :: Patchy p => FL p x y -> IO (Named p x y)
+ Darcs.Patch: anonymous :: FL p wX wY -> IO (Named p wX wY)
- Darcs.Patch: apply :: (Apply p, ApplyMonad m (ApplyState p)) => p x y -> m ()
+ Darcs.Patch: apply :: (Apply p, ApplyMonad m (ApplyState p)) => p wX wY -> m ()
- Darcs.Patch: applyToFilePaths :: (Apply p, ApplyState p ~ Tree) => p x y -> Maybe [(FilePath, FilePath)] -> [FilePath] -> ([FilePath], [FilePath], [(FilePath, FilePath)])
+ Darcs.Patch: applyToFilePaths :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Maybe [(FilePath, FilePath)] -> [FilePath] -> ([FilePath], [FilePath], [(FilePath, FilePath)])
- Darcs.Patch: applyToTree :: (Apply p, Functor m, Monad m, ApplyState p ~ Tree) => p x y -> Tree m -> m (Tree m)
+ Darcs.Patch: applyToTree :: (Apply p, Functor m, Monad m, ApplyState p ~ Tree) => p wX wY -> Tree m -> m (Tree m)
- Darcs.Patch: binary :: PrimConstruct prim => FilePath -> ByteString -> ByteString -> prim x y
+ Darcs.Patch: binary :: PrimConstruct prim => FilePath -> ByteString -> ByteString -> prim wX wY
- Darcs.Patch: canonize :: PrimCanonize prim => prim x y -> FL prim x y
+ Darcs.Patch: canonize :: PrimCanonize prim => DiffAlgorithm -> prim wX wY -> FL prim wX wY
- Darcs.Patch: changepref :: PrimConstruct prim => String -> String -> String -> prim x y
+ Darcs.Patch: changepref :: PrimConstruct prim => String -> String -> String -> prim wX wY
- Darcs.Patch: class (MyEq p, Apply p, Commute p, PatchInspect p, ShowPatch p, ReadPatch p, Invert p) => Patchy p
+ Darcs.Patch: class (Apply p, Commute p, Invert p) => Patchy p
- Darcs.Patch: class (Patchy prim, PatchListFormat prim, IsHunk prim, RepairToFL prim, PrimConstruct prim, PrimCanonize prim, PrimClassify prim, PrimDetails prim, PrimShow prim, PrimRead prim, PrimApply prim) => PrimPatch prim
+ Darcs.Patch: class (Patchy prim, MyEq prim, PatchListFormat prim, IsHunk prim, RepairToFL prim, PatchInspect prim, ReadPatch prim, ShowPatch prim, PrimConstruct prim, PrimCanonize prim, PrimClassify prim, PrimDetails prim, PrimShow prim, PrimRead prim, PrimApply prim) => PrimPatch prim
- Darcs.Patch: class (Patchy p, Merge p, Effect p, IsHunk p, FromPrim p, Conflict p, CommuteNoConflicts p, Check p, RepairToFL p, PatchListFormat p, PrimPatchBase p, Patchy (PrimOf p), IsHunk (PrimOf p)) => RepoPatch p
+ Darcs.Patch: class (Patchy p, Merge p, Effect p, IsHunk p, PatchInspect p, ReadPatch p, ShowPatch p, FromPrim p, Conflict p, CommuteNoConflicts p, Check p, RepairToFL p, PatchListFormat p, PrimPatchBase p, Patchy (PrimOf p), IsHunk (PrimOf p), MaybeInternal p, RecontextRebase p, NameHack p, Matchable p) => RepoPatch p
- Darcs.Patch: commute :: Commute p => (p :> p) x y -> Maybe ((p :> p) x y)
+ Darcs.Patch: commute :: Commute p => (p :> p) wX wY -> Maybe ((p :> p) wX wY)
- Darcs.Patch: commuteFLorComplain :: Commute p => (p :> FL p) x y -> Either (Sealed2 p) ((FL p :> p) x y)
+ Darcs.Patch: commuteFLorComplain :: Commute p => (p :> FL p) wX wY -> Either (Sealed2 p) ((FL p :> p) wX wY)
- Darcs.Patch: commuteRL :: Commute p => (RL p :> p) x y -> Maybe ((p :> RL p) x y)
+ Darcs.Patch: commuteRL :: Commute p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY)
- Darcs.Patch: data Named p x y
+ Darcs.Patch: data Named p wX wY
- Darcs.Patch: description :: ShowPatch p => p x y -> Doc
+ Darcs.Patch: description :: ShowPatch p => p wX wY -> Doc
- Darcs.Patch: effect :: Effect p => p x y -> FL (PrimOf p) x y
+ Darcs.Patch: effect :: Effect p => p wX wY -> FL (PrimOf p) wX wY
- Darcs.Patch: effectOnFilePaths :: (Apply p, ApplyState p ~ Tree) => p x y -> [FilePath] -> [FilePath]
+ Darcs.Patch: effectOnFilePaths :: (Apply p, ApplyState p ~ Tree) => p wX wY -> [FilePath] -> [FilePath]
- Darcs.Patch: forceTokReplace :: String -> String -> String -> ByteString -> Maybe ByteString
+ Darcs.Patch: forceTokReplace :: String -> ByteString -> ByteString -> ByteString -> ByteString
- Darcs.Patch: fromPrim :: FromPrim p => PrimOf p x y -> p x y
+ Darcs.Patch: fromPrim :: FromPrim p => PrimOf p wX wY -> p wX wY
- Darcs.Patch: fromPrims :: FromPrims p => FL (PrimOf p) x y -> p x y
+ Darcs.Patch: fromPrims :: FromPrims p => FL (PrimOf p) wX wY -> p wX wY
- Darcs.Patch: getdeps :: Named p x y -> [PatchInfo]
+ Darcs.Patch: getdeps :: Named p wX wY -> [PatchInfo]
- Darcs.Patch: hunk :: PrimConstruct prim => FilePath -> Int -> [ByteString] -> [ByteString] -> prim x y
+ Darcs.Patch: hunk :: PrimConstruct prim => FilePath -> Int -> [ByteString] -> [ByteString] -> prim wX wY
- Darcs.Patch: hunkMatches :: PatchInspect p => (ByteString -> Bool) -> p x y -> Bool
+ Darcs.Patch: hunkMatches :: PatchInspect p => (ByteString -> Bool) -> p wX wY -> Bool
- Darcs.Patch: infopatch :: Patchy p => PatchInfo -> FL p x y -> Named p x y
+ Darcs.Patch: infopatch :: PatchInfo -> FL p wX wY -> Named p wX wY
- Darcs.Patch: invert :: Invert p => p x y -> p y x
+ Darcs.Patch: invert :: Invert p => p wX wY -> p wY wX
- Darcs.Patch: invertFL :: Invert p => FL p x y -> RL p y x
+ Darcs.Patch: invertFL :: Invert p => FL p wX wY -> RL p wY wX
- Darcs.Patch: invertRL :: Invert p => RL p x y -> FL p y x
+ Darcs.Patch: invertRL :: Invert p => RL p wX wY -> FL p wY wX
- Darcs.Patch: isInconsistent :: Check p => p x y -> Maybe Doc
+ Darcs.Patch: isInconsistent :: Check p => p wX wY -> Maybe Doc
- Darcs.Patch: listConflictedFiles :: Conflict p => p x y -> [FilePath]
+ Darcs.Patch: listConflictedFiles :: Conflict p => p wX wY -> [FilePath]
- Darcs.Patch: listTouchedFiles :: PatchInspect p => p x y -> [FilePath]
+ Darcs.Patch: listTouchedFiles :: PatchInspect p => p wX wY -> [FilePath]
- Darcs.Patch: merge :: Merge p => (p :\/: p) x y -> (p :/\: p) x y
+ Darcs.Patch: merge :: Merge p => (p :\/: p) wX wY -> (p :/\: p) wX wY
- Darcs.Patch: move :: PrimConstruct prim => FilePath -> FilePath -> prim x y
+ Darcs.Patch: move :: PrimConstruct prim => FilePath -> FilePath -> prim wX wY
- Darcs.Patch: namepatch :: Patchy p => String -> String -> String -> [String] -> FL p x y -> IO (Named p x y)
+ Darcs.Patch: namepatch :: String -> String -> String -> [String] -> FL p wX wY -> IO (Named p wX wY)
- Darcs.Patch: patch2patchinfo :: Named p x y -> PatchInfo
+ Darcs.Patch: patch2patchinfo :: Named p wX wY -> PatchInfo
- Darcs.Patch: patchcontents :: Named p x y -> FL p x y
+ Darcs.Patch: patchcontents :: Named p wX wY -> FL p wX wY
- Darcs.Patch: patchname :: Named p x y -> String
+ Darcs.Patch: patchname :: Named p wX wY -> String
- Darcs.Patch: plainSummary :: (Conflict e, Effect e, PrimPatchBase e) => e x y -> Doc
+ Darcs.Patch: plainSummary :: (Conflict e, Effect e, PrimPatchBase e) => e wX wY -> Doc
- Darcs.Patch: plainSummaryPrims :: PrimDetails prim => FL prim x y -> Doc
+ Darcs.Patch: plainSummaryPrims :: PrimDetails prim => FL prim wX wY -> Doc
- Darcs.Patch: primIsAdddir :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch: primIsAdddir :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch: primIsAddfile :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch: primIsAddfile :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch: primIsBinary :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch: primIsBinary :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch: primIsHunk :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch: primIsHunk :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch: primIsSetpref :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch: primIsSetpref :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch: readPatch :: ReadPatch p => ByteString -> Maybe (Sealed (p x))
+ Darcs.Patch: readPatch :: ReadPatch p => ByteString -> Maybe (Sealed (p wX))
- Darcs.Patch: readPatchPartial :: ReadPatch p => ByteString -> Maybe (Sealed (p x), ByteString)
+ Darcs.Patch: readPatchPartial :: ReadPatch p => ByteString -> Maybe (Sealed (p wX), ByteString)
- Darcs.Patch: resolveConflicts :: Conflict p => p x y -> [[Sealed (FL (PrimOf p) y)]]
+ Darcs.Patch: resolveConflicts :: Conflict p => p wX wY -> [[Sealed (FL (PrimOf p) wY)]]
- Darcs.Patch: rmdir :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch: rmdir :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch: rmfile :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch: rmfile :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch: showContextPatch :: (ShowPatch p, Monad m, ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p)) => p x y -> m Doc
+ Darcs.Patch: showContextPatch :: (ShowPatch p, Monad m, ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p)) => p wX wY -> m Doc
- Darcs.Patch: showNicely :: ShowPatch p => p x y -> Doc
+ Darcs.Patch: showNicely :: ShowPatch p => p wX wY -> Doc
- Darcs.Patch: showPatch :: ShowPatchBasic p => p x y -> Doc
+ Darcs.Patch: showPatch :: ShowPatchBasic p => p wX wY -> Doc
- Darcs.Patch: sortCoalesceFL :: PrimCanonize prim => FL prim x y -> FL prim x y
+ Darcs.Patch: sortCoalesceFL :: PrimCanonize prim => FL prim wX wY -> FL prim wX wY
- Darcs.Patch: summary :: ShowPatch p => p x y -> Doc
+ Darcs.Patch: summary :: ShowPatch p => p wX wY -> Doc
- Darcs.Patch: summaryFL :: ShowPatch p => FL p x y -> Doc
+ Darcs.Patch: summaryFL :: ShowPatch p => FL p wX wY -> Doc
- Darcs.Patch: thing :: ShowPatch p => p x y -> String
+ Darcs.Patch: thing :: ShowPatch p => p wX wY -> String
- Darcs.Patch: things :: ShowPatch p => p x y -> String
+ Darcs.Patch: things :: ShowPatch p => p wX wY -> String
- Darcs.Patch: tokreplace :: PrimConstruct prim => FilePath -> String -> String -> String -> prim x y
+ Darcs.Patch: tokreplace :: PrimConstruct prim => FilePath -> String -> String -> String -> prim wX wY
- Darcs.Patch: tryToShrink :: PrimCanonize prim => FL prim x y -> FL prim x y
+ Darcs.Patch: tryToShrink :: PrimCanonize prim => FL prim wX wY -> FL prim wX wY
- Darcs.Patch: xmlSummary :: (Effect p, Conflict p, PrimPatchBase p) => p x y -> Doc
+ Darcs.Patch: xmlSummary :: (Effect p, Conflict p, PrimPatchBase p) => p wX wY -> Doc
- Darcs.Patch.Apply: apply :: (Apply p, ApplyMonad m (ApplyState p)) => p x y -> m ()
+ Darcs.Patch.Apply: apply :: (Apply p, ApplyMonad m (ApplyState p)) => p wX wY -> m ()
- Darcs.Patch.Apply: applyToFilePaths :: (Apply p, ApplyState p ~ Tree) => p x y -> Maybe [(FilePath, FilePath)] -> [FilePath] -> ([FilePath], [FilePath], [(FilePath, FilePath)])
+ Darcs.Patch.Apply: applyToFilePaths :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Maybe [(FilePath, FilePath)] -> [FilePath] -> ([FilePath], [FilePath], [(FilePath, FilePath)])
- Darcs.Patch.Apply: applyToState :: (Apply p, ApplyMonadTrans m (ApplyState p)) => p x y -> (ApplyState p) m -> m ((ApplyState p) m)
+ Darcs.Patch.Apply: applyToState :: (Apply p, ApplyMonadTrans m (ApplyState p)) => p wX wY -> (ApplyState p) m -> m ((ApplyState p) m)
- Darcs.Patch.Apply: applyToTree :: (Apply p, Functor m, Monad m, ApplyState p ~ Tree) => p x y -> Tree m -> m (Tree m)
+ Darcs.Patch.Apply: applyToTree :: (Apply p, Functor m, Monad m, ApplyState p ~ Tree) => p wX wY -> Tree m -> m (Tree m)
- Darcs.Patch.Apply: effectOnFilePaths :: (Apply p, ApplyState p ~ Tree) => p x y -> [FilePath] -> [FilePath]
+ Darcs.Patch.Apply: effectOnFilePaths :: (Apply p, ApplyState p ~ Tree) => p wX wY -> [FilePath] -> [FilePath]
- Darcs.Patch.ApplyMonad: withFileNames :: (Maybe [OrigFileNameOf]) -> [FileName] -> FilePathMonad a -> FilePathMonadState
+ Darcs.Patch.ApplyMonad: withFileNames :: Maybe [OrigFileNameOf] -> [FileName] -> FilePathMonad a -> FilePathMonadState
- Darcs.Patch.Bracketed: Braced :: BracketedFL p x y -> Bracketed p x y
+ Darcs.Patch.Bracketed: Braced :: BracketedFL p wX wY -> Bracketed p wX wY
- Darcs.Patch.Bracketed: Parens :: BracketedFL p x y -> Bracketed p x y
+ Darcs.Patch.Bracketed: Parens :: BracketedFL p wX wY -> Bracketed p wX wY
- Darcs.Patch.Bracketed: Singleton :: p x y -> Bracketed p x y
+ Darcs.Patch.Bracketed: Singleton :: p wX wY -> Bracketed p wX wY
- Darcs.Patch.Bracketed: data Bracketed p x y
+ Darcs.Patch.Bracketed: data Bracketed p wX wY
- Darcs.Patch.Bracketed: mapBracketed :: (forall a b. p a b -> q a b) -> Bracketed p x y -> Bracketed q x y
+ Darcs.Patch.Bracketed: mapBracketed :: (forall wA wB. p wA wB -> q wA wB) -> Bracketed p wX wY -> Bracketed q wX wY
- Darcs.Patch.Bracketed: type BracketedFL p x y = FL (Bracketed p) x y
+ Darcs.Patch.Bracketed: type BracketedFL p wX wY = FL (Bracketed p) wX wY
- Darcs.Patch.Bracketed: unBracketed :: Bracketed p x y -> FL p x y
+ Darcs.Patch.Bracketed: unBracketed :: Bracketed p wX wY -> FL p wX wY
- Darcs.Patch.Bracketed: unBracketedFL :: BracketedFL p x y -> FL p x y
+ Darcs.Patch.Bracketed: unBracketedFL :: BracketedFL p wX wY -> FL p wX wY
- Darcs.Patch.Bundle: contextPatches :: RepoPatch p => PatchSet p Origin x -> (PatchSet p :> (RL (PatchInfoAnd p))) Origin x
+ Darcs.Patch.Bundle: contextPatches :: RepoPatch p => PatchSet p Origin wX -> (PatchSet p :> RL (PatchInfoAnd p)) Origin wX
- Darcs.Patch.Bundle: hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (Named p) x y -> String
+ Darcs.Patch.Bundle: hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (Named p) wX wY -> String
- Darcs.Patch.Bundle: makeBundle2 :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO) -> RL (PatchInfoAnd p) start x -> FL (Named p) x y -> FL (Named p) x y -> IO Doc
+ Darcs.Patch.Bundle: makeBundle2 :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO) -> RL (PatchInfoAnd p) wStart wX -> FL (Named p) wX wY -> FL (Named p) wX wY -> IO Doc
- Darcs.Patch.Bundle: makeBundleN :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO) -> PatchSet p start x -> FL (Named p) x y -> IO Doc
+ Darcs.Patch.Bundle: makeBundleN :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO) -> PatchSet p wStart wX -> FL (Named p) wX wY -> IO Doc
- Darcs.Patch.Choices: data PatchChoices p x y
+ Darcs.Patch.Choices: data PatchChoices p wX wY
- Darcs.Patch.Choices: forceFirst :: Patchy p => Tag -> PatchChoices p a b -> PatchChoices p a b
+ Darcs.Patch.Choices: forceFirst :: Patchy p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB
- Darcs.Patch.Choices: forceFirsts :: Patchy p => [Tag] -> PatchChoices p a b -> PatchChoices p a b
+ Darcs.Patch.Choices: forceFirsts :: Patchy p => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB
- Darcs.Patch.Choices: forceLast :: Patchy p => Tag -> PatchChoices p a b -> PatchChoices p a b
+ Darcs.Patch.Choices: forceLast :: Patchy p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB
- Darcs.Patch.Choices: forceLasts :: Patchy p => [Tag] -> PatchChoices p a b -> PatchChoices p a b
+ Darcs.Patch.Choices: forceLasts :: Patchy p => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB
- Darcs.Patch.Choices: forceMatchingFirst :: Patchy p => (forall x y. TaggedPatch p x y -> Bool) -> PatchChoices p a b -> PatchChoices p a b
+ Darcs.Patch.Choices: forceMatchingFirst :: Patchy p => (forall wX wY. LabelledPatch p wX wY -> Bool) -> PatchChoices p wA wB -> PatchChoices p wA wB
- Darcs.Patch.Choices: forceMatchingLast :: Patchy p => (forall x y. TaggedPatch p x y -> Bool) -> PatchChoices p a b -> PatchChoices p a b
+ Darcs.Patch.Choices: forceMatchingLast :: Patchy p => (forall wX wY. LabelledPatch p wX wY -> Bool) -> PatchChoices p wA wB -> PatchChoices p wA wB
- Darcs.Patch.Choices: getChoices :: Patchy p => PatchChoices p x y -> (FL (TaggedPatch p) :> (FL (TaggedPatch p) :> FL (TaggedPatch p))) x y
+ Darcs.Patch.Choices: getChoices :: Patchy p => PatchChoices p wX wY -> (FL (LabelledPatch p) :> (FL (LabelledPatch p) :> FL (LabelledPatch p))) wX wY
- Darcs.Patch.Choices: makeEverythingLater :: Patchy p => PatchChoices p x y -> PatchChoices p x y
+ Darcs.Patch.Choices: makeEverythingLater :: Patchy p => PatchChoices p wX wY -> PatchChoices p wX wY
- Darcs.Patch.Choices: makeEverythingSooner :: Patchy p => PatchChoices p x y -> PatchChoices p x y
+ Darcs.Patch.Choices: makeEverythingSooner :: Patchy p => PatchChoices p wX wY -> PatchChoices p wX wY
- Darcs.Patch.Choices: makeUncertain :: Patchy p => Tag -> PatchChoices p a b -> PatchChoices p a b
+ Darcs.Patch.Choices: makeUncertain :: Patchy p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB
- Darcs.Patch.Choices: patchChoices :: Patchy p => FL p x y -> PatchChoices p x y
+ Darcs.Patch.Choices: patchChoices :: Patchy p => FL p wX wY -> PatchChoices p wX wY
- Darcs.Patch.Choices: patchSlot :: Patchy p => TaggedPatch p a b -> PatchChoices p x y -> (Slot, PatchChoices p x y)
+ Darcs.Patch.Choices: patchSlot :: Patchy p => LabelledPatch p wA wB -> PatchChoices p wX wY -> (Slot, PatchChoices p wX wY)
- Darcs.Patch.Choices: patchSlot' :: Patchy p => TaggedPatch p a b -> StateT (PatchChoices p x y) Identity Slot
+ Darcs.Patch.Choices: patchSlot' :: Patchy p => LabelledPatch p wA wB -> StateT (PatchChoices p wX wY) Identity Slot
- Darcs.Patch.Choices: refineChoices :: (Patchy p, Monad m, Functor m) => (forall u v. FL (TaggedPatch p) u v -> PatchChoices p u v -> m (PatchChoices p u v)) -> PatchChoices p x y -> m (PatchChoices p x y)
+ Darcs.Patch.Choices: refineChoices :: (Patchy p, Monad m, Functor m) => (forall wU wV. FL (LabelledPatch p) wU wV -> PatchChoices p wU wV -> m (PatchChoices p wU wV)) -> PatchChoices p wX wY -> m (PatchChoices p wX wY)
- Darcs.Patch.Choices: selectAllMiddles :: Patchy p => Bool -> PatchChoices p x y -> PatchChoices p x y
+ Darcs.Patch.Choices: selectAllMiddles :: Patchy p => Bool -> PatchChoices p wX wY -> PatchChoices p wX wY
- Darcs.Patch.Choices: separateFirstFromMiddleLast :: Patchy p => PatchChoices p x z -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) x z
+ Darcs.Patch.Choices: separateFirstFromMiddleLast :: Patchy p => PatchChoices p wX wZ -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ
- Darcs.Patch.Choices: separateFirstMiddleFromLast :: Patchy p => PatchChoices p x z -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) x z
+ Darcs.Patch.Choices: separateFirstMiddleFromLast :: Patchy p => PatchChoices p wX wZ -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ
- Darcs.Patch.Choices: substitute :: Patchy p => Sealed2 (TaggedPatch p :||: FL (TaggedPatch p)) -> PatchChoices p x y -> PatchChoices p x y
+ Darcs.Patch.Choices: substitute :: Patchy p => Sealed2 (LabelledPatch p :||: FL (LabelledPatch p)) -> PatchChoices p wX wY -> PatchChoices p wX wY
- Darcs.Patch.Commute: commute :: Commute p => (p :> p) x y -> Maybe ((p :> p) x y)
+ Darcs.Patch.Commute: commute :: Commute p => (p :> p) wX wY -> Maybe ((p :> p) wX wY)
- Darcs.Patch.Commute: commuteFL :: Commute p => (p :> FL p) x y -> Maybe ((FL p :> p) x y)
+ Darcs.Patch.Commute: commuteFL :: Commute p => (p :> FL p) wX wY -> Maybe ((FL p :> p) wX wY)
- Darcs.Patch.Commute: commuteFLorComplain :: Commute p => (p :> FL p) x y -> Either (Sealed2 p) ((FL p :> p) x y)
+ Darcs.Patch.Commute: commuteFLorComplain :: Commute p => (p :> FL p) wX wY -> Either (Sealed2 p) ((FL p :> p) wX wY)
- Darcs.Patch.Commute: commuteRL :: Commute p => (RL p :> p) x y -> Maybe ((p :> RL p) x y)
+ Darcs.Patch.Commute: commuteRL :: Commute p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY)
- Darcs.Patch.Commute: commuteRLFL :: Commute p => (RL p :> FL p) x y -> Maybe ((FL p :> RL p) x y)
+ Darcs.Patch.Commute: commuteRLFL :: Commute p => (RL p :> FL p) wX wY -> Maybe ((FL p :> RL p) wX wY)
- Darcs.Patch.Commute: toFwdCommute :: (Commute p, Commute q, Monad m) => ((p :< q) x y -> m ((q :< p) x y)) -> (q :> p) x y -> m ((p :> q) x y)
+ Darcs.Patch.Commute: toFwdCommute :: (Commute p, Commute q, Monad m) => ((p :< q) wX wY -> m ((q :< p) wX wY)) -> (q :> p) wX wY -> m ((p :> q) wX wY)
- Darcs.Patch.Commute: toRevCommute :: (Commute p, Commute q, Monad m) => ((p :> q) x y -> m ((q :> p) x y)) -> (q :< p) x y -> m ((p :< q) x y)
+ Darcs.Patch.Commute: toRevCommute :: (Commute p, Commute q, Monad m) => ((p :> q) wX wY -> m ((q :> p) wX wY)) -> (q :< p) wX wY -> m ((p :< q) wX wY)
- Darcs.Patch.Conflict: IsC :: !ConflictState -> !(prim x y) -> IsConflictedPrim prim
+ Darcs.Patch.Conflict: IsC :: !ConflictState -> !(prim wX wY) -> IsConflictedPrim prim
- Darcs.Patch.Conflict: class (Effect p, PatchInspect (PrimOf p)) => Conflict p where listConflictedFiles p = nubsort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p conflictedEffect x = case listConflictedFiles x of { [] -> mapFL (IsC Okay) $ effect x _ -> mapFL (IsC Conflicted) $ effect x }
+ Darcs.Patch.Conflict: class (Effect p, PatchInspect (PrimOf p)) => Conflict p where listConflictedFiles p = nubSort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p conflictedEffect x = case listConflictedFiles x of { [] -> mapFL (IsC Okay) $ effect x _ -> mapFL (IsC Conflicted) $ effect x }
- Darcs.Patch.Conflict: commuteNoConflicts :: CommuteNoConflicts p => (p :> p) x y -> Maybe ((p :> p) x y)
+ Darcs.Patch.Conflict: commuteNoConflicts :: CommuteNoConflicts p => (p :> p) wX wY -> Maybe ((p :> p) wX wY)
- Darcs.Patch.Conflict: conflictedEffect :: Conflict p => p x y -> [IsConflictedPrim (PrimOf p)]
+ Darcs.Patch.Conflict: conflictedEffect :: Conflict p => p wX wY -> [IsConflictedPrim (PrimOf p)]
- Darcs.Patch.Conflict: listConflictedFiles :: Conflict p => p x y -> [FilePath]
+ Darcs.Patch.Conflict: listConflictedFiles :: Conflict p => p wX wY -> [FilePath]
- Darcs.Patch.Conflict: resolveConflicts :: Conflict p => p x y -> [[Sealed (FL (PrimOf p) y)]]
+ Darcs.Patch.Conflict: resolveConflicts :: Conflict p => p wX wY -> [[Sealed (FL (PrimOf p) wY)]]
- Darcs.Patch.ConflictMarking: mangleUnravelled :: PrimPatch prim => [Sealed (FL prim x)] -> Sealed (FL prim x)
+ Darcs.Patch.ConflictMarking: mangleUnravelled :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (FL prim wX)
- Darcs.Patch.Depends: areUnrelatedRepos :: RepoPatch p => PatchSet p start x -> PatchSet p start y -> Bool
+ Darcs.Patch.Depends: areUnrelatedRepos :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> Bool
- Darcs.Patch.Depends: commuteToEnd :: RepoPatch p => RL (PatchInfoAnd p) x y -> PatchSet p start y -> (PatchSet p :> RL (PatchInfoAnd p)) start x
+ Darcs.Patch.Depends: commuteToEnd :: (Patchy p, NameHack p) => RL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY -> (PatchSet p :> RL (PatchInfoAnd p)) wStart wX
- Darcs.Patch.Depends: countUsThem :: RepoPatch p => PatchSet p start x -> PatchSet p start y -> (Int, Int)
+ Darcs.Patch.Depends: countUsThem :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> (Int, Int)
- Darcs.Patch.Depends: findCommonWithThem :: RepoPatch p => PatchSet p start x -> PatchSet p start y -> (PatchSet p :> FL (PatchInfoAnd p)) start x
+ Darcs.Patch.Depends: findCommonWithThem :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> (PatchSet p :> FL (PatchInfoAnd p)) wStart wX
- Darcs.Patch.Depends: findUncommon :: RepoPatch p => PatchSet p start x -> PatchSet p start y -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) x y
+ Darcs.Patch.Depends: findUncommon :: (Patchy p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wX wY
- Darcs.Patch.Depends: getPatchesBeyondTag :: RepoPatch p => PatchInfo -> PatchSet p start x -> FlippedSeal (RL (PatchInfoAnd p)) x
+ Darcs.Patch.Depends: getPatchesBeyondTag :: (Patchy p, NameHack p) => PatchInfo -> PatchSet p wStart wX -> FlippedSeal (RL (PatchInfoAnd p)) wX
- Darcs.Patch.Depends: merge2FL :: RepoPatch p => FL (PatchInfoAnd p) x y -> FL (PatchInfoAnd p) x z -> Sealed (FL (PatchInfoAnd p) y)
+ Darcs.Patch.Depends: merge2FL :: (Patchy p, Merge p, NameHack p) => FL (PatchInfoAnd p) wX wY -> FL (PatchInfoAnd p) wX wZ -> (FL (PatchInfoAnd p) :/\: FL (PatchInfoAnd p)) wY wZ
- Darcs.Patch.Depends: mergeThem :: RepoPatch p => PatchSet p start x -> PatchSet p start y -> Sealed (FL (PatchInfoAnd p) x)
+ Darcs.Patch.Depends: mergeThem :: (Patchy p, Merge p, NameHack p) => PatchSet p wStart wX -> PatchSet p wStart wY -> Sealed (FL (PatchInfoAnd p) wX)
- Darcs.Patch.Depends: newsetIntersection :: RepoPatch p => [SealedPatchSet p start] -> SealedPatchSet p start
+ Darcs.Patch.Depends: newsetIntersection :: (Patchy p, NameHack p) => [SealedPatchSet p wStart] -> SealedPatchSet p wStart
- Darcs.Patch.Depends: newsetUnion :: RepoPatch p => [SealedPatchSet p start] -> SealedPatchSet p start
+ Darcs.Patch.Depends: newsetUnion :: (Patchy p, Merge p, NameHack p) => [SealedPatchSet p wStart] -> SealedPatchSet p wStart
- Darcs.Patch.Depends: removeFromPatchSet :: RepoPatch p => FL (PatchInfoAnd p) x y -> PatchSet p start y -> Maybe (PatchSet p start x)
+ Darcs.Patch.Depends: removeFromPatchSet :: (Patchy p, NameHack p) => FL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY -> Maybe (PatchSet p wStart wX)
- Darcs.Patch.Depends: slightlyOptimizePatchset :: PatchSet p start x -> PatchSet p start x
+ Darcs.Patch.Depends: slightlyOptimizePatchset :: PatchSet p wStart wX -> PatchSet p wStart wX
- Darcs.Patch.Depends: splitOnTag :: RepoPatch p => PatchInfo -> PatchSet p start x -> (PatchSet p :> RL (PatchInfoAnd p)) start x
+ Darcs.Patch.Depends: splitOnTag :: (Patchy p, NameHack p) => PatchInfo -> PatchSet p wStart wX -> Maybe ((PatchSet p :> RL (PatchInfoAnd p)) wStart wX)
- Darcs.Patch.Dummy: data DummyPatch x y
+ Darcs.Patch.Dummy: data DummyPatch wX wY
- Darcs.Patch.Effect: effect :: Effect p => p x y -> FL (PrimOf p) x y
+ Darcs.Patch.Effect: effect :: Effect p => p wX wY -> FL (PrimOf p) wX wY
- Darcs.Patch.Effect: effectRL :: Effect p => p x y -> RL (PrimOf p) x y
+ Darcs.Patch.Effect: effectRL :: Effect p => p wX wY -> RL (PrimOf p) wX wY
- Darcs.Patch.FileHunk: FileHunk :: !FileName -> !Int -> [ByteString] -> [ByteString] -> FileHunk x y
+ Darcs.Patch.FileHunk: FileHunk :: !FileName -> !Int -> [ByteString] -> [ByteString] -> FileHunk wX wY
- Darcs.Patch.FileHunk: data FileHunk x y
+ Darcs.Patch.FileHunk: data FileHunk wX wY
- Darcs.Patch.FileHunk: isHunk :: IsHunk p => p x y -> Maybe (FileHunk x y)
+ Darcs.Patch.FileHunk: isHunk :: IsHunk p => p wX wY -> Maybe (FileHunk wX wY)
- Darcs.Patch.FileHunk: showFileHunk :: FileNameFormat -> FileHunk x y -> Doc
+ Darcs.Patch.FileHunk: showFileHunk :: FileNameFormat -> FileHunk wX wY -> Doc
- Darcs.Patch.Info: makePatchname :: PatchInfo -> String
+ Darcs.Patch.Info: makePatchname :: PatchInfo -> SHA1
- Darcs.Patch.Info: readPatchInfo :: ParserM m => m (PatchInfo)
+ Darcs.Patch.Info: readPatchInfo :: ParserM m => m PatchInfo
- Darcs.Patch.Inspect: hunkMatches :: PatchInspect p => (ByteString -> Bool) -> p x y -> Bool
+ Darcs.Patch.Inspect: hunkMatches :: PatchInspect p => (ByteString -> Bool) -> p wX wY -> Bool
- Darcs.Patch.Inspect: listTouchedFiles :: PatchInspect p => p x y -> [FilePath]
+ Darcs.Patch.Inspect: listTouchedFiles :: PatchInspect p => p wX wY -> [FilePath]
- Darcs.Patch.Invert: invert :: Invert p => p x y -> p y x
+ Darcs.Patch.Invert: invert :: Invert p => p wX wY -> p wY wX
- Darcs.Patch.Invert: invertFL :: Invert p => FL p x y -> RL p y x
+ Darcs.Patch.Invert: invertFL :: Invert p => FL p wX wY -> RL p wY wX
- Darcs.Patch.Invert: invertRL :: Invert p => RL p x y -> FL p y x
+ Darcs.Patch.Invert: invertRL :: Invert p => RL p wX wY -> FL p wY wX
- Darcs.Patch.Match: helpOnMatchers :: String
+ Darcs.Patch.Match: helpOnMatchers :: [String]
- Darcs.Patch.Match: matchParser :: Patchy p => CharParser st (MatchFun p)
+ Darcs.Patch.Match: matchParser :: Matchable p => CharParser st (MatchFun p)
- Darcs.Patch.Merge: merge :: Merge p => (p :\/: p) x y -> (p :/\: p) x y
+ Darcs.Patch.Merge: merge :: Merge p => (p :\/: p) wX wY -> (p :/\: p) wX wY
- Darcs.Patch.Merge: mergeFL :: Merge p => (p :\/: FL p) x y -> (FL p :/\: p) x y
+ Darcs.Patch.Merge: mergeFL :: Merge p => (p :\/: FL p) wX wY -> (FL p :/\: p) wX wY
- Darcs.Patch.Named: NamedP :: !PatchInfo -> ![PatchInfo] -> !(FL p x y) -> Named p x y
+ Darcs.Patch.Named: NamedP :: !PatchInfo -> ![PatchInfo] -> !(FL p wX wY) -> Named p wX wY
- Darcs.Patch.Named: adddeps :: Named p x y -> [PatchInfo] -> Named p x y
+ Darcs.Patch.Named: adddeps :: Named p wX wY -> [PatchInfo] -> Named p wX wY
- Darcs.Patch.Named: anonymous :: Patchy p => FL p x y -> IO (Named p x y)
+ Darcs.Patch.Named: anonymous :: FL p wX wY -> IO (Named p wX wY)
- Darcs.Patch.Named: data Named p x y
+ Darcs.Patch.Named: data Named p wX wY
- Darcs.Patch.Named: fmapFL_Named :: (FL p x y -> FL q x y) -> Named p x y -> Named q x y
+ Darcs.Patch.Named: fmapFL_Named :: (FL p wA wB -> FL q wC wD) -> Named p wA wB -> Named q wC wD
- Darcs.Patch.Named: fmapNamed :: (forall a b. p a b -> q a b) -> Named p x y -> Named q x y
+ Darcs.Patch.Named: fmapNamed :: (forall wA wB. p wA wB -> q wA wB) -> Named p wX wY -> Named q wX wY
- Darcs.Patch.Named: getdeps :: Named p x y -> [PatchInfo]
+ Darcs.Patch.Named: getdeps :: Named p wX wY -> [PatchInfo]
- Darcs.Patch.Named: infopatch :: Patchy p => PatchInfo -> FL p x y -> Named p x y
+ Darcs.Patch.Named: infopatch :: PatchInfo -> FL p wX wY -> Named p wX wY
- Darcs.Patch.Named: namepatch :: Patchy p => String -> String -> String -> [String] -> FL p x y -> IO (Named p x y)
+ Darcs.Patch.Named: namepatch :: String -> String -> String -> [String] -> FL p wX wY -> IO (Named p wX wY)
- Darcs.Patch.Named: patch2patchinfo :: Named p x y -> PatchInfo
+ Darcs.Patch.Named: patch2patchinfo :: Named p wX wY -> PatchInfo
- Darcs.Patch.Named: patchcontents :: Named p x y -> FL p x y
+ Darcs.Patch.Named: patchcontents :: Named p wX wY -> FL p wX wY
- Darcs.Patch.Named: patchname :: Named p x y -> String
+ Darcs.Patch.Named: patchname :: Named p wX wY -> String
- Darcs.Patch.PatchInfoAnd: actually :: a x y -> Hopefully a x y
+ Darcs.Patch.PatchInfoAnd: actually :: a wX wY -> Hopefully a wX wY
- Darcs.Patch.PatchInfoAnd: compareWPatchInfo :: WPatchInfo a b -> WPatchInfo c d -> EqCheck (a, b) (c, d)
+ Darcs.Patch.PatchInfoAnd: compareWPatchInfo :: WPatchInfo wA wB -> WPatchInfo wC wD -> EqCheck (wA, wB) (wC, wD)
- Darcs.Patch.PatchInfoAnd: conscientiously :: (Doc -> Doc) -> PatchInfoAnd p a b -> Named p a b
+ Darcs.Patch.PatchInfoAnd: conscientiously :: (Doc -> Doc) -> PatchInfoAnd p wA wB -> Named p wA wB
- Darcs.Patch.PatchInfoAnd: createHashed :: String -> (String -> IO (Sealed (a x))) -> IO (Sealed (Hopefully a x))
+ Darcs.Patch.PatchInfoAnd: createHashed :: String -> (String -> IO (Sealed (a wX))) -> IO (Sealed (Hopefully a wX))
- Darcs.Patch.PatchInfoAnd: data Hopefully a x y
+ Darcs.Patch.PatchInfoAnd: data Hopefully a wX wY
- Darcs.Patch.PatchInfoAnd: data PatchInfoAnd p a b
+ Darcs.Patch.PatchInfoAnd: data PatchInfoAnd p wA wB
- Darcs.Patch.PatchInfoAnd: data WPatchInfo a b
+ Darcs.Patch.PatchInfoAnd: data WPatchInfo wA wB
- Darcs.Patch.PatchInfoAnd: extractHash :: PatchInfoAnd p a b -> Either (Named p a b) String
+ Darcs.Patch.PatchInfoAnd: extractHash :: PatchInfoAnd p wA wB -> Either (Named p wA wB) String
- Darcs.Patch.PatchInfoAnd: fmapPIAP :: (forall a b. p a b -> q a b) -> PatchInfoAnd p x y -> PatchInfoAnd q x y
+ Darcs.Patch.PatchInfoAnd: fmapPIAP :: (forall wA wB. p wA wB -> q wA wB) -> PatchInfoAnd p wX wY -> PatchInfoAnd q wX wY
- Darcs.Patch.PatchInfoAnd: hopefully :: PatchInfoAnd p a b -> Named p a b
+ Darcs.Patch.PatchInfoAnd: hopefully :: PatchInfoAnd p wA wB -> Named p wA wB
- Darcs.Patch.PatchInfoAnd: hopefullyM :: Monad m => PatchInfoAnd p a b -> m (Named p a b)
+ Darcs.Patch.PatchInfoAnd: hopefullyM :: Monad m => PatchInfoAnd p wA wB -> m (Named p wA wB)
- Darcs.Patch.PatchInfoAnd: info :: PatchInfoAnd p a b -> PatchInfo
+ Darcs.Patch.PatchInfoAnd: info :: PatchInfoAnd p wA wB -> PatchInfo
- Darcs.Patch.PatchInfoAnd: n2pia :: Named p x y -> PatchInfoAnd p x y
+ Darcs.Patch.PatchInfoAnd: n2pia :: Named p wX wY -> PatchInfoAnd p wX wY
- Darcs.Patch.PatchInfoAnd: patchDesc :: PatchInfoAnd p x y -> String
+ Darcs.Patch.PatchInfoAnd: patchDesc :: PatchInfoAnd p wX wY -> String
- Darcs.Patch.PatchInfoAnd: patchInfoAndPatch :: PatchInfo -> Hopefully (Named p) a b -> PatchInfoAnd p a b
+ Darcs.Patch.PatchInfoAnd: patchInfoAndPatch :: PatchInfo -> Hopefully (Named p) wA wB -> PatchInfoAnd p wA wB
- Darcs.Patch.PatchInfoAnd: piap :: PatchInfo -> Named p a b -> PatchInfoAnd p a b
+ Darcs.Patch.PatchInfoAnd: piap :: PatchInfo -> Named p wA wB -> PatchInfoAnd p wA wB
- Darcs.Patch.PatchInfoAnd: unWPatchInfo :: WPatchInfo a b -> PatchInfo
+ Darcs.Patch.PatchInfoAnd: unWPatchInfo :: WPatchInfo wA wB -> PatchInfo
- Darcs.Patch.PatchInfoAnd: unavailable :: String -> Hopefully a x y
+ Darcs.Patch.PatchInfoAnd: unavailable :: String -> Hopefully a wX wY
- Darcs.Patch.PatchInfoAnd: winfo :: PatchInfoAnd p a b -> WPatchInfo a b
+ Darcs.Patch.PatchInfoAnd: winfo :: PatchInfoAnd p wA wB -> WPatchInfo wA wB
- Darcs.Patch.Patchy: apply :: (Apply p, ApplyMonad m (ApplyState p)) => p x y -> m ()
+ Darcs.Patch.Patchy: apply :: (Apply p, ApplyMonad m (ApplyState p)) => p wX wY -> m ()
- Darcs.Patch.Patchy: class (MyEq p, Apply p, Commute p, PatchInspect p, ShowPatch p, ReadPatch p, Invert p) => Patchy p
+ Darcs.Patch.Patchy: class (Apply p, Commute p, Invert p) => Patchy p
- Darcs.Patch.Patchy: commute :: Commute p => (p :> p) x y -> Maybe ((p :> p) x y)
+ Darcs.Patch.Patchy: commute :: Commute p => (p :> p) wX wY -> Maybe ((p :> p) wX wY)
- Darcs.Patch.Patchy: description :: ShowPatch p => p x y -> Doc
+ Darcs.Patch.Patchy: description :: ShowPatch p => p wX wY -> Doc
- Darcs.Patch.Patchy: hunkMatches :: PatchInspect p => (ByteString -> Bool) -> p x y -> Bool
+ Darcs.Patch.Patchy: hunkMatches :: PatchInspect p => (ByteString -> Bool) -> p wX wY -> Bool
- Darcs.Patch.Patchy: invert :: Invert p => p x y -> p y x
+ Darcs.Patch.Patchy: invert :: Invert p => p wX wY -> p wY wX
- Darcs.Patch.Patchy: listTouchedFiles :: PatchInspect p => p x y -> [FilePath]
+ Darcs.Patch.Patchy: listTouchedFiles :: PatchInspect p => p wX wY -> [FilePath]
- Darcs.Patch.Patchy: readPatch' :: (ReadPatch p, ParserM m) => m (Sealed (p x))
+ Darcs.Patch.Patchy: readPatch' :: (ReadPatch p, ParserM m) => m (Sealed (p wX))
- Darcs.Patch.Patchy: showContextPatch :: (ShowPatch p, Monad m, ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p)) => p x y -> m Doc
+ Darcs.Patch.Patchy: showContextPatch :: (ShowPatch p, Monad m, ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p)) => p wX wY -> m Doc
- Darcs.Patch.Patchy: showNicely :: ShowPatch p => p x y -> Doc
+ Darcs.Patch.Patchy: showNicely :: ShowPatch p => p wX wY -> Doc
- Darcs.Patch.Patchy: showPatch :: ShowPatchBasic p => p x y -> Doc
+ Darcs.Patch.Patchy: showPatch :: ShowPatchBasic p => p wX wY -> Doc
- Darcs.Patch.Patchy: summary :: ShowPatch p => p x y -> Doc
+ Darcs.Patch.Patchy: summary :: ShowPatch p => p wX wY -> Doc
- Darcs.Patch.Patchy: summaryFL :: ShowPatch p => FL p x y -> Doc
+ Darcs.Patch.Patchy: summaryFL :: ShowPatch p => FL p wX wY -> Doc
- Darcs.Patch.Patchy: thing :: ShowPatch p => p x y -> String
+ Darcs.Patch.Patchy: thing :: ShowPatch p => p wX wY -> String
- Darcs.Patch.Patchy: things :: ShowPatch p => p x y -> String
+ Darcs.Patch.Patchy: things :: ShowPatch p => p wX wY -> String
- Darcs.Patch.Permutations: commuteWhatWeCanFL :: Commute p => (p :> FL p) x y -> (FL p :> (p :> FL p)) x y
+ Darcs.Patch.Permutations: commuteWhatWeCanFL :: Commute p => (p :> FL p) wX wY -> (FL p :> (p :> FL p)) wX wY
- Darcs.Patch.Permutations: commuteWhatWeCanRL :: Commute p => (RL p :> p) x y -> (RL p :> (p :> RL p)) x y
+ Darcs.Patch.Permutations: commuteWhatWeCanRL :: Commute p => (RL p :> p) wX wY -> (RL p :> (p :> RL p)) wX wY
- Darcs.Patch.Permutations: genCommuteWhatWeCanRL :: (forall a b. (p :> p) a b -> Maybe ((p :> p) a b)) -> (RL p :> p) x y -> (RL p :> (p :> RL p)) x y
+ Darcs.Patch.Permutations: genCommuteWhatWeCanRL :: Commute p => (forall wA wB. (p :> q) wA wB -> Maybe ((q :> p) wA wB)) -> (RL p :> q) wX wY -> (RL p :> (q :> RL p)) wX wY
- Darcs.Patch.Permutations: headPermutationsFL :: Commute p => FL p x y -> [(p :> FL p) x y]
+ Darcs.Patch.Permutations: headPermutationsFL :: Commute p => FL p wX wY -> [(p :> FL p) wX wY]
- Darcs.Patch.Permutations: headPermutationsRL :: Commute p => RL p x y -> [RL p x y]
+ Darcs.Patch.Permutations: headPermutationsRL :: Commute p => RL p wX wY -> [RL p wX wY]
- Darcs.Patch.Permutations: partitionConflictingFL :: (Commute p1, Invert p1) => CommuteFn p1 p2 -> FL p1 x y -> p2 x z -> (FL p1 :> FL p1) x y
+ Darcs.Patch.Permutations: partitionConflictingFL :: (Commute p1, Invert p1) => CommuteFn p1 p2 -> FL p1 wX wY -> p2 wX wZ -> (FL p1 :> FL p1) wX wY
- Darcs.Patch.Permutations: partitionFL :: Commute p => (forall u v. p u v -> Bool) -> FL p x y -> ((FL p :> (FL p :> FL p)) x y)
+ Darcs.Patch.Permutations: partitionFL :: Commute p => (forall wU wV. p wU wV -> Bool) -> FL p wX wY -> (FL p :> (FL p :> FL p)) wX wY
- Darcs.Patch.Permutations: partitionRL :: Commute p => (forall u v. p u v -> Bool) -> RL p x y -> (RL p :> RL p) x y
+ Darcs.Patch.Permutations: partitionRL :: Commute p => (forall wU wV. p wU wV -> Bool) -> RL p wX wY -> (RL p :> RL p) wX wY
- Darcs.Patch.Permutations: removeCommon :: (MyEq p, Commute p) => (FL p :\/: FL p) x y -> (FL p :\/: FL p) x y
+ Darcs.Patch.Permutations: removeCommon :: (MyEq p, Commute p) => (FL p :\/: FL p) wX wY -> (FL p :\/: FL p) wX wY
- Darcs.Patch.Permutations: removeFL :: (MyEq p, Commute p) => p x y -> FL p x z -> Maybe (FL p y z)
+ Darcs.Patch.Permutations: removeFL :: (MyEq p, Commute p) => p wX wY -> FL p wX wZ -> Maybe (FL p wY wZ)
- Darcs.Patch.Permutations: removeRL :: (MyEq p, Commute p) => p y z -> RL p x z -> Maybe (RL p x y)
+ Darcs.Patch.Permutations: removeRL :: (MyEq p, Commute p) => p wY wZ -> RL p wX wZ -> Maybe (RL p wX wY)
- Darcs.Patch.Permutations: removeSubsequenceFL :: (MyEq p, Commute p) => FL p a b -> FL p a c -> Maybe (FL p b c)
+ Darcs.Patch.Permutations: removeSubsequenceFL :: (MyEq p, Commute p) => FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC)
- Darcs.Patch.Permutations: removeSubsequenceRL :: (MyEq p, Commute p) => RL p ab abc -> RL p a abc -> Maybe (RL p a ab)
+ Darcs.Patch.Permutations: removeSubsequenceRL :: (MyEq p, Commute p) => RL p wAb wAbc -> RL p wA wAbc -> Maybe (RL p wA wAb)
- Darcs.Patch.Permutations: simpleHeadPermutationsFL :: Commute p => FL p x y -> [FL p x y]
+ Darcs.Patch.Permutations: simpleHeadPermutationsFL :: Commute p => FL p wX wY -> [FL p wX wY]
- Darcs.Patch.Prim: adddir :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch.Prim: adddir :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch.Prim: addfile :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch.Prim: addfile :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch.Prim: anIdentity :: PrimConstruct prim => prim x x
+ Darcs.Patch.Prim: anIdentity :: PrimConstruct prim => prim wX wX
- Darcs.Patch.Prim: applyPrimFL :: (PrimApply prim, ApplyMonad m (ApplyState prim)) => FL prim x y -> m ()
+ Darcs.Patch.Prim: applyPrimFL :: (PrimApply prim, ApplyMonad m (ApplyState prim)) => FL prim wX wY -> m ()
- Darcs.Patch.Prim: binary :: PrimConstruct prim => FilePath -> ByteString -> ByteString -> prim x y
+ Darcs.Patch.Prim: binary :: PrimConstruct prim => FilePath -> ByteString -> ByteString -> prim wX wY
- Darcs.Patch.Prim: canonize :: PrimCanonize prim => prim x y -> FL prim x y
+ Darcs.Patch.Prim: canonize :: PrimCanonize prim => DiffAlgorithm -> prim wX wY -> FL prim wX wY
- Darcs.Patch.Prim: canonizeFL :: PrimCanonize prim => FL prim x y -> FL prim x y
+ Darcs.Patch.Prim: canonizeFL :: PrimCanonize prim => DiffAlgorithm -> FL prim wX wY -> FL prim wX wY
- Darcs.Patch.Prim: changepref :: PrimConstruct prim => String -> String -> String -> prim x y
+ Darcs.Patch.Prim: changepref :: PrimConstruct prim => String -> String -> String -> prim wX wY
- Darcs.Patch.Prim: class (Patchy prim, PatchListFormat prim, IsHunk prim, RepairToFL prim, PrimConstruct prim, PrimCanonize prim, PrimClassify prim, PrimDetails prim, PrimShow prim, PrimRead prim, PrimApply prim) => PrimPatch prim
+ Darcs.Patch.Prim: class (Patchy prim, MyEq prim, PatchListFormat prim, IsHunk prim, RepairToFL prim, PatchInspect prim, ReadPatch prim, ShowPatch prim, PrimConstruct prim, PrimCanonize prim, PrimClassify prim, PrimDetails prim, PrimShow prim, PrimRead prim, PrimApply prim) => PrimPatch prim
- Darcs.Patch.Prim: fromPrim :: FromPrim p => PrimOf p x y -> p x y
+ Darcs.Patch.Prim: fromPrim :: FromPrim p => PrimOf p wX wY -> p wX wY
- Darcs.Patch.Prim: fromPrims :: FromPrims p => FL (PrimOf p) x y -> p x y
+ Darcs.Patch.Prim: fromPrims :: FromPrims p => FL (PrimOf p) wX wY -> p wX wY
- Darcs.Patch.Prim: hunk :: PrimConstruct prim => FilePath -> Int -> [ByteString] -> [ByteString] -> prim x y
+ Darcs.Patch.Prim: hunk :: PrimConstruct prim => FilePath -> Int -> [ByteString] -> [ByteString] -> prim wX wY
- Darcs.Patch.Prim: is_filepatch :: PrimClassify prim => prim x y -> Maybe FileName
+ Darcs.Patch.Prim: is_filepatch :: PrimClassify prim => prim wX wY -> Maybe FileName
- Darcs.Patch.Prim: move :: PrimConstruct prim => FilePath -> FilePath -> prim x y
+ Darcs.Patch.Prim: move :: PrimConstruct prim => FilePath -> FilePath -> prim wX wY
- Darcs.Patch.Prim: primFromHunk :: PrimConstruct prim => FileHunk x y -> prim x y
+ Darcs.Patch.Prim: primFromHunk :: PrimConstruct prim => FileHunk wX wY -> prim wX wY
- Darcs.Patch.Prim: primIsAdddir :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim: primIsAdddir :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim: primIsAddfile :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim: primIsAddfile :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim: primIsBinary :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim: primIsBinary :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim: primIsHunk :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim: primIsHunk :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim: primIsSetpref :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim: primIsSetpref :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim: readPrim :: (PrimRead prim, ParserM m) => FileNameFormat -> m (Sealed (prim x))
+ Darcs.Patch.Prim: readPrim :: (PrimRead prim, ParserM m) => FileNameFormat -> m (Sealed (prim wX))
- Darcs.Patch.Prim: rmdir :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch.Prim: rmdir :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch.Prim: rmfile :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch.Prim: rmfile :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch.Prim: showPrim :: PrimShow prim => FileNameFormat -> prim a b -> Doc
+ Darcs.Patch.Prim: showPrim :: PrimShow prim => FileNameFormat -> prim wA wB -> Doc
- Darcs.Patch.Prim: showPrimFL :: PrimShow prim => FileNameFormat -> FL prim a b -> Doc
+ Darcs.Patch.Prim: showPrimFL :: PrimShow prim => FileNameFormat -> FL prim wA wB -> Doc
- Darcs.Patch.Prim: sortCoalesceFL :: PrimCanonize prim => FL prim x y -> FL prim x y
+ Darcs.Patch.Prim: sortCoalesceFL :: PrimCanonize prim => FL prim wX wY -> FL prim wX wY
- Darcs.Patch.Prim: summarizePrim :: PrimDetails prim => prim x y -> [SummDetail]
+ Darcs.Patch.Prim: summarizePrim :: PrimDetails prim => prim wX wY -> [SummDetail]
- Darcs.Patch.Prim: toPrim :: ToFromPrim p => p x y -> Maybe (PrimOf p x y)
+ Darcs.Patch.Prim: toPrim :: ToFromPrim p => p wX wY -> Maybe (PrimOf p wX wY)
- Darcs.Patch.Prim: tokreplace :: PrimConstruct prim => FilePath -> String -> String -> String -> prim x y
+ Darcs.Patch.Prim: tokreplace :: PrimConstruct prim => FilePath -> String -> String -> String -> prim wX wY
- Darcs.Patch.Prim: tryShrinkingInverse :: PrimCanonize prim => FL prim x y -> Maybe (FL prim x y)
+ Darcs.Patch.Prim: tryShrinkingInverse :: PrimCanonize prim => FL prim wX wY -> Maybe (FL prim wX wY)
- Darcs.Patch.Prim: tryToShrink :: PrimCanonize prim => FL prim x y -> FL prim x y
+ Darcs.Patch.Prim: tryToShrink :: PrimCanonize prim => FL prim wX wY -> FL prim wX wY
- Darcs.Patch.Prim.Class: adddir :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch.Prim.Class: adddir :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch.Prim.Class: addfile :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch.Prim.Class: addfile :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch.Prim.Class: anIdentity :: PrimConstruct prim => prim x x
+ Darcs.Patch.Prim.Class: anIdentity :: PrimConstruct prim => prim wX wX
- Darcs.Patch.Prim.Class: applyPrimFL :: (PrimApply prim, ApplyMonad m (ApplyState prim)) => FL prim x y -> m ()
+ Darcs.Patch.Prim.Class: applyPrimFL :: (PrimApply prim, ApplyMonad m (ApplyState prim)) => FL prim wX wY -> m ()
- Darcs.Patch.Prim.Class: binary :: PrimConstruct prim => FilePath -> ByteString -> ByteString -> prim x y
+ Darcs.Patch.Prim.Class: binary :: PrimConstruct prim => FilePath -> ByteString -> ByteString -> prim wX wY
- Darcs.Patch.Prim.Class: canonize :: PrimCanonize prim => prim x y -> FL prim x y
+ Darcs.Patch.Prim.Class: canonize :: PrimCanonize prim => DiffAlgorithm -> prim wX wY -> FL prim wX wY
- Darcs.Patch.Prim.Class: canonizeFL :: PrimCanonize prim => FL prim x y -> FL prim x y
+ Darcs.Patch.Prim.Class: canonizeFL :: PrimCanonize prim => DiffAlgorithm -> FL prim wX wY -> FL prim wX wY
- Darcs.Patch.Prim.Class: changepref :: PrimConstruct prim => String -> String -> String -> prim x y
+ Darcs.Patch.Prim.Class: changepref :: PrimConstruct prim => String -> String -> String -> prim wX wY
- Darcs.Patch.Prim.Class: class (Patchy prim, PatchListFormat prim, IsHunk prim, RepairToFL prim, PrimConstruct prim, PrimCanonize prim, PrimClassify prim, PrimDetails prim, PrimShow prim, PrimRead prim, PrimApply prim) => PrimPatch prim
+ Darcs.Patch.Prim.Class: class (Patchy prim, MyEq prim, PatchListFormat prim, IsHunk prim, RepairToFL prim, PatchInspect prim, ReadPatch prim, ShowPatch prim, PrimConstruct prim, PrimCanonize prim, PrimClassify prim, PrimDetails prim, PrimShow prim, PrimRead prim, PrimApply prim) => PrimPatch prim
- Darcs.Patch.Prim.Class: fromPrim :: FromPrim p => PrimOf p x y -> p x y
+ Darcs.Patch.Prim.Class: fromPrim :: FromPrim p => PrimOf p wX wY -> p wX wY
- Darcs.Patch.Prim.Class: fromPrims :: FromPrims p => FL (PrimOf p) x y -> p x y
+ Darcs.Patch.Prim.Class: fromPrims :: FromPrims p => FL (PrimOf p) wX wY -> p wX wY
- Darcs.Patch.Prim.Class: hunk :: PrimConstruct prim => FilePath -> Int -> [ByteString] -> [ByteString] -> prim x y
+ Darcs.Patch.Prim.Class: hunk :: PrimConstruct prim => FilePath -> Int -> [ByteString] -> [ByteString] -> prim wX wY
- Darcs.Patch.Prim.Class: is_filepatch :: PrimClassify prim => prim x y -> Maybe FileName
+ Darcs.Patch.Prim.Class: is_filepatch :: PrimClassify prim => prim wX wY -> Maybe FileName
- Darcs.Patch.Prim.Class: move :: PrimConstruct prim => FilePath -> FilePath -> prim x y
+ Darcs.Patch.Prim.Class: move :: PrimConstruct prim => FilePath -> FilePath -> prim wX wY
- Darcs.Patch.Prim.Class: primFromHunk :: PrimConstruct prim => FileHunk x y -> prim x y
+ Darcs.Patch.Prim.Class: primFromHunk :: PrimConstruct prim => FileHunk wX wY -> prim wX wY
- Darcs.Patch.Prim.Class: primIsAdddir :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim.Class: primIsAdddir :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim.Class: primIsAddfile :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim.Class: primIsAddfile :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim.Class: primIsBinary :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim.Class: primIsBinary :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim.Class: primIsHunk :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim.Class: primIsHunk :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim.Class: primIsMove :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim.Class: primIsMove :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim.Class: primIsRmdir :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim.Class: primIsRmdir :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim.Class: primIsRmfile :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim.Class: primIsRmfile :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim.Class: primIsSetpref :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim.Class: primIsSetpref :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim.Class: primIsTokReplace :: PrimClassify prim => prim x y -> Bool
+ Darcs.Patch.Prim.Class: primIsTokReplace :: PrimClassify prim => prim wX wY -> Bool
- Darcs.Patch.Prim.Class: readPrim :: (PrimRead prim, ParserM m) => FileNameFormat -> m (Sealed (prim x))
+ Darcs.Patch.Prim.Class: readPrim :: (PrimRead prim, ParserM m) => FileNameFormat -> m (Sealed (prim wX))
- Darcs.Patch.Prim.Class: rmdir :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch.Prim.Class: rmdir :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch.Prim.Class: rmfile :: PrimConstruct prim => FilePath -> prim x y
+ Darcs.Patch.Prim.Class: rmfile :: PrimConstruct prim => FilePath -> prim wX wY
- Darcs.Patch.Prim.Class: showPrim :: PrimShow prim => FileNameFormat -> prim a b -> Doc
+ Darcs.Patch.Prim.Class: showPrim :: PrimShow prim => FileNameFormat -> prim wA wB -> Doc
- Darcs.Patch.Prim.Class: showPrimFL :: PrimShow prim => FileNameFormat -> FL prim a b -> Doc
+ Darcs.Patch.Prim.Class: showPrimFL :: PrimShow prim => FileNameFormat -> FL prim wA wB -> Doc
- Darcs.Patch.Prim.Class: sortCoalesceFL :: PrimCanonize prim => FL prim x y -> FL prim x y
+ Darcs.Patch.Prim.Class: sortCoalesceFL :: PrimCanonize prim => FL prim wX wY -> FL prim wX wY
- Darcs.Patch.Prim.Class: summarizePrim :: PrimDetails prim => prim x y -> [SummDetail]
+ Darcs.Patch.Prim.Class: summarizePrim :: PrimDetails prim => prim wX wY -> [SummDetail]
- Darcs.Patch.Prim.Class: toPrim :: ToFromPrim p => p x y -> Maybe (PrimOf p x y)
+ Darcs.Patch.Prim.Class: toPrim :: ToFromPrim p => p wX wY -> Maybe (PrimOf p wX wY)
- Darcs.Patch.Prim.Class: tokreplace :: PrimConstruct prim => FilePath -> String -> String -> String -> prim x y
+ Darcs.Patch.Prim.Class: tokreplace :: PrimConstruct prim => FilePath -> String -> String -> String -> prim wX wY
- Darcs.Patch.Prim.Class: tryShrinkingInverse :: PrimCanonize prim => FL prim x y -> Maybe (FL prim x y)
+ Darcs.Patch.Prim.Class: tryShrinkingInverse :: PrimCanonize prim => FL prim wX wY -> Maybe (FL prim wX wY)
- Darcs.Patch.Prim.Class: tryToShrink :: PrimCanonize prim => FL prim x y -> FL prim x y
+ Darcs.Patch.Prim.Class: tryToShrink :: PrimCanonize prim => FL prim wX wY -> FL prim wX wY
- Darcs.Patch.Prim.V1: data Prim x y
+ Darcs.Patch.Prim.V1: data Prim wX wY
- Darcs.Patch.Prim.V1.Core: AddDir :: DirPatchType x y
+ Darcs.Patch.Prim.V1.Core: AddDir :: DirPatchType wX wY
- Darcs.Patch.Prim.V1.Core: AddFile :: FilePatchType x y
+ Darcs.Patch.Prim.V1.Core: AddFile :: FilePatchType wX wY
- Darcs.Patch.Prim.V1.Core: Binary :: ByteString -> ByteString -> FilePatchType x y
+ Darcs.Patch.Prim.V1.Core: Binary :: ByteString -> ByteString -> FilePatchType wX wY
- Darcs.Patch.Prim.V1.Core: ChangePref :: !String -> !String -> !String -> Prim x y
+ Darcs.Patch.Prim.V1.Core: ChangePref :: !String -> !String -> !String -> Prim wX wY
- Darcs.Patch.Prim.V1.Core: DP :: !FileName -> !(DirPatchType x y) -> Prim x y
+ Darcs.Patch.Prim.V1.Core: DP :: !FileName -> !(DirPatchType wX wY) -> Prim wX wY
- Darcs.Patch.Prim.V1.Core: FP :: !FileName -> !(FilePatchType x y) -> Prim x y
+ Darcs.Patch.Prim.V1.Core: FP :: !FileName -> !(FilePatchType wX wY) -> Prim wX wY
- Darcs.Patch.Prim.V1.Core: Hunk :: !Int -> [ByteString] -> [ByteString] -> FilePatchType x y
+ Darcs.Patch.Prim.V1.Core: Hunk :: !Int -> [ByteString] -> [ByteString] -> FilePatchType wX wY
- Darcs.Patch.Prim.V1.Core: Move :: !FileName -> !FileName -> Prim x y
+ Darcs.Patch.Prim.V1.Core: Move :: !FileName -> !FileName -> Prim wX wY
- Darcs.Patch.Prim.V1.Core: RmDir :: DirPatchType x y
+ Darcs.Patch.Prim.V1.Core: RmDir :: DirPatchType wX wY
- Darcs.Patch.Prim.V1.Core: RmFile :: FilePatchType x y
+ Darcs.Patch.Prim.V1.Core: RmFile :: FilePatchType wX wY
- Darcs.Patch.Prim.V1.Core: TokReplace :: !String -> !String -> !String -> FilePatchType x y
+ Darcs.Patch.Prim.V1.Core: TokReplace :: !String -> !String -> !String -> FilePatchType wX wY
- Darcs.Patch.Prim.V1.Core: comparePrim :: Prim x y -> Prim w z -> Ordering
+ Darcs.Patch.Prim.V1.Core: comparePrim :: Prim wX wY -> Prim wW wZ -> Ordering
- Darcs.Patch.Prim.V1.Core: data DirPatchType x y
+ Darcs.Patch.Prim.V1.Core: data DirPatchType wX wY
- Darcs.Patch.Prim.V1.Core: data FilePatchType x y
+ Darcs.Patch.Prim.V1.Core: data FilePatchType wX wY
- Darcs.Patch.Prim.V1.Core: data Prim x y
+ Darcs.Patch.Prim.V1.Core: data Prim wX wY
- Darcs.Patch.Prim.V1.Core: isIdentity :: Prim x y -> EqCheck x y
+ Darcs.Patch.Prim.V1.Core: isIdentity :: Prim wX wY -> EqCheck wX wY
- Darcs.Patch.Prim.V3: data Prim x y
+ Darcs.Patch.Prim.V3: data Prim wX wY
- Darcs.Patch.Prim.V3.Core: BinaryHunk :: !UUID -> Hunk x y -> Prim x y
+ Darcs.Patch.Prim.V3.Core: BinaryHunk :: !UUID -> Hunk wX wY -> Prim wX wY
- Darcs.Patch.Prim.V3.Core: Demanifest :: !UUID -> Location -> Prim x y
+ Darcs.Patch.Prim.V3.Core: Demanifest :: !UUID -> Location -> Prim wX wY
- Darcs.Patch.Prim.V3.Core: Hunk :: !Int -> ByteString -> ByteString -> Hunk x y
+ Darcs.Patch.Prim.V3.Core: Hunk :: !Int -> ByteString -> ByteString -> Hunk wX wY
- Darcs.Patch.Prim.V3.Core: Identity :: Prim x x
+ Darcs.Patch.Prim.V3.Core: Identity :: Prim wX wX
- Darcs.Patch.Prim.V3.Core: Manifest :: !UUID -> Location -> Prim x y
+ Darcs.Patch.Prim.V3.Core: Manifest :: !UUID -> Location -> Prim wX wY
- Darcs.Patch.Prim.V3.Core: Move :: !UUID -> Location -> Location -> Prim x y
+ Darcs.Patch.Prim.V3.Core: Move :: !UUID -> Location -> Location -> Prim wX wY
- Darcs.Patch.Prim.V3.Core: TextHunk :: !UUID -> Hunk x y -> Prim x y
+ Darcs.Patch.Prim.V3.Core: TextHunk :: !UUID -> Hunk wX wY -> Prim wX wY
- Darcs.Patch.Prim.V3.Core: data Hunk x y
+ Darcs.Patch.Prim.V3.Core: data Hunk wX wY
- Darcs.Patch.Prim.V3.Core: data Prim x y
+ Darcs.Patch.Prim.V3.Core: data Prim wX wY
- Darcs.Patch.Prim.V3.Core: hunkEdit :: Hunk x y -> ByteString -> ByteString
+ Darcs.Patch.Prim.V3.Core: hunkEdit :: Hunk wX wY -> ByteString -> ByteString
- Darcs.Patch.Prim.V3.Core: touches :: Prim x y -> [UUID]
+ Darcs.Patch.Prim.V3.Core: touches :: Prim wX wY -> [UUID]
- Darcs.Patch.Prim.V3.Show: showHunk :: String -> UUID -> Hunk x y -> Doc
+ Darcs.Patch.Prim.V3.Show: showHunk :: String -> UUID -> Hunk wX wY -> Doc
- Darcs.Patch.Read: bracketedFL :: ParserM m => (forall y. m (Sealed (p y))) -> Char -> Char -> m (Sealed (FL p x))
+ Darcs.Patch.Read: bracketedFL :: ParserM m => (forall wY. m (Sealed (p wY))) -> Char -> Char -> m (Sealed (FL p wX))
- Darcs.Patch.Read: readPatch :: ReadPatch p => ByteString -> Maybe (Sealed (p x))
+ Darcs.Patch.Read: readPatch :: ReadPatch p => ByteString -> Maybe (Sealed (p wX))
- Darcs.Patch.Read: readPatch' :: (ReadPatch p, ParserM m) => m (Sealed (p x))
+ Darcs.Patch.Read: readPatch' :: (ReadPatch p, ParserM m) => m (Sealed (p wX))
- Darcs.Patch.Read: readPatchPartial :: ReadPatch p => ByteString -> Maybe (Sealed (p x), ByteString)
+ Darcs.Patch.Read: readPatchPartial :: ReadPatch p => ByteString -> Maybe (Sealed (p wX), ByteString)
- Darcs.Patch.RegChars: regChars :: String -> (Char -> Bool)
+ Darcs.Patch.RegChars: regChars :: String -> Char -> Bool
- Darcs.Patch.Repair: applyAndTryToFix :: (Repair p, ApplyMonad m (ApplyState p)) => p x y -> m (Maybe (String, p x y))
+ Darcs.Patch.Repair: applyAndTryToFix :: (Repair p, ApplyMonad m (ApplyState p)) => p wX wY -> m (Maybe (String, p wX wY))
- Darcs.Patch.Repair: applyAndTryToFixFL :: (RepairToFL p, ApplyMonad m (ApplyState p)) => p x y -> m (Maybe (String, FL p x y))
+ Darcs.Patch.Repair: applyAndTryToFixFL :: (RepairToFL p, ApplyMonad m (ApplyState p)) => p wX wY -> m (Maybe (String, FL p wX wY))
- Darcs.Patch.Repair: isInconsistent :: Check p => p x y -> Maybe Doc
+ Darcs.Patch.Repair: isInconsistent :: Check p => p wX wY -> Maybe Doc
- Darcs.Patch.RepoPatch: class (Patchy p, Merge p, Effect p, IsHunk p, FromPrim p, Conflict p, CommuteNoConflicts p, Check p, RepairToFL p, PatchListFormat p, PrimPatchBase p, Patchy (PrimOf p), IsHunk (PrimOf p)) => RepoPatch p
+ Darcs.Patch.RepoPatch: class (Patchy p, Merge p, Effect p, IsHunk p, PatchInspect p, ReadPatch p, ShowPatch p, FromPrim p, Conflict p, CommuteNoConflicts p, Check p, RepairToFL p, PatchListFormat p, PrimPatchBase p, Patchy (PrimOf p), IsHunk (PrimOf p), MaybeInternal p, RecontextRebase p, NameHack p, Matchable p) => RepoPatch p
- Darcs.Patch.Set: PatchSet :: RL (PatchInfoAnd p) x y -> RL (Tagged p) start x -> PatchSet p start y
+ Darcs.Patch.Set: PatchSet :: RL (PatchInfoAnd p) wX wY -> RL (Tagged p) wStart wX -> PatchSet p wStart wY
- Darcs.Patch.Set: Tagged :: PatchInfoAnd p y z -> Maybe String -> RL (PatchInfoAnd p) x y -> Tagged p x z
+ Darcs.Patch.Set: Tagged :: PatchInfoAnd p wY wZ -> Maybe String -> RL (PatchInfoAnd p) wX wY -> Tagged p wX wZ
- Darcs.Patch.Set: appendPSFL :: PatchSet p start x -> FL (PatchInfoAnd p) x y -> PatchSet p start y
+ Darcs.Patch.Set: appendPSFL :: PatchSet p wStart wX -> FL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY
- Darcs.Patch.Set: data PatchSet p start y
+ Darcs.Patch.Set: data PatchSet p wStart wY
- Darcs.Patch.Set: data Tagged p x z
+ Darcs.Patch.Set: data Tagged p wX wZ
- Darcs.Patch.Set: newset2FL :: PatchSet p start x -> FL (PatchInfoAnd p) start x
+ Darcs.Patch.Set: newset2FL :: PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX
- Darcs.Patch.Set: newset2RL :: PatchSet p start x -> RL (PatchInfoAnd p) start x
+ Darcs.Patch.Set: newset2RL :: PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX
- Darcs.Patch.Set: progressPatchSet :: String -> PatchSet p start x -> PatchSet p start x
+ Darcs.Patch.Set: progressPatchSet :: String -> PatchSet p wStart wX -> PatchSet p wStart wX
- Darcs.Patch.Set: tags :: PatchSet p start x -> [PatchInfo]
+ Darcs.Patch.Set: tags :: PatchSet p wStart wX -> [PatchInfo]
- Darcs.Patch.Set: type SealedPatchSet p start = Sealed ((PatchSet p) start)
+ Darcs.Patch.Set: type SealedPatchSet p wStart = Sealed ((PatchSet p) wStart)
- Darcs.Patch.Show: description :: ShowPatch p => p x y -> Doc
+ Darcs.Patch.Show: description :: ShowPatch p => p wX wY -> Doc
- Darcs.Patch.Show: showContextPatch :: (ShowPatch p, Monad m, ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p)) => p x y -> m Doc
+ Darcs.Patch.Show: showContextPatch :: (ShowPatch p, Monad m, ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p)) => p wX wY -> m Doc
- Darcs.Patch.Show: showNicely :: ShowPatch p => p x y -> Doc
+ Darcs.Patch.Show: showNicely :: ShowPatch p => p wX wY -> Doc
- Darcs.Patch.Show: showPatch :: ShowPatchBasic p => p x y -> Doc
+ Darcs.Patch.Show: showPatch :: ShowPatchBasic p => p wX wY -> Doc
- Darcs.Patch.Show: summary :: ShowPatch p => p x y -> Doc
+ Darcs.Patch.Show: summary :: ShowPatch p => p wX wY -> Doc
- Darcs.Patch.Show: summaryFL :: ShowPatch p => FL p x y -> Doc
+ Darcs.Patch.Show: summaryFL :: ShowPatch p => FL p wX wY -> Doc
- Darcs.Patch.Show: thing :: ShowPatch p => p x y -> String
+ Darcs.Patch.Show: thing :: ShowPatch p => p wX wY -> String
- Darcs.Patch.Show: things :: ShowPatch p => p x y -> String
+ Darcs.Patch.Show: things :: ShowPatch p => p wX wY -> String
- Darcs.Patch.Split: Splitter :: (forall x y. p x y -> Maybe (ByteString, ByteString -> Maybe (FL p x y))) -> (forall x y. FL p x y -> FL p x y) -> Splitter p
+ Darcs.Patch.Split: Splitter :: (forall wX wY. DiffAlgorithm -> p wX wY -> Maybe (ByteString, ByteString -> Maybe (FL p wX wY))) -> (forall wX wY. DiffAlgorithm -> FL p wX wY -> FL p wX wY) -> Splitter p
- Darcs.Patch.Split: applySplitter :: Splitter p -> forall x y. p x y -> Maybe (ByteString, ByteString -> Maybe (FL p x y))
+ Darcs.Patch.Split: applySplitter :: Splitter p -> forall wX wY. DiffAlgorithm -> p wX wY -> Maybe (ByteString, ByteString -> Maybe (FL p wX wY))
- Darcs.Patch.Split: canonizeSplit :: Splitter p -> forall x y. FL p x y -> FL p x y
+ Darcs.Patch.Split: canonizeSplit :: Splitter p -> forall wX wY. DiffAlgorithm -> FL p wX wY -> FL p wX wY
- Darcs.Patch.Summary: plainSummary :: (Conflict e, Effect e, PrimPatchBase e) => e x y -> Doc
+ Darcs.Patch.Summary: plainSummary :: (Conflict e, Effect e, PrimPatchBase e) => e wX wY -> Doc
- Darcs.Patch.Summary: plainSummaryPrim :: PrimDetails prim => prim x y -> Doc
+ Darcs.Patch.Summary: plainSummaryPrim :: PrimDetails prim => prim wX wY -> Doc
- Darcs.Patch.Summary: plainSummaryPrims :: PrimDetails prim => FL prim x y -> Doc
+ Darcs.Patch.Summary: plainSummaryPrims :: PrimDetails prim => FL prim wX wY -> Doc
- Darcs.Patch.Summary: xmlSummary :: (Effect p, Conflict p, PrimPatchBase p) => p x y -> Doc
+ Darcs.Patch.Summary: xmlSummary :: (Effect p, Conflict p, PrimPatchBase p) => p wX wY -> Doc
- Darcs.Patch.TokenReplace: forceTokReplace :: String -> String -> String -> ByteString -> Maybe ByteString
+ Darcs.Patch.TokenReplace: forceTokReplace :: String -> ByteString -> ByteString -> ByteString -> ByteString
- Darcs.Patch.TouchesFiles: choosePreTouching :: (Patchy p, ApplyState p ~ Tree) => Maybe [FilePath] -> FL p x y -> Sealed (FL p x)
+ Darcs.Patch.TouchesFiles: choosePreTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [FilePath] -> FL p wX wY -> Sealed (FL p wX)
- Darcs.Patch.TouchesFiles: chooseTouching :: (Patchy p, ApplyState p ~ Tree) => Maybe [FilePath] -> FL p x y -> Sealed (FL p x)
+ Darcs.Patch.TouchesFiles: chooseTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [FilePath] -> FL p wX wY -> Sealed (FL p wX)
- Darcs.Patch.TouchesFiles: deselectNotTouching :: (Patchy p, ApplyState p ~ Tree) => Maybe [FilePath] -> PatchChoices p x y -> PatchChoices p x y
+ Darcs.Patch.TouchesFiles: deselectNotTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY
- Darcs.Patch.TouchesFiles: lookTouch :: (Patchy p, ApplyState p ~ Tree) => Maybe [(FilePath, FilePath)] -> [FilePath] -> p x y -> (Bool, [FilePath], [FilePath], [(FilePath, FilePath)])
+ Darcs.Patch.TouchesFiles: lookTouch :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [(FilePath, FilePath)] -> [FilePath] -> p wX wY -> (Bool, [FilePath], [FilePath], [(FilePath, FilePath)])
- Darcs.Patch.TouchesFiles: selectNotTouching :: (Patchy p, ApplyState p ~ Tree) => Maybe [FilePath] -> PatchChoices p x y -> PatchChoices p x y
+ Darcs.Patch.TouchesFiles: selectNotTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY
- Darcs.Patch.TouchesFiles: selectTouching :: (Patchy p, ApplyState p ~ Tree) => Maybe [FilePath] -> PatchChoices p x y -> PatchChoices p x y
+ Darcs.Patch.TouchesFiles: selectTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY
- Darcs.Patch.V1: data Patch prim x y
+ Darcs.Patch.V1: data Patch prim wX wY
- Darcs.Patch.V1.Commute: merge :: Merge p => (p :\/: p) x y -> (p :/\: p) x y
+ Darcs.Patch.V1.Commute: merge :: Merge p => (p :\/: p) wX wY -> (p :/\: p) wX wY
- Darcs.Patch.V1.Commute: merger :: PrimPatch prim => String -> Patch prim x y -> Patch prim x z -> Sealed (Patch prim y)
+ Darcs.Patch.V1.Commute: merger :: PrimPatch prim => String -> Patch prim wX wY -> Patch prim wX wZ -> Sealed (Patch prim wY)
- Darcs.Patch.V1.Commute: publicUnravel :: PrimPatch prim => Patch prim x y -> [Sealed (FL prim y)]
+ Darcs.Patch.V1.Commute: publicUnravel :: PrimPatch prim => Patch prim wX wY -> [Sealed (FL prim wY)]
- Darcs.Patch.V1.Commute: unravel :: PrimPatch prim => Patch prim x y -> [Sealed (FL prim x)]
+ Darcs.Patch.V1.Commute: unravel :: PrimPatch prim => Patch prim wX wY -> [Sealed (FL prim wX)]
- Darcs.Patch.V1.Core: Merger :: FL (Patch prim) x y -> RL (Patch prim) x b -> Patch prim c b -> Patch prim c d -> Patch prim x y
+ Darcs.Patch.V1.Core: Merger :: FL (Patch prim) wX wY -> RL (Patch prim) wX wB -> Patch prim wC wB -> Patch prim wC wD -> Patch prim wX wY
- Darcs.Patch.V1.Core: PP :: prim x y -> Patch prim x y
+ Darcs.Patch.V1.Core: PP :: prim wX wY -> Patch prim wX wY
- Darcs.Patch.V1.Core: Regrem :: FL (Patch prim) x y -> RL (Patch prim) x b -> Patch prim c b -> Patch prim c a -> Patch prim y x
+ Darcs.Patch.V1.Core: Regrem :: FL (Patch prim) wX wY -> RL (Patch prim) wX wB -> Patch prim wC wB -> Patch prim wC wA -> Patch prim wY wX
- Darcs.Patch.V1.Core: data Patch prim x y
+ Darcs.Patch.V1.Core: data Patch prim wX wY
- Darcs.Patch.V1.Core: isMerger :: Patch prim a b -> Bool
+ Darcs.Patch.V1.Core: isMerger :: Patch prim wA wB -> Bool
- Darcs.Patch.V1.Core: mergerUndo :: Patch prim x y -> FL (Patch prim) x y
+ Darcs.Patch.V1.Core: mergerUndo :: Patch prim wX wY -> FL (Patch prim) wX wY
- Darcs.Patch.V1.Show: showPatch_ :: PrimPatch prim => Patch prim a b -> Doc
+ Darcs.Patch.V1.Show: showPatch_ :: PrimPatch prim => Patch prim wA wB -> Doc
- Darcs.Patch.V2: data RealPatch prim x y
+ Darcs.Patch.V2: data RealPatch prim wX wY
- Darcs.Patch.V2: prim2real :: prim x y -> RealPatch prim x y
+ Darcs.Patch.V2: prim2real :: prim wX wY -> RealPatch prim wX wY
- Darcs.Patch.V2.Non: (*>) :: (Patchy p, ToFromPrim p) => Non p x -> p x y -> Maybe (Non p y)
+ Darcs.Patch.V2.Non: (*>) :: (Patchy p, ToFromPrim p) => Non p wX -> p wX wY -> Maybe (Non p wY)
- Darcs.Patch.V2.Non: (*>>) :: (WL l, Patchy p, ToFromPrim p, PrimPatchBase p) => Non p x -> l (PrimOf p) x y -> Maybe (Non p y)
+ Darcs.Patch.V2.Non: (*>>) :: (WL l, Patchy p, ToFromPrim p, PrimPatchBase p) => Non p wX -> l (PrimOf p) wX wY -> Maybe (Non p wY)
- Darcs.Patch.V2.Non: (>*) :: (Patchy p, ToFromPrim p) => p x y -> Non p y -> Maybe (Non p x)
+ Darcs.Patch.V2.Non: (>*) :: (Patchy p, ToFromPrim p) => p wX wY -> Non p wY -> Maybe (Non p wX)
- Darcs.Patch.V2.Non: (>>*) :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) x y -> Non p y -> Maybe (Non p x)
+ Darcs.Patch.V2.Non: (>>*) :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) wX wY -> Non p wY -> Maybe (Non p wX)
- Darcs.Patch.V2.Non: Non :: FL p x y -> PrimOf p y z -> Non p x
+ Darcs.Patch.V2.Non: Non :: FL p wX wY -> PrimOf p wY wZ -> Non p wX
- Darcs.Patch.V2.Non: commuteOrAddToCtx :: (Patchy p, ToFromPrim p) => p x y -> Non p y -> Non p x
+ Darcs.Patch.V2.Non: commuteOrAddToCtx :: (Patchy p, ToFromPrim p) => p wX wY -> Non p wY -> Non p wX
- Darcs.Patch.V2.Non: commuteOrAddToCtxRL :: (Patchy p, ToFromPrim p) => RL p x y -> Non p y -> Non p x
+ Darcs.Patch.V2.Non: commuteOrAddToCtxRL :: (Patchy p, ToFromPrim p) => RL p wX wY -> Non p wY -> Non p wX
- Darcs.Patch.V2.Non: commuteOrRemFromCtx :: (Patchy p, ToFromPrim p) => p x y -> Non p x -> Maybe (Non p y)
+ Darcs.Patch.V2.Non: commuteOrRemFromCtx :: (Patchy p, MyEq p, ToFromPrim p) => p wX wY -> Non p wX -> Maybe (Non p wY)
- Darcs.Patch.V2.Non: commuteOrRemFromCtxFL :: (Patchy p, ToFromPrim p) => FL p x y -> Non p x -> Maybe (Non p y)
+ Darcs.Patch.V2.Non: commuteOrRemFromCtxFL :: (Patchy p, MyEq p, ToFromPrim p) => FL p wX wY -> Non p wX -> Maybe (Non p wY)
- Darcs.Patch.V2.Non: commutePrimsOrAddToCtx :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) x y -> Non p y -> Non p x
+ Darcs.Patch.V2.Non: commutePrimsOrAddToCtx :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) wX wY -> Non p wY -> Non p wX
- Darcs.Patch.V2.Non: data Non p x
+ Darcs.Patch.V2.Non: data Non p wX
- Darcs.Patch.V2.Non: non :: Nonable p => p x y -> Non p x
+ Darcs.Patch.V2.Non: non :: Nonable p => p wX wY -> Non p wX
- Darcs.Patch.V2.Non: readNon :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m) => m (Non p x)
+ Darcs.Patch.V2.Non: readNon :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m) => m (Non p wX)
- Darcs.Patch.V2.Non: readNons :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m) => m [Non p x]
+ Darcs.Patch.V2.Non: readNons :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m) => m [Non p wX]
- Darcs.Patch.V2.Non: remNons :: (Nonable p, Effect p, Patchy p, ToFromPrim p, PrimPatchBase p, MyEq (PrimOf p)) => [Non p x] -> Non p x -> Non p x
+ Darcs.Patch.V2.Non: remNons :: (Nonable p, Effect p, Patchy p, MyEq p, ToFromPrim p, PrimPatchBase p, MyEq (PrimOf p)) => [Non p wX] -> Non p wX -> Non p wX
- Darcs.Patch.V2.Non: showNon :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => Non p x -> Doc
+ Darcs.Patch.V2.Non: showNon :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => Non p wX -> Doc
- Darcs.Patch.V2.Non: showNons :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => [Non p x] -> Doc
+ Darcs.Patch.V2.Non: showNons :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => [Non p wX] -> Doc
- Darcs.Patch.V2.Non: unNon :: FromPrim p => Non p x -> Sealed (FL p x)
+ Darcs.Patch.V2.Non: unNon :: FromPrim p => Non p wX -> Sealed (FL p wX)
- Darcs.Patch.V2.Real: Conflictor :: [Non (RealPatch prim) x] -> FL prim x y -> Non (RealPatch prim) x -> RealPatch prim y x
+ Darcs.Patch.V2.Real: Conflictor :: [Non (RealPatch prim) wX] -> FL prim wX wY -> Non (RealPatch prim) wX -> RealPatch prim wY wX
- Darcs.Patch.V2.Real: Duplicate :: Non (RealPatch prim) x -> RealPatch prim x x
+ Darcs.Patch.V2.Real: Duplicate :: Non (RealPatch prim) wX -> RealPatch prim wX wX
- Darcs.Patch.V2.Real: Etacilpud :: Non (RealPatch prim) x -> RealPatch prim x x
+ Darcs.Patch.V2.Real: Etacilpud :: Non (RealPatch prim) wX -> RealPatch prim wX wX
- Darcs.Patch.V2.Real: InvConflictor :: [Non (RealPatch prim) x] -> FL prim x y -> Non (RealPatch prim) x -> RealPatch prim x y
+ Darcs.Patch.V2.Real: InvConflictor :: [Non (RealPatch prim) wX] -> FL prim wX wY -> Non (RealPatch prim) wX -> RealPatch prim wX wY
- Darcs.Patch.V2.Real: Normal :: prim x y -> RealPatch prim x y
+ Darcs.Patch.V2.Real: Normal :: prim wX wY -> RealPatch prim wX wY
- Darcs.Patch.V2.Real: data RealPatch prim x y
+ Darcs.Patch.V2.Real: data RealPatch prim wX wY
- Darcs.Patch.V2.Real: isConsistent :: PrimPatch prim => RealPatch prim x y -> Maybe Doc
+ Darcs.Patch.V2.Real: isConsistent :: PrimPatch prim => RealPatch prim wX wY -> Maybe Doc
- Darcs.Patch.V2.Real: isDuplicate :: RealPatch prim s y -> Bool
+ Darcs.Patch.V2.Real: isDuplicate :: RealPatch prim wS wY -> Bool
- Darcs.Patch.V2.Real: isForward :: PrimPatch prim => RealPatch prim s y -> Maybe Doc
+ Darcs.Patch.V2.Real: isForward :: PrimPatch prim => RealPatch prim wS wY -> Maybe Doc
- Darcs.Patch.V2.Real: mergeUnravelled :: PrimPatch prim => [Sealed ((FL prim) x)] -> Maybe (FlippedSeal (RealPatch prim) x)
+ Darcs.Patch.V2.Real: mergeUnravelled :: PrimPatch prim => [Sealed ((FL prim) wX)] -> Maybe (FlippedSeal (RealPatch prim) wX)
- Darcs.Patch.V2.Real: prim2real :: prim x y -> RealPatch prim x y
+ Darcs.Patch.V2.Real: prim2real :: prim wX wY -> RealPatch prim wX wY
- Darcs.Patch.Viewing: showContextHunk :: ApplyMonad m Tree => FileHunk x y -> m Doc
+ Darcs.Patch.Viewing: showContextHunk :: ApplyMonad m Tree => FileHunk wX wY -> m Doc
- Darcs.Patch.Viewing: showContextSeries :: (Apply p, ShowPatch p, IsHunk p, ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p)) => FL p x y -> m Doc
+ Darcs.Patch.Viewing: showContextSeries :: (Apply p, ShowPatch p, IsHunk p, ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p)) => FL p wX wY -> m Doc
- Darcs.Repository: PrimV1Job :: (forall p r u. (RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim) => Repository p r u r -> IO a) -> RepoJob a
+ Darcs.Repository: PrimV1Job :: (forall p wR wU. (RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim) => Repository p wR wU wR -> IO a) -> RepoJob a
- Darcs.Repository: RepoJob :: (forall p r u. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository p r u r -> IO a) -> RepoJob a
+ Darcs.Repository: RepoJob :: (forall p wR wU. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) => Repository p wR wU wR -> IO a) -> RepoJob a
- Darcs.Repository: V1Job :: (forall r u. Repository (Patch Prim) r u r -> IO a) -> RepoJob a
+ Darcs.Repository: V1Job :: (forall wR wU. Repository (Patch Prim) wR wU wR -> IO a) -> RepoJob a
- Darcs.Repository: V2Job :: (forall r u. Repository (RealPatch Prim) r u r -> IO a) -> RepoJob a
+ Darcs.Repository: V2Job :: (forall wR wU. Repository (RealPatch Prim) wR wU wR -> IO a) -> RepoJob a
- Darcs.Repository: addToPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> FL (PrimOf p) u y -> IO ()
+ Darcs.Repository: addToPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
- Darcs.Repository: amInHashedRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.Repository: amInHashedRepository :: WorkRepo -> IO (Either String ())
- Darcs.Repository: amInRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.Repository: amInRepository :: WorkRepo -> IO (Either String ())
- Darcs.Repository: amNotInRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.Repository: amNotInRepository :: WorkRepo -> IO (Either String ())
- Darcs.Repository: applyToWorking :: (ApplyState (PrimOf p) ~ Tree, RepoPatch p) => Repository p r u t -> [DarcsFlag] -> FL (PrimOf p) u y -> IO (Repository p r y t)
+ Darcs.Repository: applyToWorking :: (ApplyState (PrimOf p) ~ Tree, RepoPatch p) => Repository p wR wU wT -> Verbosity -> FL (PrimOf p) wU wY -> IO (Repository p wR wY wT)
- Darcs.Repository: checkUnrelatedRepos :: RepoPatch p => [DarcsFlag] -> PatchSet p start x -> PatchSet p start y -> IO ()
+ Darcs.Repository: checkUnrelatedRepos :: RepoPatch p => Bool -> PatchSet p wStart wX -> PatchSet p wStart wY -> IO ()
- Darcs.Repository: cleanRepository :: RepoPatch p => Repository p r u t -> IO ()
+ Darcs.Repository: cleanRepository :: RepoPatch p => Repository p wR wU wT -> IO ()
- Darcs.Repository: considerMergeToWorking :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> String -> [DarcsFlag] -> FL (PatchInfoAnd p) x t -> FL (PatchInfoAnd p) x y -> IO (Sealed (FL (PrimOf p) u))
+ Darcs.Repository: considerMergeToWorking :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause -> Compression -> Verbosity -> Reorder -> (UseIndex, ScanKnown, DiffAlgorithm) -> FL (PatchInfoAnd p) wX wT -> FL (PatchInfoAnd p) wX wY -> IO (Sealed (FL (PrimOf p) wU))
- Darcs.Repository: createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p r u t -> [fp] -> FilePath -> IO ()
+ Darcs.Repository: createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p wR wU wT -> [fp] -> FilePath -> IO ()
- Darcs.Repository: createPristineDirectoryTree :: RepoPatch p => Repository p r u t -> FilePath -> IO ()
+ Darcs.Repository: createPristineDirectoryTree :: RepoPatch p => Repository p wR wU wT -> FilePath -> WithWorkingDir -> IO ()
- Darcs.Repository: createRepository :: [DarcsFlag] -> IO ()
+ Darcs.Repository: createRepository :: Bool -> WithWorkingDir -> WithPatchIndex -> IO ()
- Darcs.Repository: data PatchInfoAnd p a b
+ Darcs.Repository: data PatchInfoAnd p wA wB
- Darcs.Repository: data PatchSet p start y
+ Darcs.Repository: data PatchSet p wStart wY
- Darcs.Repository: data Repository (p :: * -> * -> *) recordedstate unrecordedstate tentativestate
+ Darcs.Repository: data Repository (p :: * -> * -> *) wRecordedstate wUnrecordedstate wTentativestate
- Darcs.Repository: finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO ()
+ Darcs.Repository: finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> UpdateWorking -> Compression -> IO ()
- Darcs.Repository: findRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.Repository: findRepository :: WorkRepo -> IO (Either String ())
- Darcs.Repository: identifyRepositoryFor :: RepoPatch p => Repository p r u t -> String -> IO (Repository p r u t)
+ Darcs.Repository: identifyRepositoryFor :: RepoPatch p => Repository p wR wU wT -> UseCache -> String -> IO (Repository p vR vU vT)
- Darcs.Repository: maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (IdentifyRepo p r u t)
+ Darcs.Repository: maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo p wR wU wT)
- Darcs.Repository: modifyCache :: RepoPatch p => Repository p r u t -> (Cache -> Cache) -> Repository p r u t
+ Darcs.Repository: modifyCache :: RepoPatch p => Repository p wR wU wT -> (Cache -> Cache) -> Repository p wR wU wT
- Darcs.Repository: patchSetToPatches :: RepoPatch p => PatchSet p x y -> FL (Named p) x y
+ Darcs.Repository: patchSetToPatches :: RepoPatch p => PatchSet p wX wY -> FL (Named p) wX wY
- Darcs.Repository: patchSetToRepository :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r1 u1 r1 -> PatchSet p Origin x -> [DarcsFlag] -> IO (Repository p r u t)
+ Darcs.Repository: patchSetToRepository :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR1 wU1 wR1 -> PatchSet p Origin wX -> UseCache -> RemoteDarcs -> IO ()
- Darcs.Repository: prefsUrl :: Repository p r u t -> String
+ Darcs.Repository: prefsUrl :: Repository p wR wU wT -> String
- Darcs.Repository: readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO Index
+ Darcs.Repository: readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO Index
- Darcs.Repository: readPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (Tree IO, Sealed (FL p t))
+ Darcs.Repository: readPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Tree IO, Sealed (FL p wT))
- Darcs.Repository: readRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (Tree IO)
+ Darcs.Repository: readRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Tree IO)
- Darcs.Repository: readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (Tree IO)
+ Darcs.Repository: readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Tree IO)
- Darcs.Repository: readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (PatchSet p Origin r)
+ Darcs.Repository: readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (PatchSet p Origin wR)
- Darcs.Repository: readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p r u t -> IO (PatchSet p Origin t)
+ Darcs.Repository: readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p wR wU wT -> IO (PatchSet p Origin wT)
- Darcs.Repository: readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (PatchSet p Origin t)
+ Darcs.Repository: readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (PatchSet p Origin wT)
- Darcs.Repository: readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> Maybe [SubPath] -> IO (Tree IO)
+ Darcs.Repository: readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Maybe [SubPath] -> IO (Tree IO)
- Darcs.Repository: replacePristine :: Repository p r u t -> Tree IO -> IO ()
+ Darcs.Repository: replacePristine :: Repository p wR wU wT -> Tree IO -> IO ()
- Darcs.Repository: revertRepositoryChanges :: RepoPatch p => Repository p r u t -> IO ()
+ Darcs.Repository: revertRepositoryChanges :: RepoPatch p => Repository p wR wU wT -> UpdateWorking -> IO ()
- Darcs.Repository: setScriptsExecutablePatches :: Patchy p => p x y -> IO ()
+ Darcs.Repository: setScriptsExecutablePatches :: PatchInspect p => p wX wY -> IO ()
- Darcs.Repository: tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> Compression -> PatchInfoAnd p t y -> IO (Repository p r u y)
+ Darcs.Repository: tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> Verbosity -> UpdateWorking -> PatchInfoAnd p wT wY -> IO (Repository p wR wU wY)
- Darcs.Repository: tentativelyAddToPending :: RepoPatch p => Repository p r u t -> [DarcsFlag] -> FL (PrimOf p) x y -> IO ()
+ Darcs.Repository: tentativelyAddToPending :: RepoPatch p => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wX wY -> IO ()
- Darcs.Repository: tentativelyMergePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> String -> [DarcsFlag] -> FL (PatchInfoAnd p) x t -> FL (PatchInfoAnd p) x y -> IO (Sealed (FL (PrimOf p) u))
+ Darcs.Repository: tentativelyMergePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause -> Compression -> Verbosity -> Reorder -> (UseIndex, ScanKnown, DiffAlgorithm) -> FL (PatchInfoAnd p) wX wT -> FL (PatchInfoAnd p) wX wY -> IO (Sealed (FL (PrimOf p) wU))
- Darcs.Repository: tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> Compression -> FL (PatchInfoAnd p) x t -> IO (Repository p r u x)
+ Darcs.Repository: tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> UpdateWorking -> FL (PatchInfoAnd p) wX wT -> IO (Repository p wR wU wX)
- Darcs.Repository: tentativelyReplacePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> Compression -> FL (PatchInfoAnd p) x t -> IO (Repository p r u t)
+ Darcs.Repository: tentativelyReplacePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> UpdateWorking -> Verbosity -> FL (PatchInfoAnd p) wX wT -> IO ()
- Darcs.Repository: testTentative :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (ExitCode)
+ Darcs.Repository: testTentative :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> RunTest -> LeaveTestDir -> SetScriptsExecutable -> Verbosity -> IO ExitCode
- Darcs.Repository: type SealedPatchSet p start = Sealed ((PatchSet p) start)
+ Darcs.Repository: type SealedPatchSet p wStart = Sealed ((PatchSet p) wStart)
- Darcs.Repository: unrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree) => (UseIndex, ScanKnown) -> Repository p r u t -> Maybe [SubPath] -> IO (FL (PrimOf p) t u)
+ Darcs.Repository: unrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree) => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT -> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU)
- Darcs.Repository: unrevertUrl :: Repository p r u t -> String
+ Darcs.Repository: unrevertUrl :: Repository p wR wU wT -> String
- Darcs.Repository: withRecorded :: RepoPatch p => Repository p r u t -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a
+ Darcs.Repository: withRecorded :: RepoPatch p => Repository p wR wU wT -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a
- Darcs.Repository: withRepoLock :: [DarcsFlag] -> RepoJob a -> IO a
+ Darcs.Repository: withRepoLock :: DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
- Darcs.Repository: withRepository :: [DarcsFlag] -> RepoJob a -> IO a
+ Darcs.Repository: withRepository :: UseCache -> RepoJob a -> IO a
- Darcs.Repository: withRepositoryDirectory :: [DarcsFlag] -> String -> RepoJob a -> IO a
+ Darcs.Repository: withRepositoryDirectory :: UseCache -> String -> RepoJob a -> IO a
- Darcs.Repository: writePatchSet :: (RepoPatch p, ApplyState p ~ Tree) => PatchSet p Origin x -> [DarcsFlag] -> IO (Repository p r u t)
+ Darcs.Repository: writePatchSet :: (RepoPatch p, ApplyState p ~ Tree) => PatchSet p Origin wX -> UseCache -> IO (Repository p wR wU wT)
- Darcs.Repository.ApplyPatches: applyPatches :: (MonadProgress m, ApplyMonad m (ApplyState p), Patchy p) => FL (PatchInfoAnd p) x y -> m ()
+ Darcs.Repository.ApplyPatches: applyPatches :: (MonadProgress m, ApplyMonad m (ApplyState p), Patchy p) => FL (PatchInfoAnd p) wX wY -> m ()
- Darcs.Repository.Cache: unionRemoteCaches :: Cache -> Cache -> String -> IO (Cache)
+ Darcs.Repository.Cache: unionRemoteCaches :: Cache -> Cache -> String -> IO Cache
- Darcs.Repository.Format: RF :: [[ByteString]] -> RepoFormat
+ Darcs.Repository.Format: RF :: [[RepoProperty]] -> RepoFormat
- Darcs.Repository.Format: createRepoFormat :: [DarcsFlag] -> RepoFormat
+ Darcs.Repository.Format: createRepoFormat :: Bool -> WithWorkingDir -> RepoFormat
- Darcs.Repository.HashedIO: copyHashed :: String -> Cache -> Compression -> String -> IO ()
+ Darcs.Repository.HashedIO: copyHashed :: String -> Cache -> WithWorkingDir -> String -> IO ()
- Darcs.Repository.HashedIO: copyPartialsHashed :: FilePathLike fp => Cache -> Compression -> String -> [fp] -> IO ()
+ Darcs.Repository.HashedIO: copyPartialsHashed :: FilePathLike fp => Cache -> String -> [fp] -> IO ()
- Darcs.Repository.HashedRepo: addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression -> PatchInfoAnd p x y -> IO FilePath
+ Darcs.Repository.HashedRepo: addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression -> PatchInfoAnd p wX wY -> IO FilePath
- Darcs.Repository.HashedRepo: addToTentativeInventory :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p x y -> IO FilePath
+ Darcs.Repository.HashedRepo: addToTentativeInventory :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p wX wY -> IO FilePath
- Darcs.Repository.HashedRepo: applyToTentativePristine :: (ApplyState q ~ Tree, Patchy q) => q x y -> IO ()
+ Darcs.Repository.HashedRepo: applyToTentativePristine :: (ApplyState p ~ Tree, Patchy p) => p wX wY -> IO ()
- Darcs.Repository.HashedRepo: cleanPristine :: Repository p r u t -> IO ()
+ Darcs.Repository.HashedRepo: cleanPristine :: Repository p wR wU wT -> IO ()
- Darcs.Repository.HashedRepo: copyPartialsPristine :: FilePathLike fp => Cache -> Compression -> String -> String -> [fp] -> IO ()
+ Darcs.Repository.HashedRepo: copyPartialsPristine :: FilePathLike fp => Cache -> String -> String -> [fp] -> IO ()
- Darcs.Repository.HashedRepo: copyPristine :: Cache -> Compression -> String -> String -> IO ()
+ Darcs.Repository.HashedRepo: copyPristine :: Cache -> String -> String -> WithWorkingDir -> IO ()
- Darcs.Repository.HashedRepo: copySources :: RepoPatch p => Repository p r u t -> String -> IO ()
+ Darcs.Repository.HashedRepo: copySources :: RepoPatch p => Repository p wR wU wT -> String -> IO ()
- Darcs.Repository.HashedRepo: finalizeTentativeChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> Compression -> IO ()
+ Darcs.Repository.HashedRepo: finalizeTentativeChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> IO ()
- Darcs.Repository.HashedRepo: readHashedPristineRoot :: Repository p r u t -> IO (Maybe String)
+ Darcs.Repository.HashedRepo: readHashedPristineRoot :: Repository p wR wU wT -> IO (Maybe String)
- Darcs.Repository.HashedRepo: readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> String -> IO (PatchSet p Origin r)
+ Darcs.Repository.HashedRepo: readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> String -> IO (PatchSet p Origin wR)
- Darcs.Repository.HashedRepo: readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p r u t -> String -> IO (PatchSet p Origin s)
+ Darcs.Repository.HashedRepo: readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p wR wU wT -> String -> IO (PatchSet p Origin wS)
- Darcs.Repository.HashedRepo: readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> String -> IO (PatchSet p Origin t)
+ Darcs.Repository.HashedRepo: readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> String -> IO (PatchSet p Origin wT)
- Darcs.Repository.HashedRepo: removeFromTentativeInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> Compression -> FL (PatchInfoAnd p) x t -> IO ()
+ Darcs.Repository.HashedRepo: removeFromTentativeInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> FL (PatchInfoAnd p) wX wT -> IO ()
- Darcs.Repository.HashedRepo: writeAndReadPatch :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p x y -> IO (PatchInfoAnd p x y)
+ Darcs.Repository.HashedRepo: writeAndReadPatch :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p wX wY -> IO (PatchInfoAnd p wX wY)
- Darcs.Repository.HashedRepo: writePatchIfNecessary :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p x y -> IO (PatchInfo, String)
+ Darcs.Repository.HashedRepo: writePatchIfNecessary :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p wX wY -> IO (PatchInfo, String)
- Darcs.Repository.HashedRepo: writeTentativeInventory :: RepoPatch p => Cache -> Compression -> PatchSet p Origin x -> IO ()
+ Darcs.Repository.HashedRepo: writeTentativeInventory :: RepoPatch p => Cache -> Compression -> PatchSet p Origin wX -> IO ()
- Darcs.Repository.Internal: BadRepository :: String -> IdentifyRepo p r u t
+ Darcs.Repository.Internal: BadRepository :: String -> IdentifyRepo p wR wU wT
- Darcs.Repository.Internal: GoodRepository :: (Repository p r u t) -> IdentifyRepo p r u t
+ Darcs.Repository.Internal: GoodRepository :: (Repository p wR wU wT) -> IdentifyRepo p wR wU wT
- Darcs.Repository.Internal: NonRepository :: String -> IdentifyRepo p r u t
+ Darcs.Repository.Internal: NonRepository :: String -> IdentifyRepo p wR wU wT
- Darcs.Repository.Internal: Repo :: !String -> ![DarcsFlag] -> !RepoFormat -> !(RepoType p) -> Repository recordedstate unrecordedstate tentativestate
+ Darcs.Repository.Internal: Repo :: !String -> !RepoFormat -> !Pristine -> Cache -> Repository wRecordedstate wUnrecordedstate wTentativestate
- Darcs.Repository.Internal: amInHashedRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.Repository.Internal: amInHashedRepository :: WorkRepo -> IO (Either String ())
- Darcs.Repository.Internal: amInRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.Repository.Internal: amInRepository :: WorkRepo -> IO (Either String ())
- Darcs.Repository.Internal: amNotInRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.Repository.Internal: amNotInRepository :: WorkRepo -> IO (Either String ())
- Darcs.Repository.Internal: announceMergeConflicts :: (PrimPatch p, PatchInspect p) => String -> [DarcsFlag] -> FL p x y -> IO Bool
+ Darcs.Repository.Internal: announceMergeConflicts :: (PrimPatch p, PatchInspect p) => String -> AllowConflicts -> ExternalMerge -> FL p wX wY -> IO Bool
- Darcs.Repository.Internal: applyToTentativePristine :: (ApplyState q ~ Tree, Effect q, Patchy q, PrimPatchBase q) => Repository p r u t -> q t y -> IO ()
+ Darcs.Repository.Internal: applyToTentativePristine :: (ApplyState q ~ Tree, Effect q, Patchy q, ShowPatch q, PrimPatchBase q) => Repository p wR wU wT -> Verbosity -> q wT wY -> IO ()
- Darcs.Repository.Internal: applyToWorking :: (ApplyState (PrimOf p) ~ Tree, RepoPatch p) => Repository p r u t -> [DarcsFlag] -> FL (PrimOf p) u y -> IO (Repository p r y t)
+ Darcs.Repository.Internal: applyToWorking :: (ApplyState (PrimOf p) ~ Tree, RepoPatch p) => Repository p wR wU wT -> Verbosity -> FL (PrimOf p) wU wY -> IO (Repository p wR wY wT)
- Darcs.Repository.Internal: checkUnrecordedConflicts :: RepoPatch p => [DarcsFlag] -> FL (Named p) t y -> IO Bool
+ Darcs.Repository.Internal: checkUnrecordedConflicts :: RepoPatch p => UpdateWorking -> FL (Named p) wT wY -> IO Bool
- Darcs.Repository.Internal: cleanRepository :: RepoPatch p => Repository p r u t -> IO ()
+ Darcs.Repository.Internal: cleanRepository :: RepoPatch p => Repository p wR wU wT -> IO ()
- Darcs.Repository.Internal: createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p r u t -> [fp] -> FilePath -> IO ()
+ Darcs.Repository.Internal: createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p wR wU wT -> [fp] -> FilePath -> IO ()
- Darcs.Repository.Internal: createPristineDirectoryTree :: RepoPatch p => Repository p r u t -> FilePath -> IO ()
+ Darcs.Repository.Internal: createPristineDirectoryTree :: RepoPatch p => Repository p wR wU wT -> FilePath -> WithWorkingDir -> IO ()
- Darcs.Repository.Internal: data IdentifyRepo p r u t
+ Darcs.Repository.Internal: data IdentifyRepo p wR wU wT
- Darcs.Repository.Internal: data Repository (p :: * -> * -> *) recordedstate unrecordedstate tentativestate
+ Darcs.Repository.Internal: data Repository (p :: * -> * -> *) wRecordedstate wUnrecordedstate wTentativestate
- Darcs.Repository.Internal: finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO ()
+ Darcs.Repository.Internal: finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> UpdateWorking -> Compression -> IO ()
- Darcs.Repository.Internal: findRepository :: [DarcsFlag] -> IO (Either String ())
+ Darcs.Repository.Internal: findRepository :: WorkRepo -> IO (Either String ())
- Darcs.Repository.Internal: identifyRepositoryFor :: RepoPatch p => Repository p r u t -> String -> IO (Repository p r u t)
+ Darcs.Repository.Internal: identifyRepositoryFor :: RepoPatch p => Repository p wR wU wT -> UseCache -> String -> IO (Repository p vR vU vT)
- Darcs.Repository.Internal: makeNewPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> FL (PrimOf p) t y -> IO ()
+ Darcs.Repository.Internal: makeNewPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wT wY -> IO ()
- Darcs.Repository.Internal: maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (IdentifyRepo p r u t)
+ Darcs.Repository.Internal: maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo p wR wU wT)
- Darcs.Repository.Internal: patchSetToPatches :: RepoPatch p => PatchSet p x y -> FL (Named p) x y
+ Darcs.Repository.Internal: patchSetToPatches :: RepoPatch p => PatchSet p wX wY -> FL (Named p) wX wY
- Darcs.Repository.Internal: prefsUrl :: Repository p r u t -> String
+ Darcs.Repository.Internal: prefsUrl :: Repository p wR wU wT -> String
- Darcs.Repository.Internal: readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (PatchSet p Origin r)
+ Darcs.Repository.Internal: readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (PatchSet p Origin wR)
- Darcs.Repository.Internal: readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p r u t -> IO (PatchSet p Origin t)
+ Darcs.Repository.Internal: readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p wR wU wT -> IO (PatchSet p Origin wT)
- Darcs.Repository.Internal: readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (PatchSet p Origin t)
+ Darcs.Repository.Internal: readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (PatchSet p Origin wT)
- Darcs.Repository.Internal: revertRepositoryChanges :: RepoPatch p => Repository p r u t -> IO ()
+ Darcs.Repository.Internal: revertRepositoryChanges :: RepoPatch p => Repository p wR wU wT -> UpdateWorking -> IO ()
- Darcs.Repository.Internal: setScriptsExecutablePatches :: Patchy p => p x y -> IO ()
+ Darcs.Repository.Internal: setScriptsExecutablePatches :: PatchInspect p => p wX wY -> IO ()
- Darcs.Repository.Internal: setTentativePending :: RepoPatch p => Repository p r u t -> FL (PrimOf p) x y -> IO ()
+ Darcs.Repository.Internal: setTentativePending :: RepoPatch p => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wX wY -> IO ()
- Darcs.Repository.Internal: tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> Compression -> PatchInfoAnd p t y -> IO (Repository p r u y)
+ Darcs.Repository.Internal: tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> Verbosity -> UpdateWorking -> PatchInfoAnd p wT wY -> IO (Repository p wR wU wY)
- Darcs.Repository.Internal: tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree) => UpdatePristine -> Repository p r u t -> Compression -> PatchInfoAnd p t y -> IO (Repository p r u y)
+ Darcs.Repository.Internal: tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree) => UpdatePristine -> Repository p wR wU wT -> Compression -> Verbosity -> UpdateWorking -> PatchInfoAnd p wT wY -> IO (Repository p wR wU wY)
- Darcs.Repository.Internal: tentativelyAddToPending :: RepoPatch p => Repository p r u t -> [DarcsFlag] -> FL (PrimOf p) x y -> IO ()
+ Darcs.Repository.Internal: tentativelyAddToPending :: RepoPatch p => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wX wY -> IO ()
- Darcs.Repository.Internal: tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> Compression -> FL (PatchInfoAnd p) x t -> IO (Repository p r u x)
+ Darcs.Repository.Internal: tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> UpdateWorking -> FL (PatchInfoAnd p) wX wT -> IO (Repository p wR wU wX)
- Darcs.Repository.Internal: tentativelyReplacePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> Compression -> FL (PatchInfoAnd p) x t -> IO (Repository p r u t)
+ Darcs.Repository.Internal: tentativelyReplacePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Compression -> UpdateWorking -> Verbosity -> FL (PatchInfoAnd p) wX wT -> IO ()
- Darcs.Repository.Internal: unrevertUrl :: Repository p r u t -> String
+ Darcs.Repository.Internal: unrevertUrl :: Repository p wR wU wT -> String
- Darcs.Repository.Internal: withRecorded :: RepoPatch p => Repository p r u t -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a
+ Darcs.Repository.Internal: withRecorded :: RepoPatch p => Repository p wR wU wT -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a
- Darcs.Repository.InternalTypes: Repo :: !String -> ![DarcsFlag] -> !RepoFormat -> !(RepoType p) -> Repository recordedstate unrecordedstate tentativestate
+ Darcs.Repository.InternalTypes: Repo :: !String -> !RepoFormat -> !Pristine -> Cache -> Repository wRecordedstate wUnrecordedstate wTentativestate
- Darcs.Repository.InternalTypes: data Repository (p :: * -> * -> *) recordedstate unrecordedstate tentativestate
+ Darcs.Repository.InternalTypes: data Repository (p :: * -> * -> *) wRecordedstate wUnrecordedstate wTentativestate
- Darcs.Repository.InternalTypes: extractCache :: Repository p r u t -> Cache
+ Darcs.Repository.InternalTypes: extractCache :: Repository p wR wU wT -> Cache
- Darcs.Repository.InternalTypes: modifyCache :: RepoPatch p => Repository p r u t -> (Cache -> Cache) -> Repository p r u t
+ Darcs.Repository.InternalTypes: modifyCache :: RepoPatch p => Repository p wR wU wT -> (Cache -> Cache) -> Repository p wR wU wT
- Darcs.Repository.LowLevel: pendingName :: RepoType p -> String
+ Darcs.Repository.LowLevel: pendingName :: String
- Darcs.Repository.LowLevel: readNewPending :: RepoPatch p => Repository p r u t -> IO (Sealed (FL (PrimOf p) t))
+ Darcs.Repository.LowLevel: readNewPending :: RepoPatch p => Repository p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
- Darcs.Repository.LowLevel: readPending :: RepoPatch p => Repository p r u t -> IO (Sealed (FL (PrimOf p) t))
+ Darcs.Repository.LowLevel: readPending :: RepoPatch p => Repository p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
- Darcs.Repository.LowLevel: readTentativePending :: RepoPatch p => Repository p r u t -> IO (Sealed (FL (PrimOf p) t))
+ Darcs.Repository.LowLevel: readTentativePending :: RepoPatch p => Repository p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
- Darcs.Repository.LowLevel: writeNewPending :: RepoPatch p => Repository p r u t -> FL (PrimOf p) t y -> IO ()
+ Darcs.Repository.LowLevel: writeNewPending :: RepoPatch p => Repository p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
- Darcs.Repository.LowLevel: writeTentativePending :: RepoPatch p => Repository p r u t -> FL (PrimOf p) t y -> IO ()
+ Darcs.Repository.LowLevel: writeTentativePending :: RepoPatch p => Repository p wR wU wT -> FL (PrimOf p) wT wY -> IO ()
- Darcs.Repository.Merge: considerMergeToWorking :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> String -> [DarcsFlag] -> FL (PatchInfoAnd p) x t -> FL (PatchInfoAnd p) x y -> IO (Sealed (FL (PrimOf p) u))
+ Darcs.Repository.Merge: considerMergeToWorking :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause -> Compression -> Verbosity -> Reorder -> (UseIndex, ScanKnown, DiffAlgorithm) -> FL (PatchInfoAnd p) wX wT -> FL (PatchInfoAnd p) wX wY -> IO (Sealed (FL (PrimOf p) wU))
- Darcs.Repository.Merge: tentativelyMergePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> String -> [DarcsFlag] -> FL (PatchInfoAnd p) x t -> FL (PatchInfoAnd p) x y -> IO (Sealed (FL (PrimOf p) u))
+ Darcs.Repository.Merge: tentativelyMergePatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> String -> AllowConflicts -> UpdateWorking -> ExternalMerge -> WantGuiPause -> Compression -> Verbosity -> Reorder -> (UseIndex, ScanKnown, DiffAlgorithm) -> FL (PatchInfoAnd p) wX wT -> FL (PatchInfoAnd p) wX wY -> IO (Sealed (FL (PrimOf p) wU))
- Darcs.Repository.Motd: showMotd :: [DarcsFlag] -> String -> IO ()
+ Darcs.Repository.Motd: showMotd :: String -> IO ()
- Darcs.Repository.Prefs: defaultrepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
+ Darcs.Repository.Prefs: defaultrepo :: RemoteRepos -> AbsolutePath -> [String] -> IO [String]
- Darcs.Repository.Prefs: getCaches :: [DarcsFlag] -> String -> IO Cache
+ Darcs.Repository.Prefs: getCaches :: UseCache -> String -> IO Cache
- Darcs.Repository.Repair: BrokenPatches :: (Tree IO) -> (PatchSet p Origin x) -> RepositoryConsistency p x
+ Darcs.Repository.Repair: BrokenPatches :: (Tree IO) -> (PatchSet p Origin wX) -> RepositoryConsistency p wX
- Darcs.Repository.Repair: BrokenPristine :: (Tree IO) -> RepositoryConsistency p x
+ Darcs.Repository.Repair: BrokenPristine :: (Tree IO) -> RepositoryConsistency p wX
- Darcs.Repository.Repair: RepositoryConsistent :: RepositoryConsistency p x
+ Darcs.Repository.Repair: RepositoryConsistent :: RepositoryConsistency p wX
- Darcs.Repository.Repair: checkIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> Bool -> IO Bool
+ Darcs.Repository.Repair: checkIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Bool -> IO Bool
- Darcs.Repository.Repair: data RepositoryConsistency p x
+ Darcs.Repository.Repair: data RepositoryConsistency p wX
- Darcs.Repository.Repair: replayRepository :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> [DarcsFlag] -> (RepositoryConsistency p r -> IO a) -> IO a
+ Darcs.Repository.Repair: replayRepository :: (RepoPatch p, ApplyState p ~ Tree) => DiffAlgorithm -> Repository p wR wU wT -> Compression -> Verbosity -> (RepositoryConsistency p wR -> IO a) -> IO a
- Darcs.Repository.Repair: replayRepositoryInTemp :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> [DarcsFlag] -> IO (RepositoryConsistency p r)
+ Darcs.Repository.Repair: replayRepositoryInTemp :: (RepoPatch p, ApplyState p ~ Tree) => DiffAlgorithm -> Repository p wR wU wT -> Compression -> Verbosity -> IO (RepositoryConsistency p wR)
- Darcs.Repository.State: readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO Index
+ Darcs.Repository.State: readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO Index
- Darcs.Repository.State: readPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (Tree IO, Sealed (FL p t))
+ Darcs.Repository.State: readPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Tree IO, Sealed (FL p wT))
- Darcs.Repository.State: readRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (Tree IO)
+ Darcs.Repository.State: readRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Tree IO)
- Darcs.Repository.State: readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> IO (Tree IO)
+ Darcs.Repository.State: readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Tree IO)
- Darcs.Repository.State: readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> Maybe [SubPath] -> IO (Tree IO)
+ Darcs.Repository.State: readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Maybe [SubPath] -> IO (Tree IO)
- Darcs.Repository.State: restrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u t -> [SubPath] -> IO (TreeFilter m)
+ Darcs.Repository.State: restrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> [SubPath] -> IO (TreeFilter m)
- Darcs.Repository.State: unrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree) => (UseIndex, ScanKnown) -> Repository p r u t -> Maybe [SubPath] -> IO (FL (PrimOf p) t u)
+ Darcs.Repository.State: unrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree) => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT -> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU)
Files
- GNUmakefile +5/−48
- NEWS +136/−14
- README +37/−29
- Setup.lhs +63/−47
- containers-0.5.2.1/Darcs/Data/Map/Base.hs +2791/−0
- containers-0.5.2.1/Darcs/Data/Map/Strict.hs +1180/−0
- containers-0.5.2.1/Darcs/Data/Set/Base.hs +1526/−0
- containers-0.5.2.1/Darcs/Data/StrictPair.hs +13/−0
- contrib/_darcs.zsh +1/−2
- darcs.cabal +419/−467
- darcs/darcs.hs +89/−0
- doc/darcs.css +0/−103
- doc/src/best_practices.tex +0/−612
- doc/src/building_darcs.tex +0/−33
- doc/src/configuring_darcs.tex +0/−472
- doc/src/darcs.tex +0/−1538
- doc/src/features.tex +0/−71
- doc/src/gpl.tex +0/−420
- harness/Darcs/Test/Email.hs +93/−0
- harness/Darcs/Test/Misc.hs +107/−0
- harness/Darcs/Test/Patch.hs +374/−0
- harness/Darcs/Test/Patch/Arbitrary/Generic.hs +243/−0
- harness/Darcs/Test/Patch/Arbitrary/PatchV1.hs +287/−0
- harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs +392/−0
- harness/Darcs/Test/Patch/Arbitrary/PrimV3.hs +259/−0
- harness/Darcs/Test/Patch/Arbitrary/Real.hs +66/−0
- harness/Darcs/Test/Patch/Check.hs +348/−0
- harness/Darcs/Test/Patch/Examples/Set1.hs +418/−0
- harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs +491/−0
- harness/Darcs/Test/Patch/Info.hs +163/−0
- harness/Darcs/Test/Patch/Properties/Check.hs +98/−0
- harness/Darcs/Test/Patch/Properties/Generic.hs +372/−0
- harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs +95/−0
- harness/Darcs/Test/Patch/Properties/Real.hs +35/−0
- harness/Darcs/Test/Patch/Properties/V1Set1.hs +161/−0
- harness/Darcs/Test/Patch/Properties/V1Set2.hs +316/−0
- harness/Darcs/Test/Patch/Rebase.hs +42/−0
- harness/Darcs/Test/Patch/RepoModel.hs +23/−0
- harness/Darcs/Test/Patch/Utils.hs +24/−0
- harness/Darcs/Test/Patch/V1Model.hs +288/−0
- harness/Darcs/Test/Patch/V3Model.hs +215/−0
- harness/Darcs/Test/Patch/WSub.hs +137/−0
- harness/Darcs/Test/Patch/WithState.hs +131/−0
- harness/Darcs/Test/Util/QuickCheck.hs +58/−0
- harness/Darcs/Test/Util/TestResult.hs +63/−0
- harness/test.hs +296/−0
- hashed-storage/Bundled/Posix.hsc +116/−0
- hashed-storage/LICENSE +26/−0
- hashed-storage/Storage/Hashed.hs +51/−0
- hashed-storage/Storage/Hashed/AnchoredPath.hs +110/−0
- hashed-storage/Storage/Hashed/Darcs.hs +310/−0
- hashed-storage/Storage/Hashed/Diff.hs +136/−0
- hashed-storage/Storage/Hashed/Hash.hs +80/−0
- hashed-storage/Storage/Hashed/Index.hs +525/−0
- hashed-storage/Storage/Hashed/Monad.hs +281/−0
- hashed-storage/Storage/Hashed/Packed.hs +227/−0
- hashed-storage/Storage/Hashed/Plain.hs +78/−0
- hashed-storage/Storage/Hashed/Test.hs +618/−0
- hashed-storage/Storage/Hashed/Tree.hs +464/−0
- hashed-storage/Storage/Hashed/Utils.hs +148/−0
- hashed-storage/test.hs +17/−0
- hashed-storage/testdata.zip binary
- release/distributed-context +1/−1
- src/ByteStringUtils.hs +0/−547
- src/CommandLine.hs +0/−140
- src/Crypt/SHA256.hs +0/−45
- src/Crypt/sha2.c +0/−949
- src/Crypt/sha2.h +0/−88
- src/Darcs/Annotate.hs +0/−262
- src/Darcs/ArgumentDefaults.hs +0/−79
- src/Darcs/Arguments.hs +0/−1596
- src/Darcs/Bug.hs +0/−27
- src/Darcs/ColorPrinter.hs +0/−285
- src/Darcs/Commands.hs +0/−242
- src/Darcs/Commands/Add.hs +0/−341
- src/Darcs/Commands/AmendRecord.hs +0/−332
- src/Darcs/Commands/Annotate.hs +0/−151
- src/Darcs/Commands/Apply.hs +0/−395
- src/Darcs/Commands/Changes.hs +0/−362
- src/Darcs/Commands/Check.hs +0/−167
- src/Darcs/Commands/Convert.hs +0/−261
- src/Darcs/Commands/Diff.hs +0/−214
- src/Darcs/Commands/Dist.hs +0/−172
- src/Darcs/Commands/GZCRCs.hs +0/−185
- src/Darcs/Commands/Get.hs +0/−269
- src/Darcs/Commands/Help.hs +0/−295
- src/Darcs/Commands/Init.hs +0/−63
- src/Darcs/Commands/MarkConflicts.hs +0/−113
- src/Darcs/Commands/Move.hs +0/−260
- src/Darcs/Commands/Optimize.hs +0/−372
- src/Darcs/Commands/Pull.hs +0/−361
- src/Darcs/Commands/Push.hs +0/−197
- src/Darcs/Commands/Put.hs +0/−127
- src/Darcs/Commands/Record.hs +0/−430
- src/Darcs/Commands/Remove.hs +0/−166
- src/Darcs/Commands/Replace.hs +0/−241
- src/Darcs/Commands/Revert.hs +0/−123
- src/Darcs/Commands/Rollback.hs +0/−193
- src/Darcs/Commands/Send.hs +0/−411
- src/Darcs/Commands/SetPref.hs +0/−108
- src/Darcs/Commands/Show.hs +0/−82
- src/Darcs/Commands/ShowAuthors.hs +0/−195
- src/Darcs/Commands/ShowBug.hs +0/−51
- src/Darcs/Commands/ShowContents.hs +0/−90
- src/Darcs/Commands/ShowFiles.hs +0/−133
- src/Darcs/Commands/ShowIndex.hs +0/−84
- src/Darcs/Commands/ShowRepo.hs +0/−149
- src/Darcs/Commands/ShowTags.hs +0/−82
- src/Darcs/Commands/Tag.hs +0/−123
- src/Darcs/Commands/Test.hs +0/−70
- src/Darcs/Commands/TrackDown.hs +0/−194
- src/Darcs/Commands/TransferMode.hs +0/−86
- src/Darcs/Commands/Unrecord.hs +0/−259
- src/Darcs/Commands/Unrevert.hs +0/−139
- src/Darcs/Commands/Util.hs +0/−60
- src/Darcs/Commands/WhatsNew.hs +0/−193
- src/Darcs/CommandsAux.hs +0/−122
- src/Darcs/Compat.hs +0/−126
- src/Darcs/Diff.hs +0/−156
- src/Darcs/Email.hs +0/−248
- src/Darcs/External.hs +0/−632
- src/Darcs/Flags.hs +0/−279
- src/Darcs/Global.hs +0/−286
- src/Darcs/IO.hs +0/−184
- src/Darcs/Lock.hs +0/−346
- src/Darcs/Match.hs +0/−463
- src/Darcs/MonadProgress.hs +0/−71
- src/Darcs/Patch.hs +6/−13
- src/Darcs/Patch/Annotate.hs +282/−0
- src/Darcs/Patch/Apply.hs +19/−10
- src/Darcs/Patch/ApplyMonad.hs +8/−6
- src/Darcs/Patch/ApplyPatches.hs +23/−0
- src/Darcs/Patch/Bracketed.hs +14/−15
- src/Darcs/Patch/Bracketed/Instances.hs +2/−3
- src/Darcs/Patch/Bundle.hs +203/−166
- src/Darcs/Patch/Choices.hs +186/−185
- src/Darcs/Patch/Commute.hs +71/−55
- src/Darcs/Patch/CommuteFn.hs +83/−0
- src/Darcs/Patch/Conflict.hs +23/−16
- src/Darcs/Patch/ConflictMarking.hs +17/−19
- src/Darcs/Patch/Debug.hs +20/−0
- src/Darcs/Patch/Depends.hs +368/−269
- src/Darcs/Patch/Dummy.hs +58/−3
- src/Darcs/Patch/Effect.hs +3/−4
- src/Darcs/Patch/FileHunk.hs +5/−6
- src/Darcs/Patch/FileName.hs +0/−161
- src/Darcs/Patch/Format.hs +25/−19
- src/Darcs/Patch/Index/Monad.hs +117/−0
- src/Darcs/Patch/Index/Types.hs +84/−0
- src/Darcs/Patch/Info.hs +61/−107
- src/Darcs/Patch/Inspect.hs +3/−4
- src/Darcs/Patch/Invert.hs +10/−5
- src/Darcs/Patch/Match.hs +582/−77
- src/Darcs/Patch/MatchData.hs +0/−28
- src/Darcs/Patch/Matchable.hs +13/−0
- src/Darcs/Patch/MaybeInternal.hs +33/−0
- src/Darcs/Patch/Merge.hs +18/−10
- src/Darcs/Patch/MonadProgress.hs +57/−0
- src/Darcs/Patch/Named.hs +60/−34
- src/Darcs/Patch/OldDate.hs +20/−22
- src/Darcs/Patch/PatchInfoAnd.hs +71/−52
- src/Darcs/Patch/Patchy.hs +2/−4
- src/Darcs/Patch/Patchy/Instances.hs +1/−1
- src/Darcs/Patch/Permutations.hs +70/−99
- src/Darcs/Patch/Prim.hs +1/−1
- src/Darcs/Patch/Prim/Class.hs +59/−46
- src/Darcs/Patch/Prim/V1/Apply.hs +20/−19
- src/Darcs/Patch/Prim/V1/Coalesce.hs +80/−72
- src/Darcs/Patch/Prim/V1/Commute.hs +35/−21
- src/Darcs/Patch/Prim/V1/Core.hs +16/−14
- src/Darcs/Patch/Prim/V1/Details.hs +2/−3
- src/Darcs/Patch/Prim/V1/Read.hs +13/−14
- src/Darcs/Patch/Prim/V1/Show.hs +16/−21
- src/Darcs/Patch/Prim/V3/Apply.hs +15/−14
- src/Darcs/Patch/Prim/V3/Coalesce.hs +4/−7
- src/Darcs/Patch/Prim/V3/Commute.hs +10/−10
- src/Darcs/Patch/Prim/V3/Core.hs +31/−16
- src/Darcs/Patch/Prim/V3/Details.hs +0/−1
- src/Darcs/Patch/Prim/V3/Read.hs +5/−2
- src/Darcs/Patch/Prim/V3/Show.hs +5/−14
- src/Darcs/Patch/Progress.hs +74/−0
- src/Darcs/Patch/Read.hs +11/−12
- src/Darcs/Patch/ReadMonads.hs +12/−14
- src/Darcs/Patch/Rebase.hs +559/−0
- src/Darcs/Patch/Rebase/Fixup.hs +161/−0
- src/Darcs/Patch/Rebase/Name.hs +206/−0
- src/Darcs/Patch/Rebase/NameHack.hs +23/−0
- src/Darcs/Patch/Rebase/Recontext.hs +45/−0
- src/Darcs/Patch/Rebase/Viewing.hs +569/−0
- src/Darcs/Patch/RegChars.hs +4/−4
- src/Darcs/Patch/Repair.hs +5/−6
- src/Darcs/Patch/RepoPatch.hs +15/−4
- src/Darcs/Patch/Set.hs +88/−40
- src/Darcs/Patch/Show.hs +26/−30
- src/Darcs/Patch/Split.hs +29/−20
- src/Darcs/Patch/Summary.hs +10/−11
- src/Darcs/Patch/SummaryData.hs +1/−1
- src/Darcs/Patch/TokenReplace.hs +46/−37
- src/Darcs/Patch/TouchesFiles.hs +38/−43
- src/Darcs/Patch/Type.hs +7/−0
- src/Darcs/Patch/V1.hs +2/−0
- src/Darcs/Patch/V1/Apply.hs +2/−4
- src/Darcs/Patch/V1/Commute.hs +116/−80
- src/Darcs/Patch/V1/Core.hs +68/−18
- src/Darcs/Patch/V1/Read.hs +4/−5
- src/Darcs/Patch/V1/Show.hs +3/−14
- src/Darcs/Patch/V1/Viewing.hs +0/−2
- src/Darcs/Patch/V2.hs +2/−0
- src/Darcs/Patch/V2/Non.hs +55/−50
- src/Darcs/Patch/V2/Real.hs +147/−109
- src/Darcs/Patch/Viewing.hs +119/−101
- src/Darcs/Patch/Witnesses/Eq.hs +55/−0
- src/Darcs/Patch/Witnesses/Ordered.hs +456/−0
- src/Darcs/Patch/Witnesses/Sealed.hs +175/−0
- src/Darcs/Patch/Witnesses/Show.hs +56/−0
- src/Darcs/Patch/Witnesses/Unsafe.hs +25/−0
- src/Darcs/Patch/Witnesses/WZipper.hs +99/−0
- src/Darcs/PrintPatch.hs +0/−54
- src/Darcs/ProgressPatches.hs +0/−65
- src/Darcs/RemoteApply.hs +0/−60
- src/Darcs/RepoPath.hs +0/−264
- src/Darcs/Repository.hs +639/−282
- src/Darcs/Repository/ApplyPatches.hs +154/−18
- src/Darcs/Repository/Cache.hs +423/−295
- src/Darcs/Repository/Compat.hs +141/−0
- src/Darcs/Repository/Diff.hs +162/−0
- src/Darcs/Repository/External.hs +297/−0
- src/Darcs/Repository/Flags.hs +115/−0
- src/Darcs/Repository/Format.hs +178/−127
- src/Darcs/Repository/HashedIO.hs +97/−57
- src/Darcs/Repository/HashedRepo.hs +795/−467
- src/Darcs/Repository/Internal.hs +1022/−864
- src/Darcs/Repository/InternalTypes.hs +16/−17
- src/Darcs/Repository/Job.hs +236/−0
- src/Darcs/Repository/Lock.hs +382/−0
- src/Darcs/Repository/LowLevel.hs +80/−61
- src/Darcs/Repository/Match.hs +98/−0
- src/Darcs/Repository/Merge.hs +133/−82
- src/Darcs/Repository/Motd.hs +17/−14
- src/Darcs/Repository/Old.hs +32/−32
- src/Darcs/Repository/PatchIndex.hs +770/−0
- src/Darcs/Repository/Prefs.hs +434/−319
- src/Darcs/Repository/Read.hs +25/−0
- src/Darcs/Repository/Rebase.hs +223/−0
- src/Darcs/Repository/Repair.hs +65/−64
- src/Darcs/Repository/Resolution.hs +165/−0
- src/Darcs/Repository/Ssh.hs +233/−0
- src/Darcs/Repository/State.hs +169/−60
- src/Darcs/Repository/Test.hs +163/−0
- src/Darcs/Repository/Util.hs +340/−0
- src/Darcs/Resolution.hs +0/−164
- src/Darcs/RunCommand.hs +0/−192
- src/Darcs/SelectChanges.hs +0/−904
- src/Darcs/SignalHandler.hs +0/−151
- src/Darcs/Ssh.hs +0/−231
- src/Darcs/Test.hs +0/−95
- src/Darcs/Test/Email.hs +0/−93
- src/Darcs/Test/Misc.hs +0/−107
- src/Darcs/Test/Patch.hs +0/−370
- src/Darcs/Test/Patch/Arbitrary/Generic.hs +0/−231
- src/Darcs/Test/Patch/Arbitrary/PatchV1.hs +0/−288
- src/Darcs/Test/Patch/Arbitrary/PrimV1.hs +0/−394
- src/Darcs/Test/Patch/Arbitrary/PrimV3.hs +0/−259
- src/Darcs/Test/Patch/Arbitrary/Real.hs +0/−67
- src/Darcs/Test/Patch/Check.hs +0/−347
- src/Darcs/Test/Patch/Examples/Set1.hs +0/−419
- src/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs +0/−492
- src/Darcs/Test/Patch/Info.hs +0/−163
- src/Darcs/Test/Patch/Properties/Check.hs +0/−111
- src/Darcs/Test/Patch/Properties/Generic.hs +0/−369
- src/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs +0/−90
- src/Darcs/Test/Patch/Properties/Real.hs +0/−35
- src/Darcs/Test/Patch/Properties/V1Set1.hs +0/−155
- src/Darcs/Test/Patch/Properties/V1Set2.hs +0/−315
- src/Darcs/Test/Patch/RepoModel.hs +0/−23
- src/Darcs/Test/Patch/Utils.hs +0/−24
- src/Darcs/Test/Patch/V1Model.hs +0/−289
- src/Darcs/Test/Patch/V3Model.hs +0/−216
- src/Darcs/Test/Patch/WSub.hs +0/−138
- src/Darcs/Test/Patch/WithState.hs +0/−132
- src/Darcs/Test/Util/QuickCheck.hs +0/−58
- src/Darcs/Test/Util/TestResult.hs +0/−63
- src/Darcs/TheCommands.hs +0/−104
- src/Darcs/UI/ApplyPatches.hs +179/−0
- src/Darcs/UI/Commands.hs +504/−0
- src/Darcs/UI/Commands/Add.hs +383/−0
- src/Darcs/UI/Commands/Amend.hs +476/−0
- src/Darcs/UI/Commands/Annotate.hs +218/−0
- src/Darcs/UI/Commands/Apply.hs +432/−0
- src/Darcs/UI/Commands/Clone.hs +347/−0
- src/Darcs/UI/Commands/Convert.hs +971/−0
- src/Darcs/UI/Commands/Diff.hs +273/−0
- src/Darcs/UI/Commands/Dist.hs +232/−0
- src/Darcs/UI/Commands/GZCRCs.hs +217/−0
- src/Darcs/UI/Commands/Help.hs +421/−0
- src/Darcs/UI/Commands/Init.hs +110/−0
- src/Darcs/UI/Commands/Log.hs +469/−0
- src/Darcs/UI/Commands/MarkConflicts.hs +163/−0
- src/Darcs/UI/Commands/Move.hs +366/−0
- src/Darcs/UI/Commands/Optimize.hs +695/−0
- src/Darcs/UI/Commands/Pull.hs +489/−0
- src/Darcs/UI/Commands/Push.hs +286/−0
- src/Darcs/UI/Commands/Rebase.hs +1118/−0
- src/Darcs/UI/Commands/Record.hs +567/−0
- src/Darcs/UI/Commands/Remove.hs +207/−0
- src/Darcs/UI/Commands/Repair.hs +186/−0
- src/Darcs/UI/Commands/Replace.hs +298/−0
- src/Darcs/UI/Commands/Revert.hs +169/−0
- src/Darcs/UI/Commands/Rollback.hs +199/−0
- src/Darcs/UI/Commands/Send.hs +563/−0
- src/Darcs/UI/Commands/SetPref.hs +138/−0
- src/Darcs/UI/Commands/Show.hs +89/−0
- src/Darcs/UI/Commands/ShowAuthors.hs +228/−0
- src/Darcs/UI/Commands/ShowBug.hs +77/−0
- src/Darcs/UI/Commands/ShowContents.hs +122/−0
- src/Darcs/UI/Commands/ShowFiles.hs +169/−0
- src/Darcs/UI/Commands/ShowIndex.hs +124/−0
- src/Darcs/UI/Commands/ShowPatchIndex.hs +132/−0
- src/Darcs/UI/Commands/ShowRepo.hs +174/−0
- src/Darcs/UI/Commands/ShowTags.hs +108/−0
- src/Darcs/UI/Commands/Tag.hs +236/−0
- src/Darcs/UI/Commands/Test.hs +363/−0
- src/Darcs/UI/Commands/TransferMode.hs +112/−0
- src/Darcs/UI/Commands/Unrecord.hs +445/−0
- src/Darcs/UI/Commands/Unrevert.hs +203/−0
- src/Darcs/UI/Commands/Util.hs +115/−0
- src/Darcs/UI/Commands/Util/Tree.hs +74/−0
- src/Darcs/UI/Commands/WhatsNew.hs +403/−0
- src/Darcs/UI/CommandsAux.hs +78/−0
- src/Darcs/UI/Defaults.hs +232/−0
- src/Darcs/UI/Email.hs +256/−0
- src/Darcs/UI/External.hs +615/−0
- src/Darcs/UI/Flags.hs +536/−0
- src/Darcs/UI/Message/Send.hs +182/−0
- src/Darcs/UI/Options.hs +28/−0
- src/Darcs/UI/Options/All.hs +1235/−0
- src/Darcs/UI/Options/Core.hs +297/−0
- src/Darcs/UI/Options/Flags.hs +95/−0
- src/Darcs/UI/Options/Iso.hs +25/−0
- src/Darcs/UI/Options/Markdown.hs +35/−0
- src/Darcs/UI/Options/Matching.hs +245/−0
- src/Darcs/UI/Options/Util.hs +270/−0
- src/Darcs/UI/PrintPatch.hs +71/−0
- src/Darcs/UI/RemoteApply.hs +65/−0
- src/Darcs/UI/RunCommand.hs +222/−0
- src/Darcs/UI/SelectChanges.hs +1112/−0
- src/Darcs/UI/TheCommands.hs +102/−0
- src/Darcs/UI/Usage.hs +66/−0
- src/Darcs/URL.hs +0/−126
- src/Darcs/Util/AtExit.hs +80/−0
- src/Darcs/Util/Bug.hs +27/−0
- src/Darcs/Util/ByteString.hs +508/−0
- src/Darcs/Util/CommandLine.hs +140/−0
- src/Darcs/Util/Crypt/SHA1.hs +215/−0
- src/Darcs/Util/Crypt/SHA256.hs +9/−0
- src/Darcs/Util/DateMatcher.hs +189/−0
- src/Darcs/Util/DateTime.hs +76/−0
- src/Darcs/Util/Diff.hs +18/−0
- src/Darcs/Util/Diff/Myers.hs +494/−0
- src/Darcs/Util/Diff/Patience.hs +419/−0
- src/Darcs/Util/Download.hs +351/−0
- src/Darcs/Util/Download/Curl.hs +80/−0
- src/Darcs/Util/Download/HTTP.hs +113/−0
- src/Darcs/Util/Download/Request.hs +107/−0
- src/Darcs/Util/Encoding.hs +46/−0
- src/Darcs/Util/Encoding/IConv.hsc +184/−0
- src/Darcs/Util/Encoding/Win32.hs +80/−0
- src/Darcs/Util/English.hs +97/−0
- src/Darcs/Util/Environment.hs +15/−0
- src/Darcs/Util/Exception.hs +64/−0
- src/Darcs/Util/Exec.hs +251/−0
- src/Darcs/Util/File.hs +122/−0
- src/Darcs/Util/Global.hs +184/−0
- src/Darcs/Util/IsoDate.hs +880/−0
- src/Darcs/Util/Path.hs +555/−0
- src/Darcs/Util/Printer.hs +476/−0
- src/Darcs/Util/Printer/Color.hs +380/−0
- src/Darcs/Util/Progress.hs +294/−0
- src/Darcs/Util/Prompt.hs +102/−0
- src/Darcs/Util/Ratified.hs +8/−0
- src/Darcs/Util/Show.hs +16/−0
- src/Darcs/Util/SignalHandler.hs +142/−0
- src/Darcs/Util/Ssh.hs +91/−0
- src/Darcs/Util/Text.hs +50/−0
- src/Darcs/Util/URL.hs +126/−0
- src/Darcs/Util/Workaround.hs +147/−0
- src/Darcs/Utils.hs +0/−528
- src/Darcs/Witnesses/Eq.hs +0/−54
- src/Darcs/Witnesses/Ordered.hs +0/−301
- src/Darcs/Witnesses/Sealed.hs +0/−153
- src/Darcs/Witnesses/Show.hs +0/−47
- src/Darcs/Witnesses/Unsafe.hs +0/−24
- src/Darcs/Witnesses/WZipper.hs +0/−82
- src/DateMatcher.hs +0/−188
- src/Encoding.hs +0/−46
- src/Encoding/IConv.hsc +0/−184
- src/Encoding/Win32.hs +0/−80
- src/English.hs +0/−98
- src/Exec.hs +0/−215
- src/IsoDate.hs +0/−856
- src/Lcs.hs +0/−484
- src/Preproc.hs +0/−187
- src/Printer.lhs +0/−425
- src/Progress.hs +0/−305
- src/Ratified.hs +0/−8
- src/SHA1.hs +0/−212
- src/URL.hs +0/−332
- src/URL/Curl.hs +0/−80
- src/URL/HTTP.hs +0/−111
- src/URL/Request.hs +0/−59
- src/Workaround.hs +0/−148
- src/atomic_create.c +2/−1
- src/darcs.hs +0/−88
- src/gadts.h +0/−15
- src/hscurl.c +10/−2
- src/hscurl.h +2/−1
- src/impossible.h +1/−1
- src/test.hs +0/−206
- src/win32/CtrlC.hs +0/−21
- src/win32/Darcs/Util/CtrlC.hs +21/−0
- src/win32/System/Posix/IO.hsc +1/−1
- src/win32/send_email.c +1/−1
- tests/README.test_maintainers.txt +1/−112
- tests/add-formerly-pl.sh +8/−8
- tests/add.sh +1/−1
- tests/addexitval.sh +2/−2
- tests/addmv.sh +1/−1
- tests/addrace.sh +1/−1
- tests/addrm.sh +1/−1
- tests/amend-cancelling.sh +2/−2
- tests/amend-record-back-up.sh +1/−1
- tests/amend-record.sh +0/−78
- tests/amend-unrecord.sh +5/−5
- tests/amend.sh +78/−0
- tests/apply-hunks.sh +1/−1
- tests/apply-reorder.sh +67/−0
- tests/ask_deps.sh +5/−5
- tests/bad-match-pattern.sh +0/−38
- tests/bad_pending_after_pull.sh +3/−3
- tests/bin/trackdown-bisect-helper.hs +2/−2
- tests/binary.sh +1/−1
- tests/changes-duplicate.sh +49/−0
- tests/changes.sh +2/−2
- tests/changes_send_context.sh +1/−1
- tests/check.sh +0/−42
- tests/conflict-doppleganger.sh +2/−0
- tests/conflict-fight-failure.sh +1/−1
- tests/conflict-fight.sh +1/−1
- tests/convert.sh +6/−4
- tests/convert_export.sh +51/−0
- tests/data/context-v1.dpatch +6/−2
- tests/data/context-v2.dpatch +6/−2
- tests/data/convert/darcs2/resolution.dpatch +15/−5
- tests/data/convert/darcs2/simple.dpatch +3/−1
- tests/data/convert/darcs2/threewayanddep.dpatch +15/−5
- tests/data/convert/darcs2/threewayandmultideps.dpatch +21/−7
- tests/data/convert/darcs2/threewayconflict.dpatch +12/−4
- tests/data/convert/darcs2/tworesolutions.dpatch +21/−7
- tests/data/convert/darcs2/twowayconflict.dpatch +9/−3
- tests/data/laziness-complete.tgz binary
- tests/data/laziness-cut.tgz binary
- tests/data/old-with-checkpoint.tgz binary
- tests/data/simple-v1.dpatch +3/−1
- tests/data/simple-v2.dpatch +3/−1
- tests/data/split--old-fashioned-inventory.tgz binary
- tests/diff.sh +8/−3
- tests/directory_confusion.sh +2/−2
- tests/disable.sh +28/−11
- tests/dist-v.sh +1/−1
- tests/dist.sh +13/−1
- tests/double-unrevert.sh +2/−2
- tests/emailformat.sh +3/−3
- tests/failed-amend-should-not-break-repo.sh +1/−2
- tests/failing-issue1013_either_dependency.sh +1/−1
- tests/failing-issue1014_identical_patches.sh +1/−1
- tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh +1/−1
- tests/failing-issue1266_init_inside_a_repo.sh +0/−33
- tests/failing-issue1316-2.sh +49/−0
- tests/failing-issue1316.sh +36/−0
- tests/failing-issue1327.sh +2/−2
- tests/failing-issue1332_add_r_boring.sh +45/−0
- tests/failing-issue1396_changepref-conflict.sh +1/−3
- tests/failing-issue1401_bug_in_get_extra.sh +2/−0
- tests/failing-issue1406.sh +2/−25
- tests/failing-issue1577-revert-deletes-new-files.sh +34/−0
- tests/failing-issue1579_diff_opts.sh +46/−0
- tests/failing-issue1610_get_extra.sh +2/−0
- tests/failing-issue1702-optimize-relink-vs-cache.sh +1/−1
- tests/failing-issue1845-paths-working-copy.sh +0/−37
- tests/failing-issue1926_amend-record_ignores_--index.sh +1/−1
- tests/failing-issue1932-colon-breaks-add.sh +0/−77
- tests/failing-issue1959-unwritable-cache.sh +38/−0
- tests/failing-issue2047_duplicate_conflictor_recommute_fail.sh +127/−0
- tests/failing-issue2066_add_and_remove.sh +0/−41
- tests/failing-issue2100-add-failures.sh +2/−2
- tests/failing-issue2138-whatsnew-s.sh +59/−0
- tests/failing-issue2186-apply--reply-conflict.sh +55/−0
- tests/failing-issue2186-apply--reply-ok.sh +50/−0
- tests/failing-issue2187-apply--test-non-interactive.sh +43/−0
- tests/failing-issue2203-only-list-toplevel-deleted-dirs.sh +43/−0
- tests/failing-issue2208-replace-fails-with-resolving-unrecorded-change.sh +53/−0
- tests/failing-issue2213-lastregrets-dependencies.sh +41/−0
- tests/failing-issue2219-no-working.sh +69/−0
- tests/failing-issue2234-rollback-under-tag-with-filename.sh +52/−0
- tests/failing-issue2238-unadded-files-showing-added.sh +37/−0
- tests/failing-issue2242-rollback-mv.sh +46/−0
- tests/failing-issue2243-unknown-patch-annotating-empty-first-line.sh +37/−0
- tests/failing-issue2256-diff-empty-argument.sh +43/−0
- tests/failing-issue2257-impossible-obliterate-subset.sh +64/−0
- tests/failing-issue2272-rebase-unsuspend-copes-with-unrecorded-changes.sh +52/−0
- tests/failing-issue2293-laziness-amend.sh +35/−0
- tests/failing-issue2303-diagnostic-for-bad-patch-index-permissions.sh +43/−0
- tests/failing-issue2308-changes-missing-amend-edit.sh +54/−0
- tests/failing-issue2310-rollback-doesnt-readd.sh +43/−0
- tests/failing-issue2380-rename-to-deleted-file.sh +47/−0
- tests/failing-issue2383-hunk-edit-fails.sh +76/−0
- tests/failing-issue2386-no-trailing-EOL.sh +56/−0
- tests/failing-issue390_whatsnew.sh +1/−1
- tests/failing-issue612_repo_not_writable.sh +0/−4
- tests/failing-issue68_broken_pipe.sh +1/−1
- tests/failing-look_for_moves.sh +39/−0
- tests/failing-look_for_replaces1.sh +49/−0
- tests/failing-look_for_replaces2.sh +44/−0
- tests/failing-merging_newlines.sh +1/−1
- tests/failing-newlines.sh +2/−2
- tests/failing-nice-resolutions.sh +1/−1
- tests/failing-pristine-problems.sh +0/−2
- tests/filepath.sh +6/−6
- tests/get-http-packed-detect.sh +15/−16
- tests/get-http-packed.sh +12/−13
- tests/get_tag.sh +2/−2
- tests/harness.sh +1/−1
- tests/hashed_inventory.sh +8/−8
- tests/hidden_conflict.sh +1/−1
- tests/hidden_conflict2.sh +1/−1
- tests/hunk-editor.sh +1/−1
- tests/ignoretimes.sh +1/−1
- tests/illegal_mv.sh +1/−1
- tests/impossible_unrevert.sh +7/−7
- tests/init.sh +7/−1
- tests/invalid_pending_after_mv_to_self.sh +1/−1
- tests/issue1012_unrecord_remove.sh +3/−3
- tests/issue1017_whatsnew_stack.sh +1/−1
- tests/issue1039.sh +3/−3
- tests/issue1043_geteff_a.sh +1/−1
- tests/issue1043_geteff_b.sh +1/−1
- tests/issue1101.sh +3/−3
- tests/issue1105.sh +2/−0
- tests/issue1110_get_hashed.sh +1/−1
- tests/issue1139-diff-last.sh +2/−2
- tests/issue1139-diff-with-no-args.sh +2/−2
- tests/issue1162_add_nonexistent_slash.sh +1/−1
- tests/issue121.sh +1/−1
- tests/issue1210-no-global-cache-in-sources.sh +1/−3
- tests/issue1248.sh +1/−1
- tests/issue1266_init_inside_a_repo.sh +33/−0
- tests/issue1269_setpref_predist.sh +1/−1
- tests/issue1290-diff-index.sh +5/−2
- tests/issue1332_add_r_boring.sh +0/−45
- tests/issue1344_abort_early_cant_send.sh +2/−4
- tests/issue1427_apply_gz.sh +1/−1
- tests/issue1473_annotate_repodir.sh +1/−2
- tests/issue1514-send-minimize.sh +59/−0
- tests/issue157_rollback_conflict.sh +0/−44
- tests/issue1584_optimize_upgrade.sh +1/−1
- tests/issue1599-automatically-expire-unused-caches.sh +1/−3
- tests/issue1618-amend-preserve-logfile.sh +1/−2
- tests/issue1620-record-lies-about-leaving-logfile.sh +1/−2
- tests/issue1645-ignore-symlinks-case-fold.sh +2/−2
- tests/issue1645-ignore-symlinks.sh +6/−6
- tests/issue1739-escape-multibyte-chars-correctly.sh +7/−1
- tests/issue1749-rmdir.sh +1/−1
- tests/issue1845-paths-working-copy.sh +37/−0
- tests/issue1845-record-removed.sh +1/−1
- tests/issue1871-record-dot.sh +2/−2
- tests/issue1873-apply-failed-to-read-patch.sh +1/−1
- tests/issue1909-unrecord-O-misses-tag.sh +1/−1
- tests/issue1921-missing-tag-in-apply-bundle.sh +69/−0
- tests/issue1922-obliterate-o-context.sh +1/−1
- tests/issue1923-cache-warning.sh +0/−2
- tests/issue1932-colon-breaks-add.sh +80/−0
- tests/issue194.sh +1/−1
- tests/issue1977-darcs-repair.sh +1/−1
- tests/issue1978.sh +3/−5
- tests/issue1987.sh +235/−0
- tests/issue2012_send_output_no_address.sh +1/−3
- tests/issue2013_send_to_context.sh +3/−5
- tests/issue2052-default-unified-diff.sh +1/−1
- tests/issue2066-record-file-not-exist.sh +0/−13
- tests/issue2066_add_and_remove.sh +41/−0
- tests/issue2125-always-warn-forced-replace.sh +75/−0
- tests/issue2136-changes_created_as_for_multiple_files.sh +2/−2
- tests/issue2153-allow-skipping-backwards-through-depended_upon-patches.sh +35/−0
- tests/issue2179-diff-with-dir-path.sh +46/−0
- tests/issue2193-apply-runs-test-twice.sh +43/−0
- tests/issue2200-darcs-replace-no-paths.sh +44/−0
- tests/issue2204-send-mail.sh +64/−0
- tests/issue2207-annotate-directory.sh +39/−0
- tests/issue2209-look_for_replaces.sh +323/−0
- tests/issue2212-add-changes-pending-for-other-files.sh +53/−0
- tests/issue2225-obliterate-not-in.sh +58/−0
- tests/issue2227-rebase-amend-record.sh +49/−0
- tests/issue2230-invalid-context-too-late.sh +36/−0
- tests/issue2244-dup-tag-warning.sh +13/−0
- tests/issue2248-rebase-zero-suspended.sh +45/−0
- tests/issue2253-make-patch-index-oldfashioned.sh +32/−0
- tests/issue2270-changes-interactive-only-to-files.sh +139/−0
- tests/issue2271-disable-patch-index.sh +39/−0
- tests/issue2286-metadata-encoding.sh +1/−1
- tests/issue2287_obliterate_overwrite.sh +59/−0
- tests/issue2311_posthook_for_get_should_run_in_created_repo.sh +48/−0
- tests/issue2312_posthooks_for_record_and_amend-record_should_receive_DARCS_PATCHES.sh +94/−0
- tests/issue2313-trailing-newlines-stack-overflow.sh +17/−0
- tests/issue2333.sh +16/−0
- tests/issue2343.sh +65/−0
- tests/issue2365-whatsnew-fails-get-no-working-dir.sh +40/−0
- tests/issue2382-mv-dir-to-file-confuses-darcs.sh +179/−0
- tests/issue2388-optimize-fails-no-changes.sh +30/−0
- tests/issue2432-pull-reorder-commute.sh +47/−0
- tests/issue244_changes.sh +1/−1
- tests/issue27.sh +1/−1
- tests/issue279_get_extra.sh +1/−1
- tests/issue381.sh +1/−1
- tests/issue436.sh +4/−1
- tests/issue458.sh +1/−1
- tests/issue494-pending-sort.sh +41/−0
- tests/issue525_amend_duplicates.sh +1/−1
- tests/issue538.sh +7/−7
- tests/issue588.sh +2/−2
- tests/issue691.sh +1/−1
- tests/issue706.sh +1/−1
- tests/issue709_pending_look-for-adds.sh +1/−3
- tests/issue761-fail-early-bad-pull-match.sh +38/−0
- tests/issue844_gzip_crc.sh +2/−2
- tests/issue864_replace_in_moved.sh +0/−57
- tests/issue966_diff.sh +2/−2
- tests/justrm.sh +1/−1
- tests/latin9-input.sh +193/−0
- tests/lazy-optimize-reorder.sh +2/−2
- tests/lib +14/−1
- tests/look_for_add.sh +1/−1
- tests/look_for_moves.sh +179/−0
- tests/match-date.sh +2/−2
- tests/match.sh +10/−0
- tests/merge_three_patches.sh +1/−1
- tests/mergeresolved.sh +1/−1
- tests/mv-test-suite.sh +1/−1
- tests/mv.sh +1/−1
- tests/mv_and_remove_tests.sh +1/−1
- tests/mv_then_add.sh +1/−1
- tests/network/changes.sh +0/−5
- tests/network/clone.sh +19/−0
- tests/network/external.sh +3/−3
- tests/network/get.sh +0/−19
- tests/network/issue1503_prefer_local_caches_to_remote_one.sh +2/−2
- tests/network/issue2090-transfer-mode.sh +2/−3
- tests/network/lazy-clone.sh +22/−0
- tests/network/lazy-get.sh +0/−22
- tests/network/log.sh +5/−0
- tests/network/ssh.sh +13/−13
- tests/nfs-failure.sh +1/−1
- tests/nodeps.sh +1/−1
- tests/nonewline.sh +1/−1
- tests/obliterate-formerly-pl.sh +2/−2
- tests/obliterate.sh +6/−6
- tests/oldfashioned_refusal.sh +1/−3
- tests/optimize.sh +2/−2
- tests/optimize_relink.sh +4/−4
- tests/output.sh +6/−6
- tests/overriding-defaults.sh +33/−24
- tests/patch-index-annotate.sh +46/−0
- tests/patch-index-creation.sh +99/−0
- tests/patch-index-enabled-and-disabled.sh +62/−0
- tests/patch-index-log.sh +77/−0
- tests/patch-index-rename.sh +38/−0
- tests/patch-index-spans.sh +69/−0
- tests/patch-index-sync.sh +70/−0
- tests/pending.sh +1/−1
- tests/perms.sh +1/−1
- tests/posthook.sh +1/−3
- tests/prefs.sh +1/−1
- tests/prefs_binary.sh +2/−2
- tests/prehook.sh +1/−1
- tests/pull-dont-prompt-deps.sh +3/−3
- tests/pull-reorder.sh +66/−0
- tests/pull.sh +6/−5
- tests/pull_binary.sh +2/−2
- tests/pull_compl.sh +1/−1
- tests/pull_many_files.sh +5/−3
- tests/pull_two.sh +1/−1
- tests/push-dont-prompt-deps.sh +3/−3
- tests/push-dry-run.sh +1/−1
- tests/push.sh +1/−1
- tests/push_lock.sh +1/−1
- tests/put.sh +0/−30
- tests/query_manifest.sh +1/−1
- tests/rebase-amend.sh +45/−0
- tests/rebase-apply.sh +89/−0
- tests/rebase-basic.sh +39/−0
- tests/rebase-count.sh +43/−0
- tests/rebase-keeps-deps-on-amend.sh +68/−0
- tests/rebase-keeps-deps.sh +65/−0
- tests/rebase-move-2.sh +53/−0
- tests/rebase-move.sh +47/−0
- tests/rebase-nochanges.sh +62/−0
- tests/rebase-obliterate.sh +43/−0
- tests/rebase-pull-reorder.sh +48/−0
- tests/rebase-pull-tag.sh +50/−0
- tests/rebase-pull.sh +88/−0
- tests/rebase-remote.sh +67/−0
- tests/rebase-repull.sh +42/−0
- tests/rebase-skip-conflicts.sh +81/−0
- tests/rebase-suspend-from-patch.sh +46/−0
- tests/rebase-tag.sh +39/−0
- tests/rebase-unsuspend-to-patch.sh +47/−0
- tests/record-misc.sh +61/−0
- tests/record.sh +0/−54
- tests/record_editor.sh +4/−6
- tests/recordrace.sh +1/−1
- tests/rename_shouldnt_affect_prefixes.sh +1/−1
- tests/renames.sh +29/−0
- tests/repair-clean.sh +1/−1
- tests/repair-corrupt-add.sh +2/−2
- tests/repair-corrupt.sh +1/−1
- tests/repair.sh +1/−1
- tests/replace.sh +1/−1
- tests/replace_after_pending_add.sh +1/−1
- tests/replace_after_pending_mv.sh +1/−1
- tests/repoformat.sh +4/−6
- tests/revert_interactive.sh +1/−1
- tests/revert_unrecorded_add.sh +1/−1
- tests/rmconflict.sh +1/−1
- tests/rmdir.sh +1/−1
- tests/rollback-no-record.sh +0/−67
- tests/rollback-nothing.sh +2/−2
- tests/rollback.sh +0/−34
- tests/sametwice.sh +1/−1
- tests/send-dont-prompt-deps.sh +3/−3
- tests/send-encoding.sh +1/−1
- tests/send-external.sh +3/−2
- tests/send-output-v1.sh +7/−5
- tests/send-output-v2.sh +6/−4
- tests/send.sh +1/−1
- tests/send_apply.sh +1/−1
- tests/set-default-hint.sh +9/−6
- tests/several_commands.sh +1/−1
- tests/show-authors.sh +12/−9
- tests/show_tags.sh +1/−1
- tests/sigPIPE.sh +0/−34
- tests/split-patches.sh +4/−5
- tests/steve_and_monica_rollback.sh +0/−38
- tests/tag-ask-deps.sh +51/−0
- tests/tentative_revert.sh +1/−2
- tests/test.sh +42/−0
- tests/three_way_conflict.sh +1/−1
- tests/toolbox.sh +1/−4
- tests/trackdown-bisect.sh +20/−53
- tests/tricky_unrecord.sh +1/−1
- tests/uniqueoptions.sh +1/−1
- tests/unpull-formerly-pl.sh +6/−6
- tests/unpull.sh +2/−2
- tests/unrecord-add.sh +1/−1
- tests/unrecord-dont-prompt.sh +2/−2
- tests/unrecord-remove.sh +1/−1
- tests/unrecord-setpref.sh +1/−1
- tests/unrevert.sh +1/−1
- tests/unrevert_cancel.sh +3/−3
- tests/utf8-display.sh +46/−0
- tests/utf8.sh +0/−193
- tests/v1-braced.sh +3/−1
- tests/what_sl.sh +1/−1
- tests/whatsnew-interactive.sh +46/−0
GNUmakefile view
@@ -1,44 +1,10 @@-### XXX we eventually want building of the manual to be part of Setup.lhs--# hardcode some bits-RUBBER=rubber--DARCS = dist/build/darcs/darcs-PREPROC=./dist/build/darcs/darcs --preprocess-manual-PREPROCHTML=--html-TEXSOURCES = doc/src/darcs.tex $(wildcard doc/src/*.tex) $(filter %.lhs,$(DARCS_FILES))-doc/manual/darcs.tex: $(TEXSOURCES) $(DARCS)- mkdir -p doc/manual- $(PREPROC) darcs.tex $(PREPROCHTML) >$@-doc/manual/darcs_print.tex: $(TEXSOURCES) $(DARCS)- mkdir -p doc/manual- $(PREPROC) darcs.tex >$@--%.pdf: %.tex- cd $(<D) && $(RUBBER) --pdf $(<F)--pdf: %: doc/manual/darcs.%-html: doc/manual/index.html-website: pdf html doc/manual/bigpage.html--### TODO use latex2html since bigpage seems to needslatex2html anyway;-### we can restore hevea/tex4ht support when we move this to Setup.lhs-doc/manual/index.html: doc/manual/darcs.tex doc/src/gpl.tex doc/darcs.css- latex2html -long_titles 2 -split +1 -dir doc/manual doc/manual/darcs.tex- cp -f doc/darcs.css doc/manual/darcs.css--doc/manual/bigpage.html: doc/manual/darcs.tex doc/src/gpl.tex doc/darcs.css- ln -sf darcs.tex doc/manual/bigpage.tex- latex2html -split 0 -external_file darcs -prefix big \- -no_auto_link -dir doc/manual doc/manual/bigpage.tex- cp -f doc/darcs.css doc/manual/bigpage.css--doc/manual/darcs.pdf: doc/manual/darcs_print.pdf- cp $< $@- # Good for tags. DARCS_FILES = $(wildcard src/[A-Z]*.hs src/*/[A-Z]*.hs src/*/*/[A-Z]*.hs) \- $(wildcard src/[A-Z]*.lhs src/*/[A-Z]*.lhs src/*/*/[A-Z]*.lhs)+ $(wildcard src/*/*/*/[A-Z]*.hs src/*/*/*/*/[A-Z]*.hs) \+ $(wildcard darcs/[A-Z]*.hs) \+ $(wildcard harness/[A-Z]*.hs harness/*/[A-Z]*.hs) \+ $(wildcard harness/*/*/[A-Z]*.hs harness/*/*/*/[A-Z]*.hs) \+ $(wildcard harness/*/*/*/*/[A-Z]*.hs) tags: $(DARCS_FILES) src/*.c hasktags -c $(filter %.lhs %.hs,$^)@@ -51,12 +17,3 @@ clean: rm -f TAGS tags- rm -f doc/manual/bigpage.tex doc/manual/bigpage.css- rm -f doc/manual/bigimg*.png doc/manual/bigimages.*- rm -f doc/manual/*.html doc/manual/darcs*.??? doc/manual/darcs.lg- rm -f doc/manual/darcs.html- rm -f doc/manual/darcs.xref c_context.c- rm -f doc/manual/WARNINGS doc/manual/*.pl- rm -f doc/manual/images.* doc/manual/img*.png doc/manual/*.html--.PHONY: pdf html clean website
NEWS view
@@ -1,28 +1,150 @@+Darcs 2.10.0, 19 April 2015++ * Important changes in Darcs 2.10++ * darcs rebase: enable deep amending of history+ * darcs pull --reorder: keep local-only patches on top of mainstream patches+ * darcs dist --zip: generate a zip archive from a repository+ * patch bundle contexts are minimized by default.+ * darcs convert export/import for conversion+ to/from VCSes supporting the fast-export protocol+ * darcs test --backoff: exponential backoff test strategy,+ faster than bisect on big repositories+ * work normally on sshfs-mounted repositories+ * automatic detection of file/directory moves, and of token replaces+ * patience diff algorithm by default+ * interactive mode for whatsnew+ * tag --ask-deps: create tags that may not include some patches+ * add a last question after all patches have been selected to confirm+ the whole selection+ * command names:+ * `clone` is the new name of `get` and `put`+ * `log` is the new name of `changes`+ * `amend` is the new name of `amend-record`+ * show output of `log` into a pager by default+ * the output of `log` is more similar to git's:+ * show patch hash in UI (hash of the patch's metadata)+ * put author and date on separate lines+ * enable to match on patch hash prefix with -h and --hash+ * better messages:+ * better error messages for http and ssh errors+ * `init`, `add`, `remove`, `move` and `replace` print+ confirmation messages+ * `rollback` only happens in the working copy+ * `darcs send` no longer tries to send a mail by default+ * when no patch name given, directly invoke text editor+ * use nano as default text editor instead of vi+ * keep log files for patch name and mail content in _darcs+ * `optimize` and `convert` are now supercommands+ * improve `darcs help environment` and `darcs help markdown`+ * warn about duplicate tags when creating a new one+ * allow `darcs mv` into known, but deleted in working, file+ * improve` --not-in-remote`, allowing multiple repos and use default+ * faster `darcs diff`+ * faster `log` and `annotate` thanks to patch index data structure+ * faster push via ssh by using compression+ * cloning to an ssh destination (formerly `darcs put`) is more efficient+ * faster internal representation of patch hashes+ * when cloning from http, use packs in a more predictable way+ * store global cache in bucketed format+ * require and support GHC 7.4 to 7.10++ * Other issues resolved in Darcs 2.10++ * 346: implement "patience diff" from bzr+ * 642: Automatic detection of file renames+ * 822: generalized the IO Type for better error messages and exception handling+ * 851: interactive mode for whatsnew+ * 904: Fix record on Linux/FUSE/sshfs (fall back to sloppy locks automatically)+ * 1066: clone to ssh URL by locally cloning then copying by scp+ * 1268: enable to write darcs init x+ * 1416: put log files in tempdir instead of in working dir+ * 1514: send --minimize-context flag for send+ * 1624: bucketed cache+ * 1828: file listing and working --dry-run for mark-conflicts+ * 1987: Garbage collection for inventories and patches+ * 2181: put cache in $XDG_CACHE_HOME (~/.cache by default)+ * 2193: make that finalizeTentativeChanges no longer run tests+ * 2198: move repo testing code to Darcs.Repository.Test+ * 2200: darcs replace complains if no filepaths given+ * 2204: do not send mail by default+ * 2237: prevent patch index creation for non-hashed repos+ * 2235: Accept RFC2822 dates+ * 2246: add default boring entry for emacs session save files+ * 2253: attempting to use the patch index shouldn't create it on OF repos+ * 2278: Document default value for --keep-date / --no-keep-date+ * 2199: getMatchingTag needs to commute for dirty tags+ * 2247: move patch index creation into the job running code+ * 2238: let optsModifier remove all occurrences of LookForAdds+ * 2236: make 'n' an alias for 'q' in lastregret questions+ * 2155: Expurgate the non-functional annotate --xml-output option+ * 2248: always clean up rebase-in-progress state+ * 2270: fixed darcs changes -i --only-to-files+ * 2282: don't allow remote operations to copy the rebase patch+ * 2287: obliterate -O doesn't overwrite existing file.+ * 2227: move the rebase patch to the end before an amend-record+ * 2277: rebase suspend and unsuspend supports --summary.+ * 2311: posthook for 'get' should run in created repo+ * 2312: posthooks for 'record' and 'amend-record' should receive DARCS_PATCHES+ * 2163: new option for amend, select author for patch stealing.+ * 2321: when no patch name given, directly invoke text editor+ * 2320: save prompted author name in ~/.darcs/author instead of ./_darcs/prefs/author+ * 2250: tabbing in usageHelper - pad by max length of command name+ * 2309: annotate includes line numbers+ * 2334: fix win32 build removing file permission functions+ * 2343: darcs amend-record does not record my change+ * 2335: one liner when adding tracked files if not verbose+ * 2313: whatsnew -l: Stack space overflow+ * 2347: fix amend-record --prompt-long-comment+ * 2348: switch to cabal's test framework+ * 2209: Automatically detect replace+ * 2332: ignore case of characters in prompt+ * 2263: Option --set-scripts-executable is not properly documented+ * 2367: rename amend-record to amend, make --unrecord more visible+ * 2345: solution using cabal's checkForeignDeps+ * 2357: switching to regex-compat-tdfa for unicode support+ * 2379: only use packs to copy pristine when up-to-date+ * 2365: correctly copy pristine in no-working-dir clones+ * 2244: darcs tag should warn about duplicate tags+ * 2364: don't break list of 'bad sources'+ * 2361: optimize --reorder runs forever with one repository+ * 2364: fix file corruption on double fetch+ * 2394: make optimize a supercommand+ * 2396: make convert a supercommand and enhance help strings+ * 2314: output-auto-name in defaults file+ * 2388: check if inventories dir has been created+ * 2249: Rename isFile to isValidLocalPath and WorkRepoURL to WorkRepoPossibleURL+ * 2153: allow skipping backwards through depended-upon patches+ * 2380: allow darcs mv into known, but deleted in working, file+ * 2403: need to avoid moving the rebase patch to the end+ * 2409: implement darcs rebase apply+ * 2385: invoke pager without temporary file+ * 2333: better error message when pushing and darcs not in path++ Darcs 2.8.5, 25 August 2014- * GHC 7.8 support- * Resolve issue2364: Download problems with GHC 7.8- * Bump some dependencies: base, network, unix, process, array, mtl, text- * Support matching on short patch hash- * Resolve issue2345: Fix bug where configure script reported missing libiconv rather than libcurl- * Darcs API: Rename iconv functions imported from haskeline to avoid name clash + * GHC 7.8 support+ * Resolved issue2364: Download problems with GHC 7.8+ * Support matching on short patch hash+ * Resolved issue2345: Fix bug where configure script reported missing libiconv rather than libcurl+ Darcs 2.8.4, 7 February 2013- * 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 + * GHC 7.6 support+ * Resolved issue2199: get --tag can include extra patches+ * Removed the --xml-output option to annotate which has been non-functional for a while+ Darcs 2.8.3, 4 November 2012 - * Darcs API: #ifdef some FFI imports so ghci works with -f-curl- * Darcs API: Use darcs-specific names in sha2.c to avoid clashes with other packages+ * Tweak the library to avoid a C symbol clash with cryptohash -Darcs 2.8.2, 3 September 2012+Darcs 2.8.2, 2 September 2012 - * Added PrimV1Job type to API to support darcsden+ * Addition to the Darcs API to support darcsden Darcs 2.8.1, 14 May 2012
README view
@@ -1,18 +1,17 @@ Darcs =====+ This is the source tree for darcs, a distributed version control system written in Haskell. -For more information, visit the darcs web site:-- http://www.darcs.net+For more information, visit the darcs website: <http://www.darcs.net>. Compilation and Installation ============================ Building Darcs is best done with the Haskell Platform:-http://www.haskell.org/platform/. Any release of darcs should build with+<http://www.haskell.org/platform/>. Any release of darcs should build with the most recent version of the Platform at the time of the release. This will also generally apply to unstable versions. @@ -25,7 +24,7 @@ If you have the Platform or otherwise have the "cabal-install" package on your system (that is, there is a "cabal" executable in your path), you can use the following command to create an executable in-~/.cabal/bin/darcs (this will also automatically fetch and build+`~/.cabal/bin/darcs` (this will also automatically fetch and build dependencies from the Hackage server). $ cabal update@@ -39,45 +38,54 @@ $ sudo runghc Setup install You may also omit the last step and copy the darcs executable (found in-dist/build/darcs/darcs) to a location of your choosing.+`dist/build/darcs/darcs`) to a location of your choosing. More detailed instructions can be found at <http://www.haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package> including instructions on obtaining a copy of cabal-install. -Please also note that the cabal-based build by default requires the cURL-library (and development headers). If, for some reason, you cannot provide-cURL, please pass "-f-curl" to the configure step above. +Flags to alter compilation+========================== +There some flags that can be used to alter compilation. They are specified like this:++ $ cabal install -fflag_name++Here are some may be of interest. Search for "flags" in the `darcs.cabal` file+file for the complete list.++* `-f-curl`:+ By default the cabal-based build requires the cURL library and development+ headers. If you can't provide cURL, use this flag to disable the use of it.+ The pure Haskell 'HTTP' package will be used instead.++* `-frts`:+ When trying to use the patch-index feature, you can may get an error like+ this: "Stack space overflow: current size 8388608 bytes." darcs can be+ recompiled with this flag to avoid the issue. Some more detail is here:+ <http://darcs.net/Using/PatchIndex>++* `-fstatic`:+ Builds a static binary, which bundles most dependencies. The resulting binary+ is larger, but is able to be installed on similar machines without also+ installing all the dependencies separately.+ Hacking =======-For more information about darcs hacking and best practices please check-the darcs wiki at http://wiki.darcs.net -Of particular interest are the following documents:- * http://wiki.darcs.net/Development/GettingStarted- * http://wiki.darcs.net/Development/FAQ+For more information about darcs hacking and best practices please check+the darcs website <http://wiki.darcs.net> -Comments about do-notation warnings-===================================-You may find a number of comments (163 of them at the time of writing) looking-like:--- Warning: A do-notation statement discarded a result of type Whatever.-They signal warnings issued by GHC that have been automatically silenced.-See http://bugs.darcs.net/issue1988 for more detail.+Of particular interest are the following pages: -These warnings were most certainly harmless, but who knows... If you stumble-upon one such comment, take a minute or two to check if it is really okay to-ignore the return value (look for "_ <- " on the line next to the comment). If-everything is correct, please remove the comment and send a patch (mentioning-issue1988). If it isn't, you have found a bug, congratulations! Fix it, or-fill a bug report on http//bugs.darcs.net/. Finally, if in doubt, leave it as-is. Many thanks.+* <http://darcs.net/Development/GettingStarted>+* <http://darcs.net/Development/FAQ> Testing =======+ For more information about the test suite, including how to run specific-tests please read tests/README.test_maintainers.txt.+tests <http://darcs.net/Development/RegressionTests>. Happy hacking!
Setup.lhs view
@@ -1,5 +1,5 @@ \begin{code}-{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} -- copyright (c) 2008 Duncan Coutts -- portions copyright (c) 2008 David Roundy -- portions copyright (c) 2007-2009 Judah Jacobson@@ -14,17 +14,18 @@ ( checkForeignDeps ) import Distribution.ModuleName( toFilePath ) import Distribution.PackageDescription- ( PackageDescription(executables), Executable(buildInfo, exeName)+ ( PackageDescription(executables, testSuites), Executable(buildInfo, exeName) , BuildInfo(customFieldsBI), emptyBuildInfo+ , TestSuite(testBuildInfo) , FlagName(FlagName) , updatePackageDescription , cppOptions, ccOptions, ldOptions , library, libBuildInfo, otherModules , extraLibs, extraLibDirs, includeDirs ) import Distribution.Package- ( packageVersion, packageName, PackageName(..) )+ ( packageVersion, packageName, PackageName(..), Package ) import Distribution.Version- ( Version(versionBranch) )+ ( Version(Version, versionBranch) ) import Data.Version( showVersion ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), absoluteInstallDirs, externalPackageDeps )@@ -35,21 +36,23 @@ (buildVerbosity, copyDest, copyVerbosity, fromFlag, haddockVerbosity, installVerbosity, sDistVerbosity, configVerbosity, ConfigFlags, configConfigurationsFlags)+import qualified Distribution.Simple.Setup as DSS -- to get replVerbosity in Cabal > 1.18 import Distribution.Simple.BuildPaths ( autogenModulesDir, exeExtension ) import Distribution.System ( OS(Windows), buildOS ) import Distribution.Simple.Utils (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout,- rewriteFile, withTempFile)+ rewriteFile, withTempFile, cabalVersion) import Distribution.Verbosity ( Verbosity ) import Distribution.Text ( display )-import Distribution.Package (Package)- import Control.Monad ( zipWithM_, when, unless, filterM ) import Control.Exception ( bracket, handle, IOException )++import Language.Haskell.TH ( mkName, newName, recUpdE, varE, appE, lamE, varP )+ import System.Directory (copyFile, createDirectory, createDirectoryIfMissing, doesDirectoryExist, doesFileExist,@@ -64,32 +67,44 @@ ) import System.Process (runProcess) import System.IO.Error ( isDoesNotExistError )-import Data.List( isPrefixOf, isSuffixOf, sort, partition )--import System.Cmd( rawSystem )-import System.Exit( exitWith )+import Data.List( isPrefixOf, isSuffixOf, sort )+import System.Process( rawSystem ) import System.FilePath ( (</>), (<.>), splitDirectories, isAbsolute ) import Foreign.Marshal.Utils ( with ) import Foreign.Storable ( peek ) import Foreign.Ptr ( castPtr )+import Data.Monoid ( mappend ) import Data.Word ( Word8, Word32 ) import qualified Control.Exception as Exception --- Handle exceptions migration. We could use extensible-exceptions--- but Cabal can't handle package dependencies of Setup.lhs--- automatically so it'd be disruptive for users.--- Once we drop older GHCs we can clean up the use sites properly--- and perhaps think about being more restrictive in which exceptions--- are caught at each site.-#if __GLASGOW_HASKELL__ >= 610 catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException))-#else-catchAny = Exception.catch-#endif +{- Template Haskell hackery for replHook while we want to support Cabal < 1.18 -}+replVerbosity =+ $(if cabalVersion >= Version [1,18,0] []+ then varE (mkName "DSS.replVerbosity")+ else [| error "This shouldn't be called" |]+ )++replHookBody replHookSel =+ \pkg lbi hooks flags args ->+ let verb = fromFlag $ replVerbosity flags+ in commonBuildHook replHookSel pkg lbi hooks verb >>= (\f -> f flags args)++addReplHook =+ $(if cabalVersion >= Version [1,18,0] []+ then+ do hooks <- newName "hooks"+ let replHook = mkName "replHook"+ app <- appE (varE (mkName "replHookBody")) (varE replHook)+ lamE [varP hooks] (recUpdE (varE hooks) [return (replHook, app)])+ else [| \hooks -> hooks |]+ )+{- End of Template Haskell hackery -}+ main :: IO ()-main = defaultMainWithHooks simpleUserHooks {+main = defaultMainWithHooks $ addReplHook $ simpleUserHooks { buildHook = \ pkg lbi hooks flags -> let verb = fromFlag $ buildVerbosity flags@@ -98,31 +113,18 @@ haddockHook = \ pkg lbi hooks flags -> let verb = fromFlag $ haddockVerbosity flags in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) ,-+{-+ -- this is the actual replHook code we want+ replHook = \pkg lbi hooks flags args ->+ let verb = fromFlag $ replVerbosity flags+ in commonBuildHook replHook pkg lbi hooks verb >>= (\f -> f flags args) ,+-} postBuild = \ _ _ _ lbi -> buildManpage lbi, postCopy = \ _ flags pkg lbi -> installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags), postInst = \ _ flags pkg lbi -> installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest, - runTests = \ args0 _ _ lbi -> do- cwd <- getCurrentDirectory- let isabs = isAbsolute $ buildDir lbi- builddir = (if isabs then id else (cwd </>)) $ buildDir lbi- darcs = builddir </> "darcs" </> "darcs" <.> exeExtension- darcstest = builddir </> "darcs-test" </> "darcs-test" <.> exeExtension- (flags, args1) = partition ('=' `elem`) args0- (what', args2) = partition (`elem` ["bugs", "network", "tests", "unit"]) args1- what = if null what' then ["tests"] else what'- opts = [ "--darcs", darcs ] ++ concat [ ["-t", x] | x <- args2 ] ++- [ "--no-unit" | "unit" `notElem` what] ++- [ "--network" | "network" <- what ] ++ [ "--failing" | "bugs" <- what ] ++- [ "--no-shell" | _ <- [()], "tests" `notElem` what ] ++- [ "--threads=" ++ drop 8 t | t <- flags, "threads" `isPrefixOf` t ] ++- [ "--plain" | "output=plain" <- flags ]- rawSystem darcstest opts >>= exitWith- ,- sDistHook = \ pkg lbi hooks flags -> do let pkgVer = packageVersion pkg verb = fromFlag $ sDistVerbosity flags@@ -173,19 +175,25 @@ -- invocations, doing a dance to make the base hook aware of them. littleEndian <- testEndianness let args = ("-DPACKAGE_VERSION=" ++ show' version) :- ("-DPACKAGE_VERSION_STATE=" ++ show' state) : [arg | (arg, True) <- -- include fst iff snd. [("-DHAVE_HTTP", "x-have-http" `elem` customFields),- ("-DUSE_COLOR", "x-use-color" `elem` customFields), -- We have MAPI iff building on/for Windows. ("-DHAVE_MAPI", buildOS == Windows),+ ("-DLITTLEENDIAN", littleEndian), ("-DBIGENDIAN", not littleEndian)]] bi = emptyBuildInfo { cppOptions = args, ccOptions = args } hbi = (Just bi, [(exeName exe, bi) | exe <- executables pkg]) pkg' = updatePackageDescription hbi pkg- lbi' = lbi { localPkgDescr = pkg' }- return $ runHook simpleUserHooks pkg' lbi' hooks + -- updatePackageDescription doesn't handle test suites so we+ -- need to do this manually+ updateTestSuiteBI bi testSuite+ = testSuite { testBuildInfo = bi `mappend` testBuildInfo testSuite }+ pkg'' = pkg' { testSuites = map (updateTestSuiteBI bi) (testSuites pkg') }++ lbi' = lbi { localPkgDescr = pkg'' }+ return $ runHook simpleUserHooks pkg'' lbi' hooks+ where customFields = map fst . customFieldsBI . buildInfo $ darcsExe darcsExe = head [e | e <- executables pkg, exeName e == "darcs"]@@ -195,6 +203,10 @@ testEndianness = with (1 :: Word32) $ \p -> do o <- peek $ castPtr p return $ o == (1 :: Word8) +-- ---------------------------------------------------------------------+-- man page+-- ---------------------------------------------------------------------+ buildManpage :: LocalBuildInfo -> IO () buildManpage lbi = do let darcs = buildDir lbi </> "darcs/darcs"@@ -211,6 +223,10 @@ (mandir (absoluteInstallDirs pkg lbi copy) </> "man1") [(buildDir lbi </> "darcs", "darcs.1")] +-- ---------------------------------------------------------------------+-- version module+-- ---------------------------------------------------------------------+ determineVersion :: Verbosity -> PackageDescription -> IO (String, String) determineVersion verbosity pkg = do let darcsVersion = packageVersion pkg@@ -261,7 +277,7 @@ ["module Version where" ,"builddeps, version, context :: String" ,"version = \"" ++ version ++ " (" ++ state ++ ")\""- ,"builddeps = " ++ (show $ formatdeps (externalPackageDeps lbi))+ ,"builddeps = " ++ show ( formatdeps (externalPackageDeps lbi)) ,"context = " ++ case ctx of Just x -> show x Nothing -> show "context not available"@@ -358,7 +374,7 @@ addIconv bi = bi {extraLibs = "iconv" : extraLibs bi} iconv_prog :: String-iconv_prog = unlines $+iconv_prog = unlines [ "#include <iconv.h>" , "int main(void) {" , " iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");"
+ containers-0.5.2.1/Darcs/Data/Map/Base.hs view
@@ -0,0 +1,2791 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}+#endif+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.Map.Base+-- Copyright : (c) Daan Leijen 2002+-- (c) Andriy Palamarchuk 2008+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- An efficient implementation of maps from keys to values (dictionaries).+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.Map (Map)+-- > import qualified Data.Map as Map+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+-- * Stephen Adams, \"/Efficient sets: a balancing act/\",+-- Journal of Functional Programming 3(4):553-562, October 1993,+-- <http://www.swiss.ai.mit.edu/~adams/BB/>.+--+-- * J. Nievergelt and E.M. Reingold,+-- \"/Binary search trees of bounded balance/\",+-- SIAM journal of computing 2(1), March 1973.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'.+--+-- Operation comments contain the operation time complexity in+-- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.+-----------------------------------------------------------------------------++-- [Note: Using INLINABLE]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- It is crucial to the performance that the functions specialize on the Ord+-- type when possible. GHC 7.0 and higher does this by itself when it sees th+-- unfolding of a function -- that is why all public functions are marked+-- INLINABLE (that exposes the unfolding).+++-- [Note: Using INLINE]+-- ~~~~~~~~~~~~~~~~~~~~+-- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.+-- We mark the functions that just navigate down the tree (lookup, insert,+-- delete and similar). That navigation code gets inlined and thus specialized+-- when possible. There is a price to pay -- code growth. The code INLINED is+-- therefore only the tree navigation, all the real work (rebalancing) is not+-- INLINED by using a NOINLINE.+--+-- All methods marked INLINE have to be nonrecursive -- a 'go' function doing+-- the real work is provided.+++-- [Note: Type of local 'go' function]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- If the local 'go' function uses an Ord class, it sometimes heap-allocates+-- the Ord dictionary when the 'go' function does not have explicit type.+-- In that case we give 'go' explicit type. But this slightly decrease+-- performance, as the resulting 'go' function can float out to top level.+++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- As opposed to IntMap, when 'go' function captures an argument, increased+-- heap-allocation can occur: sometimes in a polymorphic function, the 'go'+-- floats out of its enclosing function and then it heap-allocates the+-- dictionary and the argument. Maybe it floats out too late and strictness+-- analyzer cannot see that these could be passed on stack.+--+-- For example, change 'member' so that its local 'go' function is not passing+-- argument k and then look at the resulting code for hedgeInt.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of Map matters when considering performance.+-- Currently in GHC 7.0, when type has 2 constructors, a forward conditional+-- jump is made when successfully matching second constructor. Successful match+-- of first constructor results in the forward jump not taken.+-- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip+-- improves the benchmark by up to 10% on x86.++module Darcs.Data.Map.Base (+ -- * Map type+ Map(..) -- instance Eq,Show,Read++ -- * Operators+ , (!), (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookup+ , findWithDefault+ , lookupLT+ , lookupGT+ , lookupLE+ , lookupGE++ -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWithKey+ , insertLookupWithKey++ -- ** Delete\/Update+ , delete+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter++ -- * Combine++ -- ** Union+ , union+ , unionWith+ , unionWithKey+ , unions+ , unionsWith++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey++ -- ** Intersection+ , intersection+ , intersectionWith+ , intersectionWithKey++ -- ** Universal combining function+ , mergeWithKey++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , traverseWithKey+ , mapAccum+ , mapAccumWithKey+ , mapAccumRWithKey+ , mapKeys+ , mapKeysWith+ , mapKeysMonotonic++ -- * Folds+ , foldr+ , foldl+ , foldrWithKey+ , foldlWithKey+ -- ** Strict folds+ , foldr'+ , foldl'+ , foldrWithKey'+ , foldlWithKey'++ -- * Conversion+ , elems+ , keys+ , assocs+ , keysSet+ , fromSet++ -- ** Lists+ , toList+ , fromList+ , fromListWith+ , fromListWithKey++ -- ** Ordered lists+ , toAscList+ , toDescList+ , fromAscList+ , fromAscListWith+ , fromAscListWithKey+ , fromDistinctAscList++ -- * Filter+ , filter+ , filterWithKey+ , partition+ , partitionWithKey++ , mapMaybe+ , mapMaybeWithKey+ , mapEither+ , mapEitherWithKey++ , split+ , splitLookup++ -- * Submap+ , isSubmapOf, isSubmapOfBy+ , isProperSubmapOf, isProperSubmapOfBy++ -- * Indexed+ , lookupIndex+ , findIndex+ , elemAt+ , updateAt+ , deleteAt++ -- * Min\/Max+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , updateMin+ , updateMax+ , updateMinWithKey+ , updateMaxWithKey+ , minView+ , maxView+ , minViewWithKey+ , maxViewWithKey++ -- * Debugging+ , showTree+ , showTreeWith+ , valid++ -- Used by the strict version+ , bin+ , balance+ , balanced+ , balanceL+ , balanceR+ , delta+ , join+ , insertMax+ , merge+ , glue+ , trim+ , trimLookupLo+ , foldlStrict+ , MaybeS(..)+ , filterGt+ , filterLt+ ) where++import Control.Applicative (Applicative(..), (<$>))+import Control.DeepSeq (NFData(rnf))+import Data.Bits (shiftL, shiftR)+import qualified Data.Foldable as Foldable+import Data.Monoid (Monoid(..))+import Darcs.Data.StrictPair+import Data.Traversable (Traversable(traverse))+import Data.Typeable+import Prelude hiding (lookup, map, filter, foldr, foldl, null)++import qualified Darcs.Data.Set.Base as Set++#if __GLASGOW_HASKELL__+import GHC.Exts ( build )+import Text.Read+import Data.Data+#endif++-- Use macros to define strictness of functions.+-- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.+-- We do not use BangPatterns, because they are not in any standard and we+-- want the compilers to be compiled by as many compilers as possible.+#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined+#define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined+#define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined+#define STRICT_1_OF_4(fn) fn arg _ _ _ | arg `seq` False = undefined+#define STRICT_2_OF_4(fn) fn _ arg _ _ | arg `seq` False = undefined++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}+infixl 9 !,\\ --++-- | /O(log n)/. Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: Ord k => Map k a -> k -> a+(!) m k = find k m+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE (!) #-}+#endif++-- | Same as 'difference'.+(\\) :: Ord k => Map k a -> Map k b -> Map k a+m1 \\ m2 = difference m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE (\\) #-}+#endif++{--------------------------------------------------------------------+ Size balanced trees.+--------------------------------------------------------------------}+-- | A Map from keys @k@ to values @a@.++-- See Note: Order of constructors+data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)+ | Tip++type Size = Int++instance (Ord k) => Monoid (Map k v) where+ mempty = empty+ mappend = union+ mconcat = unions++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+ A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance (Data k, Data a, Ord k) => Data (Map k a) where+ gfoldl f z m = z fromList `f` toList m+ toConstr _ = fromListConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z fromList)+ _ -> error "gunfold"+ dataTypeOf _ = mapDataType+ dataCast2 f = gcast2 f++fromListConstr :: Constr+fromListConstr = mkConstr mapDataType "fromList" [] Prefix++mapDataType :: DataType+mapDataType = mkDataType "Data.Map.Base.Map" [fromListConstr]++#endif++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the map empty?+--+-- > Data.Map.null (empty) == True+-- > Data.Map.null (singleton 1 'a') == False++null :: Map k a -> Bool+null Tip = True+null (Bin {}) = False+{-# INLINE null #-}++-- | /O(1)/. The number of elements in the map.+--+-- > size empty == 0+-- > size (singleton 1 'a') == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3++size :: Map k a -> Int+size Tip = 0+size (Bin sz _ _ _ _) = sz+{-# INLINE size #-}+++-- | /O(log n)/. Lookup the value at a key in the map.+--+-- The function will return the corresponding value as @('Just' value)@,+-- or 'Nothing' if the key isn't in the map.+--+-- An example of using @lookup@:+--+-- > import Prelude hiding (lookup)+-- > import Data.Map+-- >+-- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])+-- > deptCountry = fromList([("IT","USA"), ("Sales","France")])+-- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])+-- >+-- > employeeCurrency :: String -> Maybe String+-- > employeeCurrency name = do+-- > dept <- lookup name employeeDept+-- > country <- lookup dept deptCountry+-- > lookup country countryCurrency+-- >+-- > main = do+-- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))+-- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))+--+-- The output of this program:+--+-- > John's currency: Just "Euro"+-- > Pete's currency: Nothing+lookup :: Ord k => k -> Map k a -> Maybe a+lookup = go+ where+ STRICT_1_OF_2(go)+ go _ Tip = Nothing+ go k (Bin _ kx x l r) = case compare k kx of+ LT -> go k l+ GT -> go k r+ EQ -> Just x+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookup #-}+#else+{-# INLINE lookup #-}+#endif++-- | /O(log n)/. Is the key a member of the map? See also 'notMember'.+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False+member :: Ord k => k -> Map k a -> Bool+member = go+ where+ STRICT_1_OF_2(go)+ go _ Tip = False+ go k (Bin _ kx _ l r) = case compare k kx of+ LT -> go k l+ GT -> go k r+ EQ -> True+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE member #-}+#else+{-# INLINE member #-}+#endif++-- | /O(log n)/. Is the key not a member of the map? See also 'member'.+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Ord k => k -> Map k a -> Bool+notMember k m = not $ member k m+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE notMember #-}+#else+{-# INLINE notMember #-}+#endif++-- | /O(log n)/. Find the value at a key.+-- Calls 'error' when the element can not be found.+find :: Ord k => k -> Map k a -> a+find = go+ where+ STRICT_1_OF_2(go)+ go _ Tip = error "Map.!: given key is not an element in the map"+ go k (Bin _ kx x l r) = case compare k kx of+ LT -> go k l+ GT -> go k r+ EQ -> x+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE find #-}+#else+{-# INLINE find #-}+#endif++-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'+findWithDefault :: Ord k => a -> k -> Map k a -> a+findWithDefault = go+ where+ STRICT_2_OF_3(go)+ go def _ Tip = def+ go def k (Bin _ kx x l r) = case compare k kx of+ LT -> go def k l+ GT -> go def k r+ EQ -> x+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE findWithDefault #-}+#else+{-# INLINE findWithDefault #-}+#endif++-- | /O(log n)/. Find largest key smaller than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+lookupLT :: Ord k => k -> Map k v -> Maybe (k, v)+lookupLT = goNothing+ where+ STRICT_1_OF_2(goNothing)+ goNothing _ Tip = Nothing+ goNothing k (Bin _ kx x l r) | k <= kx = goNothing k l+ | otherwise = goJust k kx x r++ STRICT_1_OF_4(goJust)+ goJust _ kx' x' Tip = Just (kx', x')+ goJust k kx' x' (Bin _ kx x l r) | k <= kx = goJust k kx' x' l+ | otherwise = goJust k kx x r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupLT #-}+#else+{-# INLINE lookupLT #-}+#endif++-- | /O(log n)/. Find smallest key greater than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing+lookupGT :: Ord k => k -> Map k v -> Maybe (k, v)+lookupGT = goNothing+ where+ STRICT_1_OF_2(goNothing)+ goNothing _ Tip = Nothing+ goNothing k (Bin _ kx x l r) | k < kx = goJust k kx x l+ | otherwise = goNothing k r++ STRICT_1_OF_4(goJust)+ goJust _ kx' x' Tip = Just (kx', x')+ goJust k kx' x' (Bin _ kx x l r) | k < kx = goJust k kx x l+ | otherwise = goJust k kx' x' r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupGT #-}+#else+{-# INLINE lookupGT #-}+#endif++-- | /O(log n)/. Find largest key smaller or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+lookupLE :: Ord k => k -> Map k v -> Maybe (k, v)+lookupLE = goNothing+ where+ STRICT_1_OF_2(goNothing)+ goNothing _ Tip = Nothing+ goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goNothing k l+ EQ -> Just (kx, x)+ GT -> goJust k kx x r++ STRICT_1_OF_4(goJust)+ goJust _ kx' x' Tip = Just (kx', x')+ goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx' x' l+ EQ -> Just (kx, x)+ GT -> goJust k kx x r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupLE #-}+#else+{-# INLINE lookupLE #-}+#endif++-- | /O(log n)/. Find smallest key greater or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing+lookupGE :: Ord k => k -> Map k v -> Maybe (k, v)+lookupGE = goNothing+ where+ STRICT_1_OF_2(goNothing)+ goNothing _ Tip = Nothing+ goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l+ EQ -> Just (kx, x)+ GT -> goNothing k r++ STRICT_1_OF_4(goJust)+ goJust _ kx' x' Tip = Just (kx', x')+ goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l+ EQ -> Just (kx, x)+ GT -> goJust k kx' x' r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupGE #-}+#else+{-# INLINE lookupGE #-}+#endif++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty map.+--+-- > empty == fromList []+-- > size empty == 0++empty :: Map k a+empty = Tip+{-# INLINE empty #-}++-- | /O(1)/. A map with a single element.+--+-- > singleton 1 'a' == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: k -> a -> Map k a+singleton k x = Bin 1 k x Tip Tip+{-# INLINE singleton #-}++{--------------------------------------------------------------------+ Insertion+--------------------------------------------------------------------}+-- | /O(log n)/. Insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty == singleton 5 'x'++-- See Note: Type of local 'go' function+insert :: Ord k => k -> a -> Map k a -> Map k a+insert = go+ where+ go :: Ord k => k -> a -> Map k a -> Map k a+ STRICT_1_OF_3(go)+ go kx x Tip = singleton kx x+ go kx x (Bin sz ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go kx x l) r+ GT -> balanceR ky y l (go kx x r)+ EQ -> Bin sz kx x l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insert #-}+#else+{-# INLINE insert #-}+#endif++-- Insert a new key and value in the map if it is not already present.+-- Used by `union`.++-- See Note: Type of local 'go' function+insertR :: Ord k => k -> a -> Map k a -> Map k a+insertR = go+ where+ go :: Ord k => k -> a -> Map k a -> Map k a+ STRICT_1_OF_3(go)+ go kx x Tip = singleton kx x+ go kx x t@(Bin _ ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go kx x l) r+ GT -> balanceR ky y l (go kx x r)+ EQ -> t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertR #-}+#else+{-# INLINE insertR #-}+#endif++-- | /O(log n)/. Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"++insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWith f = insertWithKey (\_ x' y' -> f x' y')+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertWith #-}+#else+{-# INLINE insertWith #-}+#endif++-- | /O(log n)/. Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key,f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"++-- See Note: Type of local 'go' function+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey = go+ where+ go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+ STRICT_2_OF_4(go)+ go _ kx x Tip = singleton kx x+ go f kx x (Bin sy ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go f kx x l) r+ GT -> balanceR ky y l (go f kx x r)+ EQ -> Bin sy kx (f kx x y) l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertWithKey #-}+#else+{-# INLINE insertWithKey #-}+#endif++-- | /O(log n)/. Combines insert operation with old value retrieval.+-- The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])++-- See Note: Type of local 'go' function+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a+ -> (Maybe a, Map k a)+insertLookupWithKey = go+ where+ go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)+ STRICT_2_OF_4(go)+ go _ kx x Tip = (Nothing, singleton kx x)+ go f kx x (Bin sy ky y l r) =+ case compare kx ky of+ LT -> let (found, l') = go f kx x l+ in (found, balanceL ky y l' r)+ GT -> let (found, r') = go f kx x r+ in (found, balanceR ky y l r')+ EQ -> (Just y, Bin sy kx (f kx x y) l r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertLookupWithKey #-}+#else+{-# INLINE insertLookupWithKey #-}+#endif++{--------------------------------------------------------------------+ Deletion+--------------------------------------------------------------------}+-- | /O(log n)/. Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > delete 5 empty == empty++-- See Note: Type of local 'go' function+delete :: Ord k => k -> Map k a -> Map k a+delete = go+ where+ go :: Ord k => k -> Map k a -> Map k a+ STRICT_1_OF_2(go)+ go _ Tip = Tip+ go k (Bin _ kx x l r) =+ case compare k kx of+ LT -> balanceR kx x (go k l) r+ GT -> balanceL kx x l (go k r)+ EQ -> glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE delete #-}+#else+{-# INLINE delete #-}+#endif++-- | /O(log n)/. Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty == empty++adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a+adjust f = adjustWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE adjust #-}+#else+{-# INLINE adjust #-}+#endif++-- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty == empty++adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x'))+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE adjustWithKey #-}+#else+{-# INLINE adjustWithKey #-}+#endif++-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a+update f = updateWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE update #-}+#else+{-# INLINE update #-}+#endif++-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++-- See Note: Type of local 'go' function+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+updateWithKey = go+ where+ go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+ STRICT_2_OF_3(go)+ go _ _ Tip = Tip+ go f k(Bin sx kx x l r) =+ case compare k kx of+ LT -> balanceR kx x (go f k l) r+ GT -> balanceL kx x l (go f k r)+ EQ -> case f kx x of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateWithKey #-}+#else+{-# INLINE updateWithKey #-}+#endif++-- | /O(log n)/. Lookup and update. See also 'updateWithKey'.+-- The function returns changed value, if it is updated.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++-- See Note: Type of local 'go' function+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)+updateLookupWithKey = go+ where+ go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)+ STRICT_2_OF_3(go)+ go _ _ Tip = (Nothing,Tip)+ go f k (Bin sx kx x l r) =+ case compare k kx of+ LT -> let (found,l') = go f k l in (found,balanceR kx x l' r)+ GT -> let (found,r') = go f k r in (found,balanceL kx x l r')+ EQ -> case f kx x of+ Just x' -> (Just x',Bin sx kx x' l r)+ Nothing -> (Just x,glue l r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateLookupWithKey #-}+#else+{-# INLINE updateLookupWithKey #-}+#endif++-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+--+-- > let f _ = Nothing+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- >+-- > let f _ = Just "c"+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]++-- See Note: Type of local 'go' function+alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+alter = go+ where+ go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+ STRICT_2_OF_3(go)+ go f k Tip = case f Nothing of+ Nothing -> Tip+ Just x -> singleton k x++ go f k (Bin sx kx x l r) = case compare k kx of+ LT -> balance kx x (go f k l) r+ GT -> balance kx x l (go f k r)+ EQ -> case f (Just x) of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE alter #-}+#else+{-# INLINE alter #-}+#endif++{--------------------------------------------------------------------+ Indexing+--------------------------------------------------------------------}+-- | /O(log n)/. Return the /index/ of a key, which is its zero-based index in+-- the sequence sorted by keys. The index is a number from /0/ up to, but not+-- including, the 'size' of the map. Calls 'error' when the key is not+-- a 'member' of the map.+--+-- > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map+-- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0+-- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1+-- > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map++-- See Note: Type of local 'go' function+findIndex :: Ord k => k -> Map k a -> Int+findIndex = go 0+ where+ go :: Ord k => Int -> k -> Map k a -> Int+ STRICT_1_OF_3(go)+ STRICT_2_OF_3(go)+ go _ _ Tip = error "Map.findIndex: element is not in the map"+ go idx k (Bin _ kx _ l r) = case compare k kx of+ LT -> go idx k l+ GT -> go (idx + size l + 1) k r+ EQ -> idx + size l+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE findIndex #-}+#endif++-- | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index in+-- the sequence sorted by keys. The index is a number from /0/ up to, but not+-- including, the 'size' of the map.+--+-- > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) == False+-- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0+-- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1+-- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False++-- See Note: Type of local 'go' function+lookupIndex :: Ord k => k -> Map k a -> Maybe Int+lookupIndex = go 0+ where+ go :: Ord k => Int -> k -> Map k a -> Maybe Int+ STRICT_1_OF_3(go)+ STRICT_2_OF_3(go)+ go _ _ Tip = Nothing+ go idx k (Bin _ kx _ l r) = case compare k kx of+ LT -> go idx k l+ GT -> go (idx + size l + 1) k r+ EQ -> Just $! idx + size l+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupIndex #-}+#endif++-- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based+-- index in the sequence sorted by keys. If the /index/ is out of range (less+-- than zero, greater or equal to 'size' of the map), 'error' is called.+--+-- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")+-- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")+-- > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range++elemAt :: Int -> Map k a -> (k,a)+STRICT_1_OF_2(elemAt)+elemAt _ Tip = error "Map.elemAt: index out of range"+elemAt i (Bin _ kx x l r)+ = case compare i sizeL of+ LT -> elemAt i l+ GT -> elemAt (i-sizeL-1) r+ EQ -> (kx,x)+ where+ sizeL = size l++-- | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in+-- the sequence sorted by keys. If the /index/ is out of range (less than zero,+-- greater or equal to 'size' of the map), 'error' is called.+--+-- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]+-- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]+-- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range++updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a+updateAt f i t = i `seq`+ case t of+ Tip -> error "Map.updateAt: index out of range"+ Bin sx kx x l r -> case compare i sizeL of+ LT -> balanceR kx x (updateAt f i l) r+ GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)+ EQ -> case f kx x of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r+ where+ sizeL = size l++-- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in+-- the sequence sorted by keys. If the /index/ is out of range (less than zero,+-- greater or equal to 'size' of the map), 'error' is called.+--+-- > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range++deleteAt :: Int -> Map k a -> Map k a+deleteAt i t = i `seq`+ case t of+ Tip -> error "Map.deleteAt: index out of range"+ Bin _ kx x l r -> case compare i sizeL of+ LT -> balanceR kx x (deleteAt i l) r+ GT -> balanceL kx x l (deleteAt (i-sizeL-1) r)+ EQ -> glue l r+ where+ sizeL = size l+++{--------------------------------------------------------------------+ Minimal, Maximal+--------------------------------------------------------------------}+-- | /O(log n)/. The minimal key of the map. Calls 'error' if the map is empty.+--+-- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")+-- > findMin empty Error: empty map has no minimal element++findMin :: Map k a -> (k,a)+findMin (Bin _ kx x Tip _) = (kx,x)+findMin (Bin _ _ _ l _) = findMin l+findMin Tip = error "Map.findMin: empty map has no minimal element"++-- | /O(log n)/. The maximal key of the map. Calls 'error' if the map is empty.+--+-- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")+-- > findMax empty Error: empty map has no maximal element++findMax :: Map k a -> (k,a)+findMax (Bin _ kx x _ Tip) = (kx,x)+findMax (Bin _ _ _ _ r) = findMax r+findMax Tip = error "Map.findMax: empty map has no maximal element"++-- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.+--+-- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]+-- > deleteMin empty == empty++deleteMin :: Map k a -> Map k a+deleteMin (Bin _ _ _ Tip r) = r+deleteMin (Bin _ kx x l r) = balanceR kx x (deleteMin l) r+deleteMin Tip = Tip++-- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.+--+-- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]+-- > deleteMax empty == empty++deleteMax :: Map k a -> Map k a+deleteMax (Bin _ _ _ l Tip) = l+deleteMax (Bin _ kx x l r) = balanceL kx x l (deleteMax r)+deleteMax Tip = Tip++-- | /O(log n)/. Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> Map k a -> Map k a+updateMin f m+ = updateMinWithKey (\_ x -> f x) m++-- | /O(log n)/. Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> Map k a -> Map k a+updateMax f m+ = updateMaxWithKey (\_ x -> f x) m+++-- | /O(log n)/. Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMinWithKey _ Tip = Tip+updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of+ Nothing -> r+ Just x' -> Bin sx kx x' Tip r+updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r++-- | /O(log n)/. Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMaxWithKey _ Tip = Tip+updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of+ Nothing -> l+ Just x' -> Bin sx kx x' l Tip+updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r)++-- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)+minViewWithKey Tip = Nothing+minViewWithKey x = Just (deleteFindMin x)++-- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)+maxViewWithKey Tip = Nothing+maxViewWithKey x = Just (deleteFindMax x)++-- | /O(log n)/. Retrieves the value associated with minimal key of the+-- map, and the map stripped of that element, or 'Nothing' if passed an+-- empty map.+--+-- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")+-- > minView empty == Nothing++minView :: Map k a -> Maybe (a, Map k a)+minView Tip = Nothing+minView x = Just (first snd $ deleteFindMin x)++-- | /O(log n)/. Retrieves the value associated with maximal key of the+-- map, and the map stripped of that element, or 'Nothing' if passed an+--+-- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")+-- > maxView empty == Nothing++maxView :: Map k a -> Maybe (a, Map k a)+maxView Tip = Nothing+maxView x = Just (first snd $ deleteFindMax x)++-- Update the 1st component of a tuple (special case of Control.Arrow.first)+first :: (a -> b) -> (a,c) -> (b,c)+first f (x,y) = (f x, y)++{--------------------------------------------------------------------+ Union.+--------------------------------------------------------------------}+-- | The union of a list of maps:+-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+--+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- > == fromList [(3, "b"), (5, "a"), (7, "C")]+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]+-- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]++unions :: Ord k => [Map k a] -> Map k a+unions ts+ = foldlStrict union empty ts+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unions #-}+#endif++-- | The union of a list of maps, with a combining operation:+-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a+unionsWith f ts+ = foldlStrict (unionWith f) empty ts+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unionsWith #-}+#endif++-- | /O(n+m)/.+-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.+-- It prefers @t1@ when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+-- The implementation uses the efficient /hedge-union/ algorithm.+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: Ord k => Map k a -> Map k a -> Map k a+union Tip t2 = t2+union t1 Tip = t1+union t1 t2 = hedgeUnion NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE union #-}+#endif++-- left-biased hedge union+hedgeUnion :: Ord a => MaybeS a -> MaybeS a -> Map a b -> Map a b -> Map a b+hedgeUnion _ _ t1 Tip = t1+hedgeUnion blo bhi Tip (Bin _ kx x l r) = join kx x (filterGt blo l) (filterLt bhi r)+hedgeUnion _ _ t1 (Bin _ kx x Tip Tip) = insertR kx x t1 -- According to benchmarks, this special case increases+ -- performance up to 30%. It does not help in difference or intersection.+hedgeUnion blo bhi (Bin _ kx x l r) t2 = join kx x (hedgeUnion blo bmi l (trim blo bmi t2))+ (hedgeUnion bmi bhi r (trim bmi bhi t2))+ where bmi = JustS kx+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeUnion #-}+#endif++{--------------------------------------------------------------------+ Union with a combining function+--------------------------------------------------------------------}+-- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWith f m1 m2+ = unionWithKey (\_ x y -> f x y) m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unionWith #-}+#endif++-- | /O(n+m)/.+-- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) id id t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unionWithKey #-}+#endif++{--------------------------------------------------------------------+ Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference of two maps.+-- Return elements of the first map not existing in the second map.+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: Ord k => Map k a -> Map k b -> Map k a+difference Tip _ = Tip+difference t1 Tip = t1+difference t1 t2 = hedgeDiff NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE difference #-}+#endif++hedgeDiff :: Ord a => MaybeS a -> MaybeS a -> Map a b -> Map a c -> Map a b+hedgeDiff _ _ Tip _ = Tip+hedgeDiff blo bhi (Bin _ kx x l r) Tip = join kx x (filterGt blo l) (filterLt bhi r)+hedgeDiff blo bhi t (Bin _ kx _ l r) = merge (hedgeDiff blo bmi (trim blo bmi t) l)+ (hedgeDiff bmi bhi (trim bmi bhi t) r)+ where bmi = JustS kx+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeDiff #-}+#endif++-- | /O(n+m)/. Difference with a combining function.+-- When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- > == singleton 3 "b:B"++differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWith f m1 m2+ = differenceWithKey (\_ x y -> f x y) m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE differenceWith #-}+#endif++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- > == singleton 3 "3:b|B"++differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWithKey f t1 t2 = mergeWithKey f id (const Tip) t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE differenceWithKey #-}+#endif+++{--------------------------------------------------------------------+ Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. Intersection of two maps.+-- Return data in the first map for the keys existing in both maps.+-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).+-- The implementation uses an efficient /hedge/ algorithm comparable with+-- /hedge-union/.+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: Ord k => Map k a -> Map k b -> Map k a+intersection Tip _ = Tip+intersection _ Tip = Tip+intersection t1 t2 = hedgeInt NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE intersection #-}+#endif++hedgeInt :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k b -> Map k a+hedgeInt _ _ _ Tip = Tip+hedgeInt _ _ Tip _ = Tip+hedgeInt blo bhi (Bin _ kx x l r) t2 = let l' = hedgeInt blo bmi l (trim blo bmi t2)+ r' = hedgeInt bmi bhi r (trim bmi bhi t2)+ in if kx `member` t2 then join kx x l' r' else merge l' r'+ where bmi = JustS kx+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeInt #-}+#endif++-- | /O(n+m)/. Intersection with a combining function. The implementation uses+-- an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWith f m1 m2+ = intersectionWithKey (\_ x y -> f x y) m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE intersectionWith #-}+#endif++-- | /O(n+m)/. Intersection with a combining function. The implementation uses+-- an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"+++intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) (const Tip) (const Tip) t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE intersectionWithKey #-}+#endif+++{--------------------------------------------------------------------+ MergeWithKey+--------------------------------------------------------------------}++-- | /O(n+m)/. A high-performance universal combining function. This function+-- is used to define 'unionWith', 'unionWithKey', 'differenceWith',+-- 'differenceWithKey', 'intersectionWith', 'intersectionWithKey' and can be+-- used to define other custom combine functions.+--+-- Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'IntMap's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+-- values to the @combine@ function. Depending on the result, the key is either+-- present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+-- the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+-- the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c)+ -> Map k a -> Map k b -> Map k c+mergeWithKey f g1 g2 = go+ where+ go Tip t2 = g2 t2+ go t1 Tip = g1 t1+ go t1 t2 = hedgeMerge NothingS NothingS t1 t2++ hedgeMerge _ _ t1 Tip = g1 t1+ hedgeMerge blo bhi Tip (Bin _ kx x l r) = g2 $ join kx x (filterGt blo l) (filterLt bhi r)+ hedgeMerge blo bhi (Bin _ kx x l r) t2 = let l' = hedgeMerge blo bmi l (trim blo bmi t2)+ (found, trim_t2) = trimLookupLo kx bhi t2+ r' = hedgeMerge bmi bhi r trim_t2+ in case found of+ Nothing -> case g1 (singleton kx x) of+ Tip -> merge l' r'+ (Bin _ _ x' Tip Tip) -> join kx x' l' r'+ _ -> error "mergeWithKey: Given function only1 does not fulfil required conditions (see documentation)"+ Just x2 -> case f kx x x2 of+ Nothing -> merge l' r'+ Just x' -> join kx x' l' r'+ where bmi = JustS kx+{-# INLINE mergeWithKey #-}++{--------------------------------------------------------------------+ Submap+--------------------------------------------------------------------}+-- | /O(n+m)/.+-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+--+isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isSubmapOf #-}+#endif++{- | /O(n+m)/.+ The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if+ all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++ > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])++ But the following are all 'False':++ > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])+++-}+isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool+isSubmapOfBy f t1 t2+ = (size t1 <= size t2) && (submap' f t1 t2)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isSubmapOfBy #-}+#endif++submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool+submap' _ Tip _ = True+submap' _ _ Tip = False+submap' f (Bin _ kx x l r) t+ = case found of+ Nothing -> False+ Just y -> f x y && submap' f l lt && submap' f r gt+ where+ (lt,found,gt) = splitLookup kx t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE submap' #-}+#endif++-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+isProperSubmapOf m1 m2+ = isProperSubmapOfBy (==) m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isProperSubmapOf #-}+#endif++{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @m1@ and @m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++ > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+ > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+++-}+isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool+isProperSubmapOfBy f t1 t2+ = (size t1 < size t2) && (submap' f t1 t2)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isProperSubmapOfBy #-}+#endif++{--------------------------------------------------------------------+ Filter and partition+--------------------------------------------------------------------}+-- | /O(n)/. Filter all values that satisfy the predicate.+--+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty++filter :: (a -> Bool) -> Map k a -> Map k a+filter p m+ = filterWithKey (\_ x -> p x) m++-- | /O(n)/. Filter all keys\/values that satisfy the predicate.+--+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a+filterWithKey _ Tip = Tip+filterWithKey p (Bin _ kx x l r)+ | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)+ | otherwise = merge (filterWithKey p l) (filterWithKey p r)++-- | /O(n)/. Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partition :: (a -> Bool) -> Map k a -> (Map k a,Map k a)+partition p m+ = partitionWithKey (\_ x -> p x) m++-- | /O(n)/. Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)+partitionWithKey p0 t0 = toPair $ go p0 t0+ where+ go _ Tip = (Tip :*: Tip)+ go p (Bin _ kx x l r)+ | p kx x = join kx x l1 r1 :*: merge l2 r2+ | otherwise = merge l1 r1 :*: join kx x l2 r2+ where+ (l1 :*: l2) = go p l+ (r1 :*: r2) = go p r++-- | /O(n)/. Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b+mapMaybeWithKey _ Tip = Tip+mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of+ Just y -> join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)+ Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r)++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEither f m+ = mapEitherWithKey (\_ x -> f x) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+ where+ go _ Tip = (Tip :*: Tip)+ go f (Bin _ kx x l r) = case f kx x of+ Left y -> join kx y l1 r1 :*: merge l2 r2+ Right z -> merge l1 r1 :*: join kx z l2 r2+ where+ (l1 :*: l2) = go f l+ (r1 :*: r2) = go f r++{--------------------------------------------------------------------+ Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Map k a -> Map k b+map _ Tip = Tip+map f (Bin sx kx x l r) = Bin sx kx (f x) (map f l) (map f r)++-- | /O(n)/. Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (k -> a -> b) -> Map k a -> Map k b+mapWithKey _ Tip = Tip+mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)++-- | /O(n)/.+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing+{-# INLINE traverseWithKey #-}+traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)+traverseWithKey f = go+ where+ go Tip = pure Tip+ go (Bin s k v l r)+ = flip (Bin s k) <$> go l <*> f k v <*> go r++-- | /O(n)/. The function 'mapAccum' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccum f a m+ = mapAccumWithKey (\a' _ x' -> f a' x') a m++-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumWithKey f a t+ = mapAccumL f a t++-- | /O(n)/. The function 'mapAccumL' threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumL _ a Tip = (a,Tip)+mapAccumL f a (Bin sx kx x l r) =+ let (a1,l') = mapAccumL f a l+ (a2,x') = f a1 kx x+ (a3,r') = mapAccumL f a2 r+ in (a3,Bin sx kx x' l' r')++-- | /O(n)/. The function 'mapAccumR' threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumRWithKey _ a Tip = (a,Tip)+mapAccumRWithKey f a (Bin sx kx x l r) =+ let (a1,r') = mapAccumRWithKey f a r+ (a2,x') = f a1 kx x+ (a3,l') = mapAccumRWithKey f a2 l+ in (a3,Bin sx kx x' l' r')++-- | /O(n*log n)/.+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the value at the greatest of the+-- original keys is retained.+--+-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]+-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"+-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"++mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a+mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapKeys #-}+#endif++-- | /O(n*log n)/.+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the associated values will be+-- combined using @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"++mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a+mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapKeysWith #-}+#endif+++-- | /O(n)/.+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- /The precondition is not checked./+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- > ==> mapKeysMonotonic f s == mapKeys f s+-- > where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has better performance than 'mapKeys'.+--+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]+-- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True+-- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False++mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a+mapKeysMonotonic _ Tip = Tip+mapKeysMonotonic f (Bin sz k x l r) =+ Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)++{--------------------------------------------------------------------+ Folds+--------------------------------------------------------------------}++-- | /O(n)/. Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+--+-- For example,+--+-- > elems map = foldr (:) [] map+--+-- > let f a len = len + (length a)+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldr :: (a -> b -> b) -> b -> Map k a -> b+foldr f z = go z+ where+ go z' Tip = z'+ go z' (Bin _ _ x l r) = go (f x (go z' r)) l+{-# INLINE foldr #-}++-- | /O(n)/. A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> Map k a -> b+foldr' f z = go z+ where+ STRICT_1_OF_2(go)+ go z' Tip = z'+ go z' (Bin _ _ x l r) = go (f x (go z' r)) l+{-# INLINE foldr' #-}++-- | /O(n)/. Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+--+-- For example,+--+-- > elems = reverse . foldl (flip (:)) []+--+-- > let f len a = len + (length a)+-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldl :: (a -> b -> a) -> a -> Map k b -> a+foldl f z = go z+ where+ go z' Tip = z'+ go z' (Bin _ _ x l r) = go (f (go z' l) x) r+{-# INLINE foldl #-}++-- | /O(n)/. A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> Map k b -> a+foldl' f z = go z+ where+ STRICT_1_OF_2(go)+ go z' Tip = z'+ go z' (Bin _ _ x l r) = go (f (go z' l) x) r+{-# INLINE foldl' #-}++-- | /O(n)/. Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- For example,+--+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrWithKey f z = go z+ where+ go z' Tip = z'+ go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l+{-# INLINE foldrWithKey #-}++-- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrWithKey' f z = go z+ where+ STRICT_1_OF_2(go)+ go z' Tip = z'+ go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l+{-# INLINE foldrWithKey' #-}++-- | /O(n)/. Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+--+-- For example,+--+-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []+--+-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"+foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlWithKey f z = go z+ where+ go z' Tip = z'+ go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r+{-# INLINE foldlWithKey #-}++-- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlWithKey' f z = go z+ where+ STRICT_1_OF_2(go)+ go z' Tip = z'+ go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r+{-# INLINE foldlWithKey' #-}++{--------------------------------------------------------------------+ List variations+--------------------------------------------------------------------}+-- | /O(n)/.+-- Return all elements of the map in the ascending order of their keys.+-- Subject to list fusion.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: Map k a -> [a]+elems = foldr (:) []++-- | /O(n)/. Return all keys of the map in ascending order. Subject to list+-- fusion.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys :: Map k a -> [k]+keys = foldrWithKey (\k _ ks -> k : ks) []++-- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map+-- in ascending key order. Subject to list fusion.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: Map k a -> [(k,a)]+assocs m+ = toAscList m++-- | /O(n)/. The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]+-- > keysSet empty == Data.Set.empty++keysSet :: Map k a -> Set.Set k+keysSet Tip = Set.Tip+keysSet (Bin sz kx _ l r) = Set.Bin sz kx (keysSet l) (keysSet r)++-- | /O(n)/. Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.Set.empty == empty++fromSet :: (k -> a) -> Set.Set k -> Map k a+fromSet _ Set.Tip = Tip+fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r)++{--------------------------------------------------------------------+ Lists+ use [foldlStrict] to reduce demand on the control-stack+--------------------------------------------------------------------}+-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+--+-- If the keys of the list are ordered, linear-time implementation is used,+-- with the performance equal to 'fromDistinctAscList'.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++-- For some reason, when 'singleton' is used in fromList or in+-- create, it is not inlined, so we inline it manually.+fromList :: Ord k => [(k,a)] -> Map k a+fromList [] = Tip+fromList [(kx, x)] = Bin 1 kx x Tip Tip+fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = fromList' (Bin 1 kx0 x0 Tip Tip) xs0+ | otherwise = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0+ where+ not_ordered _ [] = False+ not_ordered kx ((ky,_) : _) = kx >= ky+ {-# INLINE not_ordered #-}++ fromList' t0 xs = foldlStrict ins t0 xs+ where ins t (k,x) = insert k x t++ STRICT_1_OF_3(go)+ go _ t [] = t+ go _ t [(kx, x)] = insertMax kx x t+ go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs+ | otherwise = case create s xss of+ (r, ys, []) -> go (s `shiftL` 1) (join kx x l r) ys+ (r, _, ys) -> fromList' (join kx x l r) ys++ -- The create is returning a triple (tree, xs, ys). Both xs and ys+ -- represent not yet processed elements and only one of them can be nonempty.+ -- If ys is nonempty, the keys in ys are not ordered with respect to tree+ -- and must be inserted using fromList'. Otherwise the keys have been+ -- ordered so far.+ STRICT_1_OF_2(create)+ create _ [] = (Tip, [], [])+ create s xs@(xp : xss)+ | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss)+ | otherwise -> (Bin 1 kx x Tip Tip, xss, [])+ | otherwise = case create (s `shiftR` 1) xs of+ res@(_, [], _) -> res+ (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs)+ (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)+ | otherwise -> case create (s `shiftR` 1) yss of+ (r, zs, ws) -> (join ky y l r, zs, ws)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromList #-}+#endif++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [] == empty++fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a+fromListWith f xs+ = fromListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromListWith #-}+#endif++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.+--+-- > let f k a1 a2 = (show k) ++ a1 ++ a2+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]+-- > fromListWithKey f [] == empty++fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromListWithKey f xs+ = foldlStrict ins empty xs+ where+ ins t (k,x) = insertWithKey f k x t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromListWithKey #-}+#endif++-- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list fusion.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: Map k a -> [(k,a)]+toList = toAscList++-- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are+-- in ascending order. Subject to list fusion.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: Map k a -> [(k,a)]+toAscList = foldrWithKey (\k x xs -> (k,x):xs) []++-- | /O(n)/. Convert the map to a list of key\/value pairs where the keys+-- are in descending order. Subject to list fusion.+--+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]++toDescList :: Map k a -> [(k,a)]+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.+-- They are important to convert unfused methods back, see mapFB in prelude.+foldrFB :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrFB = foldrWithKey+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlFB = foldlWithKey+{-# INLINE[0] foldlFB #-}++-- Inline assocs and toList, so that we need to fuse only toAscList.+{-# INLINE assocs #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to+-- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to+-- inline it before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] elems #-}+{-# NOINLINE[0] keys #-}+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}+{-# RULES "Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}+{-# RULES "Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}+{-# RULES "Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}+{-# RULES "Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}+{-# RULES "Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}+{-# RULES "Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}+{-# RULES "Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}+#endif++{--------------------------------------------------------------------+ Building trees from ascending/descending lists can be done in linear time.++ Note that if [xs] is ascending that:+ fromAscList xs == fromList xs+ fromAscListWith f xs == fromListWith f xs+--------------------------------------------------------------------}+-- | /O(n)/. Build a map from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]+-- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False++fromAscList :: Eq k => [(k,a)] -> Map k a+fromAscList xs+ = fromAscListWithKey (\_ x _ -> x) xs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromAscList #-}+#endif++-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+-- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False++fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWith f xs+ = fromAscListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromAscListWith #-}+#endif++-- | /O(n)/. Build a map from an ascending list in linear time with a+-- combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]+-- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True+-- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False++fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWithKey f xs+ = fromDistinctAscList (combineEq f xs)+ where+ -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+ combineEq _ xs'+ = case xs' of+ [] -> []+ [x] -> [x]+ (x:xx) -> combineEq' x xx++ combineEq' z [] = [z]+ combineEq' z@(kz,zz) (x@(kx,xx):xs')+ | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs'+ | otherwise = z:combineEq' x xs'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromAscListWithKey #-}+#endif+++-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.+-- /The precondition is not checked./+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True+-- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False++-- For some reason, when 'singleton' is used in fromDistinctAscList or in+-- create, it is not inlined, so we inline it manually.+fromDistinctAscList :: [(k,a)] -> Map k a+fromDistinctAscList [] = Tip+fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0+ where+ STRICT_1_OF_3(go)+ go _ t [] = t+ go s l ((kx, x) : xs) = case create s xs of+ (r, ys) -> go (s `shiftL` 1) (join kx x l r) ys++ STRICT_1_OF_2(create)+ create _ [] = (Tip, [])+ create s xs@(x' : xs')+ | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip, xs')+ | otherwise = case create (s `shiftR` 1) xs of+ res@(_, []) -> res+ (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of+ (r, zs) -> (join ky y l r, zs)+++{--------------------------------------------------------------------+ Utility functions that return sub-ranges of the original+ tree. Some functions take a `Maybe value` as an argument to+ allow comparisons against infinite values. These are called `blow`+ (Nothing is -\infty) and `bhigh` (here Nothing is +\infty).+ We use MaybeS value, which is a Maybe strict in the Just case.++ [trim blow bhigh t] A tree that is either empty or where [x > blow]+ and [x < bhigh] for the value [x] of the root.+ [filterGt blow t] A tree where for all values [k]. [k > blow]+ [filterLt bhigh t] A tree where for all values [k]. [k < bhigh]++ [split k t] Returns two trees [l] and [r] where all keys+ in [l] are <[k] and all keys in [r] are >[k].+ [splitLookup k t] Just like [split] but also returns whether [k]+ was found in the tree.+--------------------------------------------------------------------}++data MaybeS a = NothingS | JustS !a++{--------------------------------------------------------------------+ [trim blo bhi t] trims away all subtrees that surely contain no+ values between the range [blo] to [bhi]. The returned tree is either+ empty or the key of the root is between @blo@ and @bhi@.+--------------------------------------------------------------------}+trim :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k a+trim NothingS NothingS t = t+trim (JustS lk) NothingS t = greater lk t where greater lo (Bin _ k _ _ r) | k <= lo = greater lo r+ greater _ t' = t'+trim NothingS (JustS hk) t = lesser hk t where lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l+ lesser _ t' = t'+trim (JustS lk) (JustS hk) t = middle lk hk t where middle lo hi (Bin _ k _ _ r) | k <= lo = middle lo hi r+ middle lo hi (Bin _ k _ l _) | k >= hi = middle lo hi l+ middle _ _ t' = t'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE trim #-}+#endif++-- Helper function for 'mergeWithKey'. The @'trimLookupLo' lk hk t@ performs both+-- @'trim' (JustS lk) hk t@ and @'lookup' lk t@.++-- See Note: Type of local 'go' function+trimLookupLo :: Ord k => k -> MaybeS k -> Map k a -> (Maybe a, Map k a)+trimLookupLo lk0 mhk0 t0 = toPair $ go lk0 mhk0 t0+ where+ go lk NothingS t = greater lk t+ where greater :: Ord k => k -> Map k a -> StrictPair (Maybe a) (Map k a)+ greater lo t'@(Bin _ kx x l r) = case compare lo kx of+ LT -> lookup lo l :*: t'+ EQ -> (Just x :*: r)+ GT -> greater lo r+ greater _ Tip = (Nothing :*: Tip)+ go lk (JustS hk) t = middle lk hk t+ where middle :: Ord k => k -> k -> Map k a -> StrictPair (Maybe a) (Map k a)+ middle lo hi t'@(Bin _ kx x l r) = case compare lo kx of+ LT | kx < hi -> lookup lo l :*: t'+ | otherwise -> middle lo hi l+ EQ -> Just x :*: lesser hi r+ GT -> middle lo hi r+ middle _ _ Tip = (Nothing :*: Tip)++ lesser :: Ord k => k -> Map k a -> Map k a+ lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l+ lesser _ t' = t'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE trimLookupLo #-}+#endif+++{--------------------------------------------------------------------+ [filterGt b t] filter all keys >[b] from tree [t]+ [filterLt b t] filter all keys <[b] from tree [t]+--------------------------------------------------------------------}+filterGt :: Ord k => MaybeS k -> Map k v -> Map k v+filterGt NothingS t = t+filterGt (JustS b) t = filter' b t+ where filter' _ Tip = Tip+ filter' b' (Bin _ kx x l r) =+ case compare b' kx of LT -> join kx x (filter' b' l) r+ EQ -> r+ GT -> filter' b' r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE filterGt #-}+#endif++filterLt :: Ord k => MaybeS k -> Map k v -> Map k v+filterLt NothingS t = t+filterLt (JustS b) t = filter' b t+ where filter' _ Tip = Tip+ filter' b' (Bin _ kx x l r) =+ case compare kx b' of LT -> join kx x l (filter' b' r)+ EQ -> l+ GT -> filter' b' l+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE filterLt #-}+#endif++{--------------------------------------------------------------------+ Split+--------------------------------------------------------------------}+-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.+-- Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)+-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)++split :: Ord k => k -> Map k a -> (Map k a,Map k a)+split k0 t0 = k0 `seq` toPair $ go k0 t0+ where+ go k t =+ case t of+ Tip -> (Tip :*: Tip)+ Bin _ kx x l r -> case compare k kx of+ LT -> let (lt :*: gt) = go k l in lt :*: join kx x gt r+ GT -> let (lt :*: gt) = go k r in join kx x l lt :*: gt+ EQ -> (l :*: r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE split #-}+#endif++-- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just+-- like 'split' but also returns @'lookup' k map@.+--+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)+-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)++splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)+splitLookup k t = k `seq`+ case t of+ Tip -> (Tip,Nothing,Tip)+ Bin _ kx x l r -> case compare k kx of+ LT -> let (lt,z,gt) = splitLookup k l+ gt' = join kx x gt r+ in gt' `seq` (lt,z,gt')+ GT -> let (lt,z,gt) = splitLookup k r+ lt' = join kx x l lt+ in lt' `seq` (lt',z,gt)+ EQ -> (l,Just x,r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE splitLookup #-}+#endif++{--------------------------------------------------------------------+ Utility functions that maintain the balance properties of the tree.+ All constructors assume that all values in [l] < [k] and all values+ in [r] > [k], and that [l] and [r] are valid trees.++ In order of sophistication:+ [Bin sz k x l r] The type constructor.+ [bin k x l r] Maintains the correct size, assumes that both [l]+ and [r] are balanced with respect to each other.+ [balance k x l r] Restores the balance and size.+ Assumes that the original tree was balanced and+ that [l] or [r] has changed by at most one element.+ [join k x l r] Restores balance and size.++ Furthermore, we can construct a new tree from two trees. Both operations+ assume that all values in [l] < all values in [r] and that [l] and [r]+ are valid:+ [glue l r] Glues [l] and [r] together. Assumes that [l] and+ [r] are already balanced with respect to each other.+ [merge l r] Merges two trees and restores balance.++ Note: in contrast to Adam's paper, we use (<=) comparisons instead+ of (<) comparisons in [join], [merge] and [balance].+ Quickcheck (on [difference]) showed that this was necessary in order+ to maintain the invariants. It is quite unsatisfactory that I haven't+ been able to find out why this is actually the case! Fortunately, it+ doesn't hurt to be a bit more conservative.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+ Join+--------------------------------------------------------------------}+join :: k -> a -> Map k a -> Map k a -> Map k a+join kx x Tip r = insertMin kx x r+join kx x l Tip = insertMax kx x l+join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)+ | delta*sizeL < sizeR = balanceL kz z (join kx x l lz) rz+ | delta*sizeR < sizeL = balanceR ky y ly (join kx x ry r)+ | otherwise = bin kx x l r+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: k -> a -> Map k a -> Map k a+insertMax kx x t+ = case t of+ Tip -> singleton kx x+ Bin _ ky y l r+ -> balanceR ky y l (insertMax kx x r)++insertMin kx x t+ = case t of+ Tip -> singleton kx x+ Bin _ ky y l r+ -> balanceL ky y (insertMin kx x l) r++{--------------------------------------------------------------------+ [merge l r]: merges two trees.+--------------------------------------------------------------------}+merge :: Map k a -> Map k a -> Map k a+merge Tip r = r+merge l Tip = l+merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)+ | delta*sizeL < sizeR = balanceL ky y (merge l ly) ry+ | delta*sizeR < sizeL = balanceR kx x lx (merge rx r)+ | otherwise = glue l r++{--------------------------------------------------------------------+ [glue l r]: glues two trees together.+ Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: Map k a -> Map k a -> Map k a+glue Tip r = r+glue l Tip = l+glue l r+ | size l > size r = let ((km,m),l') = deleteFindMax l in balanceR km m l' r+ | otherwise = let ((km,m),r') = deleteFindMin r in balanceL km m l r'+++-- | /O(log n)/. Delete and find the minimal element.+--+-- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])+-- > deleteFindMin Error: can not return the minimal element of an empty map++deleteFindMin :: Map k a -> ((k,a),Map k a)+deleteFindMin t+ = case t of+ Bin _ k x Tip r -> ((k,x),r)+ Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balanceR k x l' r)+ Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)++-- | /O(log n)/. Delete and find the maximal element.+--+-- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])+-- > deleteFindMax empty Error: can not return the maximal element of an empty map++deleteFindMax :: Map k a -> ((k,a),Map k a)+deleteFindMax t+ = case t of+ Bin _ k x l Tip -> ((k,x),l)+ Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balanceL k x l r')+ Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)+++{--------------------------------------------------------------------+ [balance l x r] balances two trees with value x.+ The sizes of the trees should balance after decreasing the+ size of one of them. (a rotation).++ [delta] is the maximal relative difference between the sizes of+ two trees, it corresponds with the [w] in Adams' paper.+ [ratio] is the ratio between an outer and inner sibling of the+ heavier subtree in an unbalanced setting. It determines+ whether a double or single rotation should be performed+ to restore balance. It is corresponds with the inverse+ of $\alpha$ in Adam's article.++ Note that according to the Adam's paper:+ - [delta] should be larger than 4.646 with a [ratio] of 2.+ - [delta] should be larger than 3.745 with a [ratio] of 1.534.++ But the Adam's paper is erroneous:+ - It can be proved that for delta=2 and delta>=5 there does+ not exist any ratio that would work.+ - Delta=4.5 and ratio=2 does not work.++ That leaves two reasonable variants, delta=3 and delta=4,+ both with ratio=2.++ - A lower [delta] leads to a more 'perfectly' balanced tree.+ - A higher [delta] performs less rebalancing.++ In the benchmarks, delta=3 is faster on insert operations,+ and delta=4 has slightly better deletes. As the insert speedup+ is larger, we currently use delta=3.++--------------------------------------------------------------------}+delta,ratio :: Int+delta = 3+ratio = 2++-- The balance function is equivalent to the following:+--+-- balance :: k -> a -> Map k a -> Map k a -> Map k a+-- balance k x l r+-- | sizeL + sizeR <= 1 = Bin sizeX k x l r+-- | sizeR > delta*sizeL = rotateL k x l r+-- | sizeL > delta*sizeR = rotateR k x l r+-- | otherwise = Bin sizeX k x l r+-- where+-- sizeL = size l+-- sizeR = size r+-- sizeX = sizeL + sizeR + 1+--+-- rotateL :: a -> b -> Map a b -> Map a b -> Map a b+-- rotateL k x l r@(Bin _ _ _ ly ry) | size ly < ratio*size ry = singleL k x l r+-- | otherwise = doubleL k x l r+--+-- rotateR :: a -> b -> Map a b -> Map a b -> Map a b+-- rotateR k x l@(Bin _ _ _ ly ry) r | size ry < ratio*size ly = singleR k x l r+-- | otherwise = doubleR k x l r+--+-- singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b+-- singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3+-- singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)+--+-- doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b+-- doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)+-- doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)+--+-- It is only written in such a way that every node is pattern-matched only once.++balance :: k -> a -> Map k a -> Map k a -> Map k a+balance k x l r = case l of+ Tip -> case r of+ Tip -> Bin 1 k x Tip Tip+ (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+ (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+ (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+ (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+ | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+ | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++ (Bin ls lk lx ll lr) -> case r of+ Tip -> case (ll, lr) of+ (Tip, Tip) -> Bin 2 k x l Tip+ (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+ ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+ ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr))+ | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+ | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)+ (Bin rs rk rx rl rr)+ | rs > delta*ls -> case (rl, rr) of+ (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+ | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+ | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)+ (_, _) -> error "Failure in Data.Map.balance"+ | ls > delta*rs -> case (ll, lr) of+ (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+ | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+ | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)+ (_, _) -> error "Failure in Data.Map.balance"+ | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balance #-}++-- Functions balanceL and balanceR are specialised versions of balance.+-- balanceL only checks whether the left subtree is too big,+-- balanceR only checks whether the right subtree is too big.++-- balanceL is called when left subtree might have been inserted to or when+-- right subtree might have been deleted from.+balanceL :: k -> a -> Map k a -> Map k a -> Map k a+balanceL k x l r = case r of+ Tip -> case l of+ Tip -> Bin 1 k x Tip Tip+ (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip+ (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+ (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+ (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))+ | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+ | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)++ (Bin rs _ _ _ _) -> case l of+ Tip -> Bin (1+rs) k x Tip r++ (Bin ls lk lx ll lr)+ | ls > delta*rs -> case (ll, lr) of+ (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+ | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+ | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)+ (_, _) -> error "Failure in Data.Map.balanceL"+ | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balanceL #-}++-- balanceR is called when right subtree might have been inserted to or when+-- left subtree might have been deleted from.+balanceR :: k -> a -> Map k a -> Map k a -> Map k a+balanceR k x l r = case l of+ Tip -> case r of+ Tip -> Bin 1 k x Tip Tip+ (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+ (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+ (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+ (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+ | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+ | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++ (Bin ls _ _ _ _) -> case r of+ Tip -> Bin (1+ls) k x l Tip++ (Bin rs rk rx rl rr)+ | rs > delta*ls -> case (rl, rr) of+ (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+ | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+ | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)+ (_, _) -> error "Failure in Data.Map.balanceR"+ | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balanceR #-}+++{--------------------------------------------------------------------+ The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin :: k -> a -> Map k a -> Map k a -> Map k a+bin k x l r+ = Bin (size l + size r + 1) k x l r+{-# INLINE bin #-}+++{--------------------------------------------------------------------+ Eq converts the tree to a list. In a lazy setting, this+ actually seems one of the faster methods to compare two trees+ and it is certainly the simplest :-)+--------------------------------------------------------------------}+instance (Eq k,Eq a) => Eq (Map k a) where+ t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)++{--------------------------------------------------------------------+ Ord+--------------------------------------------------------------------}++instance (Ord k, Ord v) => Ord (Map k v) where+ compare m1 m2 = compare (toAscList m1) (toAscList m2)++{--------------------------------------------------------------------+ Functor+--------------------------------------------------------------------}+instance Functor (Map k) where+ fmap f m = map f m++instance Traversable (Map k) where+ traverse f = traverseWithKey (\_ -> f)++instance Foldable.Foldable (Map k) where+ fold Tip = mempty+ fold (Bin _ _ v l r) = Foldable.fold l `mappend` v `mappend` Foldable.fold r+ foldr = foldr+ foldl = foldl+ foldMap _ Tip = mempty+ foldMap f (Bin _ _ v l r) = Foldable.foldMap f l `mappend` f v `mappend` Foldable.foldMap f r++instance (NFData k, NFData a) => NFData (Map k a) where+ rnf Tip = ()+ rnf (Bin _ kx x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance (Ord k, Read k, Read e) => Read (Map k e) where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++{--------------------------------------------------------------------+ Show+--------------------------------------------------------------------}+instance (Show k, Show a) => Show (Map k a) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)++-- | /O(n)/. Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format. See 'showTreeWith'.+showTree :: (Show k,Show a) => Map k a -> String+showTree m+ = showTreeWith showElem True False m+ where+ showElem k x = show k ++ ":=" ++ show x+++{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows+ the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.++> Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t+> (4,())+> +--(2,())+> | +--(1,())+> | +--(3,())+> +--(5,())+>+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t+> (4,())+> |+> +--(2,())+> | |+> | +--(1,())+> | |+> | +--(3,())+> |+> +--(5,())+>+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t+> +--(5,())+> |+> (4,())+> |+> | +--(3,())+> | |+> +--(2,())+> |+> +--(1,())++-}+showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String+showTreeWith showelem hang wide t+ | hang = (showsTreeHang showelem wide [] t) ""+ | otherwise = (showsTree showelem wide [] [] t) ""++showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS+showsTree showelem wide lbars rbars t+ = case t of+ Tip -> showsBars lbars . showString "|\n"+ Bin _ kx x Tip Tip+ -> showsBars lbars . showString (showelem kx x) . showString "\n"+ Bin _ kx x l r+ -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .+ showWide wide rbars .+ showsBars lbars . showString (showelem kx x) . showString "\n" .+ showWide wide lbars .+ showsTree showelem wide (withEmpty lbars) (withBar lbars) l++showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS+showsTreeHang showelem wide bars t+ = case t of+ Tip -> showsBars bars . showString "|\n"+ Bin _ kx x Tip Tip+ -> showsBars bars . showString (showelem kx x) . showString "\n"+ Bin _ kx x l r+ -> showsBars bars . showString (showelem kx x) . showString "\n" .+ showWide wide bars .+ showsTreeHang showelem wide (withBar bars) l .+ showWide wide bars .+ showsTreeHang showelem wide (withEmpty bars) r++showWide :: Bool -> [String] -> String -> String+showWide wide bars+ | wide = showString (concat (reverse bars)) . showString "|\n"+ | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+ = case bars of+ [] -> id+ _ -> showString (concat (reverse (tail bars))) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars = "| ":bars+withEmpty bars = " ":bars++{--------------------------------------------------------------------+ Typeable+--------------------------------------------------------------------}++#include "Typeable.h"+INSTANCE_TYPEABLE2(Map,mapTc,"Map")++{--------------------------------------------------------------------+ Assertions+--------------------------------------------------------------------}+-- | /O(n)/. Test if the internal map structure is valid.+--+-- > valid (fromAscList [(3,"b"), (5,"a")]) == True+-- > valid (fromAscList [(5,"a"), (3,"b")]) == False++valid :: Ord k => Map k a -> Bool+valid t+ = balanced t && ordered t && validsize t++ordered :: Ord a => Map a b -> Bool+ordered t+ = bounded (const True) (const True) t+ where+ bounded lo hi t'+ = case t' of+ Tip -> True+ Bin _ kx _ l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r++-- | Exported only for "Debug.QuickCheck"+balanced :: Map k a -> Bool+balanced t+ = case t of+ Tip -> True+ Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&+ balanced l && balanced r++validsize :: Map a b -> Bool+validsize t+ = (realsize t == Just (size t))+ where+ realsize t'+ = case t' of+ Tip -> Just 0+ Bin sz _ _ l r -> case (realsize l,realsize r) of+ (Just n,Just m) | n+m+1 == sz -> Just sz+ _ -> Nothing++{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}+foldlStrict :: (a -> b -> a) -> a -> [b] -> a+foldlStrict f = go+ where+ go z [] = z+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs+{-# INLINE foldlStrict #-}
+ containers-0.5.2.1/Darcs/Data/Map/Strict.hs view
@@ -0,0 +1,1180 @@+{-# LANGUAGE CPP #-}+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Safe #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.Map.Strict+-- Copyright : (c) Daan Leijen 2002+-- (c) Andriy Palamarchuk 2008+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- An efficient implementation of ordered maps from keys to values+-- (dictionaries).+--+-- API of this module is strict in both the keys and the values.+-- If you need value-lazy maps, use "Data.Map.Lazy" instead.+-- The 'Map' type is shared between the lazy and strict modules,+-- meaning that the same 'Map' value can be passed to functions in+-- both modules (although that is rarely needed).+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- > import qualified Data.Map.Strict as Map+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+-- * Stephen Adams, \"/Efficient sets: a balancing act/\",+-- Journal of Functional Programming 3(4):553-562, October 1993,+-- <http://www.swiss.ai.mit.edu/~adams/BB/>.+--+-- * J. Nievergelt and E.M. Reingold,+-- \"/Binary search trees of bounded balance/\",+-- SIAM journal of computing 2(1), March 1973.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'.+--+-- Operation comments contain the operation time complexity in+-- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).+--+-- Be aware that the 'Functor', 'Traversable' and 'Data' instances+-- are the same as for the "Data.Map.Lazy" module, so if they are used+-- on strict maps, the resulting maps will be lazy.+-----------------------------------------------------------------------------++-- See the notes at the beginning of Data.Map.Base.++module Darcs.Data.Map.Strict+ (+ -- * Strictness properties+ -- $strictness++ -- * Map type+#if !defined(TESTING)+ Map -- instance Eq,Show,Read+#else+ Map(..) -- instance Eq,Show,Read+#endif++ -- * Operators+ , (!), (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookup+ , findWithDefault+ , lookupLT+ , lookupGT+ , lookupLE+ , lookupGE++ -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWithKey+ , insertLookupWithKey++ -- ** Delete\/Update+ , delete+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter++ -- * Combine++ -- ** Union+ , union+ , unionWith+ , unionWithKey+ , unions+ , unionsWith++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey++ -- ** Intersection+ , intersection+ , intersectionWith+ , intersectionWithKey++ -- ** Universal combining function+ , mergeWithKey++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , traverseWithKey+ , mapAccum+ , mapAccumWithKey+ , mapAccumRWithKey+ , mapKeys+ , mapKeysWith+ , mapKeysMonotonic++ -- * Folds+ , foldr+ , foldl+ , foldrWithKey+ , foldlWithKey+ -- ** Strict folds+ , foldr'+ , foldl'+ , foldrWithKey'+ , foldlWithKey'++ -- * Conversion+ , elems+ , keys+ , assocs+ , keysSet+ , fromSet++ -- ** Lists+ , toList+ , fromList+ , fromListWith+ , fromListWithKey++ -- ** Ordered lists+ , toAscList+ , toDescList+ , fromAscList+ , fromAscListWith+ , fromAscListWithKey+ , fromDistinctAscList++ -- * Filter+ , filter+ , filterWithKey+ , partition+ , partitionWithKey++ , mapMaybe+ , mapMaybeWithKey+ , mapEither+ , mapEitherWithKey++ , split+ , splitLookup++ -- * Submap+ , isSubmapOf, isSubmapOfBy+ , isProperSubmapOf, isProperSubmapOfBy++ -- * Indexed+ , lookupIndex+ , findIndex+ , elemAt+ , updateAt+ , deleteAt++ -- * Min\/Max+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , updateMin+ , updateMax+ , updateMinWithKey+ , updateMaxWithKey+ , minView+ , maxView+ , minViewWithKey+ , maxViewWithKey++ -- * Debugging+ , showTree+ , showTreeWith+ , valid++#if defined(TESTING)+ -- * Internals+ , bin+ , balanced+ , join+ , merge+#endif+ ) where++import Prelude hiding (lookup,map,filter,foldr,foldl,null)++import Darcs.Data.Map.Base hiding+ ( findWithDefault+ , singleton+ , insert+ , insertWith+ , insertWithKey+ , insertLookupWithKey+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter+ , unionWith+ , unionWithKey+ , unionsWith+ , differenceWith+ , differenceWithKey+ , intersectionWith+ , intersectionWithKey+ , mergeWithKey+ , map+ , mapWithKey+ , mapAccum+ , mapAccumWithKey+ , mapAccumRWithKey+ , mapKeysWith+ , fromSet+ , fromList+ , fromListWith+ , fromListWithKey+ , fromAscList+ , fromAscListWith+ , fromAscListWithKey+ , fromDistinctAscList+ , mapMaybe+ , mapMaybeWithKey+ , mapEither+ , mapEitherWithKey+ , updateAt+ , updateMin+ , updateMax+ , updateMinWithKey+ , updateMaxWithKey+ )+import qualified Darcs.Data.Set.Base as Set+import Darcs.Data.StrictPair+import Data.Bits (shiftL, shiftR)++-- Use macros to define strictness of functions. STRICT_x_OF_y+-- denotes an y-ary function strict in the x-th parameter. Similarly+-- STRICT_x_y_OF_z denotes an z-ary function strict in the x-th and+-- y-th parameter. We do not use BangPatterns, because they are not+-- in any standard and we want the compilers to be compiled by as many+-- compilers as possible.+#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined+#define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined+#define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined+#define STRICT_1_2_OF_3(fn) fn arg1 arg2 _ | arg1 `seq` arg2 `seq` False = undefined+#define STRICT_2_3_OF_4(fn) fn _ arg1 arg2 _ | arg1 `seq` arg2 `seq` False = undefined++-- $strictness+--+-- This module satisfies the following strictness properties:+--+-- 1. Key and value arguments are evaluated to WHNF;+--+-- 2. Keys and values are evaluated to WHNF before they are stored in+-- the map.+--+-- Here are some examples that illustrate the first property:+--+-- > insertWith (\ new old -> old) k undefined m == undefined+-- > delete undefined m == undefined+--+-- Here are some examples that illustrate the second property:+--+-- > map (\ v -> undefined) m == undefined -- m is not empty+-- > mapKeys (\ k -> undefined) m == undefined -- m is not empty++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}++-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++-- See Map.Base.Note: Local 'go' functions and capturing+findWithDefault :: Ord k => a -> k -> Map k a -> a+findWithDefault def k = def `seq` k `seq` go+ where+ go Tip = def+ go (Bin _ kx x l r) = case compare k kx of+ LT -> go l+ GT -> go r+ EQ -> x+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE findWithDefault #-}+#else+{-# INLINE findWithDefault #-}+#endif++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}++-- | /O(1)/. A map with a single element.+--+-- > singleton 1 'a' == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: k -> a -> Map k a+singleton k x = x `seq` Bin 1 k x Tip Tip+{-# INLINE singleton #-}++{--------------------------------------------------------------------+ Insertion+--------------------------------------------------------------------}+-- | /O(log n)/. Insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty == singleton 5 'x'++-- See Map.Base.Note: Type of local 'go' function+insert :: Ord k => k -> a -> Map k a -> Map k a+insert = go+ where+ go :: Ord k => k -> a -> Map k a -> Map k a+ STRICT_1_2_OF_3(go)+ go kx x Tip = singleton kx x+ go kx x (Bin sz ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go kx x l) r+ GT -> balanceR ky y l (go kx x r)+ EQ -> Bin sz kx x l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insert #-}+#else+{-# INLINE insert #-}+#endif++-- | /O(log n)/. Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"++insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWith f = insertWithKey (\_ x' y' -> f x' y')+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertWith #-}+#else+{-# INLINE insertWith #-}+#endif++-- | /O(log n)/. Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key,f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"++-- See Map.Base.Note: Type of local 'go' function+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey = go+ where+ go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+ STRICT_2_3_OF_4(go)+ go _ kx x Tip = singleton kx x+ go f kx x (Bin sy ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go f kx x l) r+ GT -> balanceR ky y l (go f kx x r)+ EQ -> let x' = f kx x y+ in x' `seq` Bin sy kx x' l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertWithKey #-}+#else+{-# INLINE insertWithKey #-}+#endif++-- | /O(log n)/. Combines insert operation with old value retrieval.+-- The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])++-- See Map.Base.Note: Type of local 'go' function+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a+ -> (Maybe a, Map k a)+insertLookupWithKey f0 kx0 x0 t0 = toPair $ go f0 kx0 x0 t0+ where+ go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)+ STRICT_2_3_OF_4(go)+ go _ kx x Tip = Nothing :*: singleton kx x+ go f kx x (Bin sy ky y l r) =+ case compare kx ky of+ LT -> let (found :*: l') = go f kx x l+ in found :*: balanceL ky y l' r+ GT -> let (found :*: r') = go f kx x r+ in found :*: balanceR ky y l r'+ EQ -> let x' = f kx x y+ in x' `seq` (Just y :*: Bin sy kx x' l r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertLookupWithKey #-}+#else+{-# INLINE insertLookupWithKey #-}+#endif++{--------------------------------------------------------------------+ Deletion+--------------------------------------------------------------------}++-- | /O(log n)/. Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty == empty++adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a+adjust f = adjustWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE adjust #-}+#else+{-# INLINE adjust #-}+#endif++-- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty == empty++adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x'))+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE adjustWithKey #-}+#else+{-# INLINE adjustWithKey #-}+#endif++-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a+update f = updateWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE update #-}+#else+{-# INLINE update #-}+#endif++-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++-- See Map.Base.Note: Type of local 'go' function+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+updateWithKey = go+ where+ go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+ STRICT_2_OF_3(go)+ go _ _ Tip = Tip+ go f k(Bin sx kx x l r) =+ case compare k kx of+ LT -> balanceR kx x (go f k l) r+ GT -> balanceL kx x l (go f k r)+ EQ -> case f kx x of+ Just x' -> x' `seq` Bin sx kx x' l r+ Nothing -> glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateWithKey #-}+#else+{-# INLINE updateWithKey #-}+#endif++-- | /O(log n)/. Lookup and update. See also 'updateWithKey'.+-- The function returns changed value, if it is updated.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++-- See Map.Base.Note: Type of local 'go' function+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)+updateLookupWithKey f0 k0 t0 = toPair $ go f0 k0 t0+ where+ go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)+ STRICT_2_OF_3(go)+ go _ _ Tip = (Nothing :*: Tip)+ go f k (Bin sx kx x l r) =+ case compare k kx of+ LT -> let (found :*: l') = go f k l+ in found :*: balanceR kx x l' r+ GT -> let (found :*: r') = go f k r+ in found :*: balanceL kx x l r'+ EQ -> case f kx x of+ Just x' -> x' `seq` (Just x' :*: Bin sx kx x' l r)+ Nothing -> (Just x :*: glue l r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateLookupWithKey #-}+#else+{-# INLINE updateLookupWithKey #-}+#endif++-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+--+-- > let f _ = Nothing+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- >+-- > let f _ = Just "c"+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]++-- See Map.Base.Note: Type of local 'go' function+alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+alter = go+ where+ go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+ STRICT_2_OF_3(go)+ go f k Tip = case f Nothing of+ Nothing -> Tip+ Just x -> singleton k x++ go f k (Bin sx kx x l r) = case compare k kx of+ LT -> balance kx x (go f k l) r+ GT -> balance kx x l (go f k r)+ EQ -> case f (Just x) of+ Just x' -> x' `seq` Bin sx kx x' l r+ Nothing -> glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE alter #-}+#else+{-# INLINE alter #-}+#endif++{--------------------------------------------------------------------+ Indexing+--------------------------------------------------------------------}++-- | /O(log n)/. Update the element at /index/. Calls 'error' when an+-- invalid index is used.+--+-- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]+-- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]+-- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range++updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a+updateAt f i t = i `seq`+ case t of+ Tip -> error "Map.updateAt: index out of range"+ Bin sx kx x l r -> case compare i sizeL of+ LT -> balanceR kx x (updateAt f i l) r+ GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)+ EQ -> case f kx x of+ Just x' -> x' `seq` Bin sx kx x' l r+ Nothing -> glue l r+ where+ sizeL = size l++{--------------------------------------------------------------------+ Minimal, Maximal+--------------------------------------------------------------------}++-- | /O(log n)/. Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> Map k a -> Map k a+updateMin f m+ = updateMinWithKey (\_ x -> f x) m++-- | /O(log n)/. Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> Map k a -> Map k a+updateMax f m+ = updateMaxWithKey (\_ x -> f x) m+++-- | /O(log n)/. Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMinWithKey _ Tip = Tip+updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of+ Nothing -> r+ Just x' -> x' `seq` Bin sx kx x' Tip r+updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r++-- | /O(log n)/. Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMaxWithKey _ Tip = Tip+updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of+ Nothing -> l+ Just x' -> x' `seq` Bin sx kx x' l Tip+updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r)++{--------------------------------------------------------------------+ Union.+--------------------------------------------------------------------}++-- | The union of a list of maps, with a combining operation:+-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a+unionsWith f ts+ = foldlStrict (unionWith f) empty ts+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unionsWith #-}+#endif++{--------------------------------------------------------------------+ Union with a combining function+--------------------------------------------------------------------}+-- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWith f m1 m2+ = unionWithKey (\_ x y -> f x y) m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unionWith #-}+#endif++-- | /O(n+m)/.+-- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) id id t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unionWithKey #-}+#endif++{--------------------------------------------------------------------+ Difference+--------------------------------------------------------------------}++-- | /O(n+m)/. Difference with a combining function.+-- When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- > == singleton 3 "b:B"++differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWith f m1 m2+ = differenceWithKey (\_ x y -> f x y) m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE differenceWith #-}+#endif++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- > == singleton 3 "3:b|B"++differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWithKey f t1 t2 = mergeWithKey f id (const Tip) t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE differenceWithKey #-}+#endif+++{--------------------------------------------------------------------+ Intersection+--------------------------------------------------------------------}++-- | /O(n+m)/. Intersection with a combining function. The implementation uses+-- an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWith f m1 m2+ = intersectionWithKey (\_ x y -> f x y) m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE intersectionWith #-}+#endif++-- | /O(n+m)/. Intersection with a combining function. The implementation uses+-- an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"+++intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) (const Tip) (const Tip) t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE intersectionWithKey #-}+#endif+++{--------------------------------------------------------------------+ MergeWithKey+--------------------------------------------------------------------}++-- | /O(n+m)/. A high-performance universal combining function. This function+-- is used to define 'unionWith', 'unionWithKey', 'differenceWith',+-- 'differenceWithKey', 'intersectionWith', 'intersectionWithKey' and can be+-- used to define other custom combine functions.+--+-- Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'IntMap's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+-- values to the @combine@ function. Depending on the result, the key is either+-- present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+-- the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+-- the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c)+ -> Map k a -> Map k b -> Map k c+mergeWithKey f g1 g2 = go+ where+ go Tip t2 = g2 t2+ go t1 Tip = g1 t1+ go t1 t2 = hedgeMerge NothingS NothingS t1 t2++ hedgeMerge _ _ t1 Tip = g1 t1+ hedgeMerge blo bhi Tip (Bin _ kx x l r) = g2 $ join kx x (filterGt blo l) (filterLt bhi r)+ hedgeMerge blo bhi (Bin _ kx x l r) t2 = let l' = hedgeMerge blo bmi l (trim blo bmi t2)+ (found, trim_t2) = trimLookupLo kx bhi t2+ r' = hedgeMerge bmi bhi r trim_t2+ in case found of+ Nothing -> case g1 (singleton kx x) of+ Tip -> merge l' r'+ (Bin _ _ x' Tip Tip) -> join kx x' l' r'+ _ -> error "mergeWithKey: Given function only1 does not fulfil required conditions (see documentation)"+ Just x2 -> case f kx x x2 of+ Nothing -> merge l' r'+ Just x' -> x' `seq` join kx x' l' r'+ where bmi = JustS kx+{-# INLINE mergeWithKey #-}++{--------------------------------------------------------------------+ Filter and partition+--------------------------------------------------------------------}++-- | /O(n)/. Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b+mapMaybeWithKey _ Tip = Tip+mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of+ Just y -> y `seq` join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)+ Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r)++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEither f m+ = mapEitherWithKey (\_ x -> f x) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+ where+ go _ Tip = (Tip :*: Tip)+ go f (Bin _ kx x l r) = case f kx x of+ Left y -> y `seq` (join kx y l1 r1 :*: merge l2 r2)+ Right z -> z `seq` (merge l1 r1 :*: join kx z l2 r2)+ where+ (l1 :*: l2) = go f l+ (r1 :*: r2) = go f r++{--------------------------------------------------------------------+ Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Map k a -> Map k b+map _ Tip = Tip+map f (Bin sx kx x l r) = let x' = f x in x' `seq` Bin sx kx x' (map f l) (map f r)++-- | /O(n)/. Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (k -> a -> b) -> Map k a -> Map k b+mapWithKey _ Tip = Tip+mapWithKey f (Bin sx kx x l r) = let x' = f kx x+ in x' `seq` Bin sx kx x' (mapWithKey f l) (mapWithKey f r)++-- | /O(n)/. The function 'mapAccum' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccum f a m+ = mapAccumWithKey (\a' _ x' -> f a' x') a m++-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumWithKey f a t+ = mapAccumL f a t++-- | /O(n)/. The function 'mapAccumL' threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumL _ a Tip = (a,Tip)+mapAccumL f a (Bin sx kx x l r) =+ let (a1,l') = mapAccumL f a l+ (a2,x') = f a1 kx x+ (a3,r') = mapAccumL f a2 r+ in x' `seq` (a3,Bin sx kx x' l' r')++-- | /O(n)/. The function 'mapAccumR' threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumRWithKey _ a Tip = (a,Tip)+mapAccumRWithKey f a (Bin sx kx x l r) =+ let (a1,r') = mapAccumRWithKey f a r+ (a2,x') = f a1 kx x+ (a3,l') = mapAccumRWithKey f a2 l+ in x' `seq` (a3,Bin sx kx x' l' r')++-- | /O(n*log n)/.+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the associated values will be+-- combined using @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"++mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a+mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapKeysWith #-}+#endif++{--------------------------------------------------------------------+ Conversions+--------------------------------------------------------------------}++-- | /O(n)/. Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.Set.empty == empty++fromSet :: (k -> a) -> Set.Set k -> Map k a+fromSet _ Set.Tip = Tip+fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r)++{--------------------------------------------------------------------+ Lists+ use [foldlStrict] to reduce demand on the control-stack+--------------------------------------------------------------------}+-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+--+-- If the keys of the list are ordered, linear-time implementation is used,+-- with the performance equal to 'fromDistinctAscList'.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++-- For some reason, when 'singleton' is used in fromList or in+-- create, it is not inlined, so we inline it manually.+fromList :: Ord k => [(k,a)] -> Map k a+fromList [] = Tip+fromList [(kx, x)] = x `seq` Bin 1 kx x Tip Tip+fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = x0 `seq` fromList' (Bin 1 kx0 x0 Tip Tip) xs0+ | otherwise = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0+ where+ not_ordered _ [] = False+ not_ordered kx ((ky,_) : _) = kx >= ky+ {-# INLINE not_ordered #-}++ fromList' t0 xs = foldlStrict ins t0 xs+ where ins t (k,x) = insert k x t++ STRICT_1_OF_3(go)+ go _ t [] = t+ go _ t [(kx, x)] = x `seq` insertMax kx x t+ go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs+ | otherwise = case create s xss of+ (r, ys, []) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys+ (r, _, ys) -> x `seq` fromList' (join kx x l r) ys++ -- The create is returning a triple (tree, xs, ys). Both xs and ys+ -- represent not yet processed elements and only one of them can be nonempty.+ -- If ys is nonempty, the keys in ys are not ordered with respect to tree+ -- and must be inserted using fromList'. Otherwise the keys have been+ -- ordered so far.+ STRICT_1_OF_2(create)+ create _ [] = (Tip, [], [])+ create s xs@(xp : xss)+ | s == 1 = case xp of (kx, x) | not_ordered kx xss -> x `seq` (Bin 1 kx x Tip Tip, [], xss)+ | otherwise -> x `seq` (Bin 1 kx x Tip Tip, xss, [])+ | otherwise = case create (s `shiftR` 1) xs of+ res@(_, [], _) -> res+ (l, [(ky, y)], zs) -> y `seq` (insertMax ky y l, [], zs)+ (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)+ | otherwise -> case create (s `shiftR` 1) yss of+ (r, zs, ws) -> y `seq` (join ky y l r, zs, ws)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromList #-}+#endif++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [] == empty++fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a+fromListWith f xs+ = fromListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromListWith #-}+#endif++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.+--+-- > let f k a1 a2 = (show k) ++ a1 ++ a2+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]+-- > fromListWithKey f [] == empty++fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromListWithKey f xs+ = foldlStrict ins empty xs+ where+ ins t (k,x) = insertWithKey f k x t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromListWithKey #-}+#endif++{--------------------------------------------------------------------+ Building trees from ascending/descending lists can be done in linear time.++ Note that if [xs] is ascending that:+ fromAscList xs == fromList xs+ fromAscListWith f xs == fromListWith f xs+--------------------------------------------------------------------}+-- | /O(n)/. Build a map from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]+-- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False++fromAscList :: Eq k => [(k,a)] -> Map k a+fromAscList xs+ = fromAscListWithKey (\_ x _ -> x) xs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromAscList #-}+#endif++-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+-- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False++fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWith f xs+ = fromAscListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromAscListWith #-}+#endif++-- | /O(n)/. Build a map from an ascending list in linear time with a+-- combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]+-- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True+-- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False++fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWithKey f xs+ = fromDistinctAscList (combineEq f xs)+ where+ -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+ combineEq _ xs'+ = case xs' of+ [] -> []+ [x] -> [x]+ (x:xx) -> combineEq' x xx++ combineEq' z [] = [z]+ combineEq' z@(kz,zz) (x@(kx,xx):xs')+ | kx==kz = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'+ | otherwise = z:combineEq' x xs'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromAscListWithKey #-}+#endif++-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.+-- /The precondition is not checked./+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True+-- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False++-- For some reason, when 'singleton' is used in fromDistinctAscList or in+-- create, it is not inlined, so we inline it manually.+fromDistinctAscList :: [(k,a)] -> Map k a+fromDistinctAscList [] = Tip+fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0+ where+ STRICT_1_OF_3(go)+ go _ t [] = t+ go s l ((kx, x) : xs) = case create s xs of+ (r, ys) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys++ STRICT_1_OF_2(create)+ create _ [] = (Tip, [])+ create s xs@(x' : xs')+ | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip, xs')+ | otherwise = case create (s `shiftR` 1) xs of+ res@(_, []) -> res+ (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of+ (r, zs) -> y `seq` (join ky y l r, zs)
+ containers-0.5.2.1/Darcs/Data/Set/Base.hs view
@@ -0,0 +1,1526 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}+#endif+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.Set.Base+-- Copyright : (c) Daan Leijen 2002+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- An efficient implementation of sets.+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- > import Data.Set (Set)+-- > import qualified Data.Set as Set+--+-- The implementation of 'Set' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+-- * Stephen Adams, \"/Efficient sets: a balancing act/\",+-- Journal of Functional Programming 3(4):553-562, October 1993,+-- <http://www.swiss.ai.mit.edu/~adams/BB/>.+--+-- * J. Nievergelt and E.M. Reingold,+-- \"/Binary search trees of bounded balance/\",+-- SIAM journal of computing 2(1), March 1973.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'. Of course, left-biasing can only be observed+-- when equality is an equivalence relation instead of structural+-- equality.+-----------------------------------------------------------------------------++-- [Note: Using INLINABLE]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- It is crucial to the performance that the functions specialize on the Ord+-- type when possible. GHC 7.0 and higher does this by itself when it sees th+-- unfolding of a function -- that is why all public functions are marked+-- INLINABLE (that exposes the unfolding).+++-- [Note: Using INLINE]+-- ~~~~~~~~~~~~~~~~~~~~+-- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.+-- We mark the functions that just navigate down the tree (lookup, insert,+-- delete and similar). That navigation code gets inlined and thus specialized+-- when possible. There is a price to pay -- code growth. The code INLINED is+-- therefore only the tree navigation, all the real work (rebalancing) is not+-- INLINED by using a NOINLINE.+--+-- All methods marked INLINE have to be nonrecursive -- a 'go' function doing+-- the real work is provided.+++-- [Note: Type of local 'go' function]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- If the local 'go' function uses an Ord class, it sometimes heap-allocates+-- the Ord dictionary when the 'go' function does not have explicit type.+-- In that case we give 'go' explicit type. But this slightly decrease+-- performance, as the resulting 'go' function can float out to top level.+++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- As opposed to IntSet, when 'go' function captures an argument, increased+-- heap-allocation can occur: sometimes in a polymorphic function, the 'go'+-- floats out of its enclosing function and then it heap-allocates the+-- dictionary and the argument. Maybe it floats out too late and strictness+-- analyzer cannot see that these could be passed on stack.+--+-- For example, change 'member' so that its local 'go' function is not passing+-- argument x and then look at the resulting code for hedgeInt.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of Set matters when considering performance.+-- Currently in GHC 7.0, when type has 2 constructors, a forward conditional+-- jump is made when successfully matching second constructor. Successful match+-- of first constructor results in the forward jump not taken.+-- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip+-- improves the benchmark by up to 10% on x86.++module Darcs.Data.Set.Base (+ -- * Set type+ Set(..) -- instance Eq,Ord,Show,Read,Data,Typeable++ -- * Operators+ , (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookupLT+ , lookupGT+ , lookupLE+ , lookupGE+ , isSubsetOf+ , isProperSubsetOf++ -- * Construction+ , empty+ , singleton+ , insert+ , delete++ -- * Combine+ , union+ , unions+ , difference+ , intersection++ -- * Filter+ , filter+ , partition+ , split+ , splitMember++ -- * Indexed+ , lookupIndex+ , findIndex+ , elemAt+ , deleteAt++ -- * Map+ , map+ , mapMonotonic++ -- * Folds+ , foldr+ , foldl+ -- ** Strict folds+ , foldr'+ , foldl'+ -- ** Legacy folds+ , fold++ -- * Min\/Max+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , maxView+ , minView++ -- * Conversion++ -- ** List+ , elems+ , toList+ , fromList++ -- ** Ordered list+ , toAscList+ , toDescList+ , fromAscList+ , fromDistinctAscList++ -- * Debugging+ , showTree+ , showTreeWith+ , valid++ -- Internals (for testing)+ , bin+ , balanced+ , join+ , merge+ ) where++import Prelude hiding (filter,foldl,foldr,null,map)+import qualified Data.List as List+import Data.Bits (shiftL, shiftR)+import Data.Monoid (Monoid(..))+import qualified Data.Foldable as Foldable+import Data.Typeable+import Control.DeepSeq (NFData(rnf))++import Darcs.Data.StrictPair++#if __GLASGOW_HASKELL__+import GHC.Exts ( build )+import Text.Read+import Data.Data+#endif++-- Use macros to define strictness of functions.+-- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.+-- We do not use BangPatterns, because they are not in any standard and we+-- want the compilers to be compiled by as many compilers as possible.+#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined+#define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined+#define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}+infixl 9 \\ --++-- | /O(n+m)/. See 'difference'.+(\\) :: Ord a => Set a -> Set a -> Set a+m1 \\ m2 = difference m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE (\\) #-}+#endif++{--------------------------------------------------------------------+ Sets are size balanced trees+--------------------------------------------------------------------}+-- | A set of values @a@.++-- See Note: Order of constructors+data Set a = Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a)+ | Tip++type Size = Int++instance Ord a => Monoid (Set a) where+ mempty = empty+ mappend = union+ mconcat = unions++instance Foldable.Foldable Set where+ fold Tip = mempty+ fold (Bin _ k l r) = Foldable.fold l `mappend` k `mappend` Foldable.fold r+ foldr = foldr+ foldl = foldl+ foldMap _ Tip = mempty+ foldMap f (Bin _ k l r) = Foldable.foldMap f l `mappend` f k `mappend` Foldable.foldMap f r++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+ A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance (Data a, Ord a) => Data (Set a) where+ gfoldl f z set = z fromList `f` (toList set)+ toConstr _ = fromListConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z fromList)+ _ -> error "gunfold"+ dataTypeOf _ = setDataType+ dataCast1 f = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr setDataType "fromList" [] Prefix++setDataType :: DataType+setDataType = mkDataType "Data.Set.Base.Set" [fromListConstr]++#endif++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | /O(1)/. Is this the empty set?+null :: Set a -> Bool+null Tip = True+null (Bin {}) = False+{-# INLINE null #-}++-- | /O(1)/. The number of elements in the set.+size :: Set a -> Int+size Tip = 0+size (Bin sz _ _ _) = sz+{-# INLINE size #-}++-- | /O(log n)/. Is the element in the set?+member :: Ord a => a -> Set a -> Bool+member = go+ where+ STRICT_1_OF_2(go)+ go _ Tip = False+ go x (Bin _ y l r) = case compare x y of+ LT -> go x l+ GT -> go x r+ EQ -> True+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE member #-}+#else+{-# INLINE member #-}+#endif++-- | /O(log n)/. Is the element not in the set?+notMember :: Ord a => a -> Set a -> Bool+notMember a t = not $ member a t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE notMember #-}+#else+{-# INLINE notMember #-}+#endif++-- | /O(log n)/. Find largest element smaller than the given one.+--+-- > lookupLT 3 (fromList [3, 5]) == Nothing+-- > lookupLT 5 (fromList [3, 5]) == Just 3+lookupLT :: Ord a => a -> Set a -> Maybe a+lookupLT = goNothing+ where+ STRICT_1_OF_2(goNothing)+ goNothing _ Tip = Nothing+ goNothing x (Bin _ y l r) | x <= y = goNothing x l+ | otherwise = goJust x y r++ STRICT_1_OF_3(goJust)+ goJust _ best Tip = Just best+ goJust x best (Bin _ y l r) | x <= y = goJust x best l+ | otherwise = goJust x y r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupLT #-}+#else+{-# INLINE lookupLT #-}+#endif++-- | /O(log n)/. Find smallest element greater than the given one.+--+-- > lookupGT 4 (fromList [3, 5]) == Just 5+-- > lookupGT 5 (fromList [3, 5]) == Nothing+lookupGT :: Ord a => a -> Set a -> Maybe a+lookupGT = goNothing+ where+ STRICT_1_OF_2(goNothing)+ goNothing _ Tip = Nothing+ goNothing x (Bin _ y l r) | x < y = goJust x y l+ | otherwise = goNothing x r++ STRICT_1_OF_3(goJust)+ goJust _ best Tip = Just best+ goJust x best (Bin _ y l r) | x < y = goJust x y l+ | otherwise = goJust x best r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupGT #-}+#else+{-# INLINE lookupGT #-}+#endif++-- | /O(log n)/. Find largest element smaller or equal to the given one.+--+-- > lookupLE 2 (fromList [3, 5]) == Nothing+-- > lookupLE 4 (fromList [3, 5]) == Just 3+-- > lookupLE 5 (fromList [3, 5]) == Just 5+lookupLE :: Ord a => a -> Set a -> Maybe a+lookupLE = goNothing+ where+ STRICT_1_OF_2(goNothing)+ goNothing _ Tip = Nothing+ goNothing x (Bin _ y l r) = case compare x y of LT -> goNothing x l+ EQ -> Just y+ GT -> goJust x y r++ STRICT_1_OF_3(goJust)+ goJust _ best Tip = Just best+ goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x best l+ EQ -> Just y+ GT -> goJust x y r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupLE #-}+#else+{-# INLINE lookupLE #-}+#endif++-- | /O(log n)/. Find smallest element greater or equal to the given one.+--+-- > lookupGE 3 (fromList [3, 5]) == Just 3+-- > lookupGE 4 (fromList [3, 5]) == Just 5+-- > lookupGE 6 (fromList [3, 5]) == Nothing+lookupGE :: Ord a => a -> Set a -> Maybe a+lookupGE = goNothing+ where+ STRICT_1_OF_2(goNothing)+ goNothing _ Tip = Nothing+ goNothing x (Bin _ y l r) = case compare x y of LT -> goJust x y l+ EQ -> Just y+ GT -> goNothing x r++ STRICT_1_OF_3(goJust)+ goJust _ best Tip = Just best+ goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x y l+ EQ -> Just y+ GT -> goJust x best r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupGE #-}+#else+{-# INLINE lookupGE #-}+#endif++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty set.+empty :: Set a+empty = Tip+{-# INLINE empty #-}++-- | /O(1)/. Create a singleton set.+singleton :: a -> Set a+singleton x = Bin 1 x Tip Tip+{-# INLINE singleton #-}++{--------------------------------------------------------------------+ Insertion, Deletion+--------------------------------------------------------------------}+-- | /O(log n)/. Insert an element in a set.+-- If the set already contains an element equal to the given value,+-- it is replaced with the new value.++-- See Note: Type of local 'go' function+insert :: Ord a => a -> Set a -> Set a+insert = go+ where+ go :: Ord a => a -> Set a -> Set a+ STRICT_1_OF_2(go)+ go x Tip = singleton x+ go x (Bin sz y l r) = case compare x y of+ LT -> balanceL y (go x l) r+ GT -> balanceR y l (go x r)+ EQ -> Bin sz x l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insert #-}+#else+{-# INLINE insert #-}+#endif++-- Insert an element to the set only if it is not in the set.+-- Used by `union`.++-- See Note: Type of local 'go' function+insertR :: Ord a => a -> Set a -> Set a+insertR = go+ where+ go :: Ord a => a -> Set a -> Set a+ STRICT_1_OF_2(go)+ go x Tip = singleton x+ go x t@(Bin _ y l r) = case compare x y of+ LT -> balanceL y (go x l) r+ GT -> balanceR y l (go x r)+ EQ -> t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertR #-}+#else+{-# INLINE insertR #-}+#endif++-- | /O(log n)/. Delete an element from a set.++-- See Note: Type of local 'go' function+delete :: Ord a => a -> Set a -> Set a+delete = go+ where+ go :: Ord a => a -> Set a -> Set a+ STRICT_1_OF_2(go)+ go _ Tip = Tip+ go x (Bin _ y l r) = case compare x y of+ LT -> balanceR y (go x l) r+ GT -> balanceL y l (go x r)+ EQ -> glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE delete #-}+#else+{-# INLINE delete #-}+#endif++{--------------------------------------------------------------------+ Subset+--------------------------------------------------------------------}+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).+isProperSubsetOf :: Ord a => Set a -> Set a -> Bool+isProperSubsetOf s1 s2+ = (size s1 < size s2) && (isSubsetOf s1 s2)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isProperSubsetOf #-}+#endif+++-- | /O(n+m)/. Is this a subset?+-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.+isSubsetOf :: Ord a => Set a -> Set a -> Bool+isSubsetOf t1 t2+ = (size t1 <= size t2) && (isSubsetOfX t1 t2)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isSubsetOf #-}+#endif++isSubsetOfX :: Ord a => Set a -> Set a -> Bool+isSubsetOfX Tip _ = True+isSubsetOfX _ Tip = False+isSubsetOfX (Bin _ x l r) t+ = found && isSubsetOfX l lt && isSubsetOfX r gt+ where+ (lt,found,gt) = splitMember x t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isSubsetOfX #-}+#endif+++{--------------------------------------------------------------------+ Minimal, Maximal+--------------------------------------------------------------------}+-- | /O(log n)/. The minimal element of a set.+findMin :: Set a -> a+findMin (Bin _ x Tip _) = x+findMin (Bin _ _ l _) = findMin l+findMin Tip = error "Set.findMin: empty set has no minimal element"++-- | /O(log n)/. The maximal element of a set.+findMax :: Set a -> a+findMax (Bin _ x _ Tip) = x+findMax (Bin _ _ _ r) = findMax r+findMax Tip = error "Set.findMax: empty set has no maximal element"++-- | /O(log n)/. Delete the minimal element. Returns an empty set if the set is empty.+deleteMin :: Set a -> Set a+deleteMin (Bin _ _ Tip r) = r+deleteMin (Bin _ x l r) = balanceR x (deleteMin l) r+deleteMin Tip = Tip++-- | /O(log n)/. Delete the maximal element. Returns an empty set if the set is empty.+deleteMax :: Set a -> Set a+deleteMax (Bin _ _ l Tip) = l+deleteMax (Bin _ x l r) = balanceL x l (deleteMax r)+deleteMax Tip = Tip++{--------------------------------------------------------------------+ Union.+--------------------------------------------------------------------}+-- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).+unions :: Ord a => [Set a] -> Set a+unions = foldlStrict union empty+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unions #-}+#endif++-- | /O(n+m)/. The union of two sets, preferring the first set when+-- equal elements are encountered.+-- The implementation uses the efficient /hedge-union/ algorithm.+union :: Ord a => Set a -> Set a -> Set a+union Tip t2 = t2+union t1 Tip = t1+union t1 t2 = hedgeUnion NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE union #-}+#endif++hedgeUnion :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a+hedgeUnion _ _ t1 Tip = t1+hedgeUnion blo bhi Tip (Bin _ x l r) = join x (filterGt blo l) (filterLt bhi r)+hedgeUnion _ _ t1 (Bin _ x Tip Tip) = insertR x t1 -- According to benchmarks, this special case increases+ -- performance up to 30%. It does not help in difference or intersection.+hedgeUnion blo bhi (Bin _ x l r) t2 = join x (hedgeUnion blo bmi l (trim blo bmi t2))+ (hedgeUnion bmi bhi r (trim bmi bhi t2))+ where bmi = JustS x+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeUnion #-}+#endif++{--------------------------------------------------------------------+ Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference of two sets.+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+difference :: Ord a => Set a -> Set a -> Set a+difference Tip _ = Tip+difference t1 Tip = t1+difference t1 t2 = hedgeDiff NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE difference #-}+#endif++hedgeDiff :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a+hedgeDiff _ _ Tip _ = Tip+hedgeDiff blo bhi (Bin _ x l r) Tip = join x (filterGt blo l) (filterLt bhi r)+hedgeDiff blo bhi t (Bin _ x l r) = merge (hedgeDiff blo bmi (trim blo bmi t) l)+ (hedgeDiff bmi bhi (trim bmi bhi t) r)+ where bmi = JustS x+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeDiff #-}+#endif++{--------------------------------------------------------------------+ Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. The intersection of two sets. The implementation uses an+-- efficient /hedge/ algorithm comparable with /hedge-union/. Elements of the+-- result come from the first set, so for example+--+-- > import qualified Data.Set as S+-- > data AB = A | B deriving Show+-- > instance Ord AB where compare _ _ = EQ+-- > instance Eq AB where _ == _ = True+-- > main = print (S.singleton A `S.intersection` S.singleton B,+-- > S.singleton B `S.intersection` S.singleton A)+--+-- prints @(fromList [A],fromList [B])@.+intersection :: Ord a => Set a -> Set a -> Set a+intersection Tip _ = Tip+intersection _ Tip = Tip+intersection t1 t2 = hedgeInt NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE intersection #-}+#endif++hedgeInt :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a+hedgeInt _ _ _ Tip = Tip+hedgeInt _ _ Tip _ = Tip+hedgeInt blo bhi (Bin _ x l r) t2 = let l' = hedgeInt blo bmi l (trim blo bmi t2)+ r' = hedgeInt bmi bhi r (trim bmi bhi t2)+ in if x `member` t2 then join x l' r' else merge l' r'+ where bmi = JustS x+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeInt #-}+#endif++{--------------------------------------------------------------------+ Filter and partition+--------------------------------------------------------------------}+-- | /O(n)/. Filter all elements that satisfy the predicate.+filter :: (a -> Bool) -> Set a -> Set a+filter _ Tip = Tip+filter p (Bin _ x l r)+ | p x = join x (filter p l) (filter p r)+ | otherwise = merge (filter p l) (filter p r)++-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy+-- the predicate and one with all elements that don't satisfy the predicate.+-- See also 'split'.+partition :: (a -> Bool) -> Set a -> (Set a,Set a)+partition p0 t0 = toPair $ go p0 t0+ where+ go _ Tip = (Tip :*: Tip)+ go p (Bin _ x l r) = case (go p l, go p r) of+ ((l1 :*: l2), (r1 :*: r2))+ | p x -> join x l1 r1 :*: merge l2 r2+ | otherwise -> merge l1 r1 :*: join x l2 r2++{----------------------------------------------------------------------+ Map+----------------------------------------------------------------------}++-- | /O(n*log n)/.+-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.+--+-- It's worth noting that the size of the result may be smaller if,+-- for some @(x,y)@, @x \/= y && f x == f y@++map :: Ord b => (a->b) -> Set a -> Set b+map f = fromList . List.map f . toList+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE map #-}+#endif++-- | /O(n)/. The+--+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is monotonic.+-- /The precondition is not checked./+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- > ==> mapMonotonic f s == map f s+-- > where ls = toList s++mapMonotonic :: (a->b) -> Set a -> Set b+mapMonotonic _ Tip = Tip+mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)++{--------------------------------------------------------------------+ Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold the elements in the set using the given right-associative+-- binary operator. This function is an equivalent of 'foldr' and is present+-- for compatibility only.+--+-- /Please note that fold will be deprecated in the future and removed./+fold :: (a -> b -> b) -> b -> Set a -> b+fold = foldr+{-# INLINE fold #-}++-- | /O(n)/. Fold the elements in the set using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.+--+-- For example,+--+-- > toAscList set = foldr (:) [] set+foldr :: (a -> b -> b) -> b -> Set a -> b+foldr f z = go z+ where+ go z' Tip = z'+ go z' (Bin _ x l r) = go (f x (go z' r)) l+{-# INLINE foldr #-}++-- | /O(n)/. A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> Set a -> b+foldr' f z = go z+ where+ STRICT_1_OF_2(go)+ go z' Tip = z'+ go z' (Bin _ x l r) = go (f x (go z' r)) l+{-# INLINE foldr' #-}++-- | /O(n)/. Fold the elements in the set using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.+--+-- For example,+--+-- > toDescList set = foldl (flip (:)) [] set+foldl :: (a -> b -> a) -> a -> Set b -> a+foldl f z = go z+ where+ go z' Tip = z'+ go z' (Bin _ x l r) = go (f (go z' l) x) r+{-# INLINE foldl #-}++-- | /O(n)/. A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> Set b -> a+foldl' f z = go z+ where+ STRICT_1_OF_2(go)+ go z' Tip = z'+ go z' (Bin _ x l r) = go (f (go z' l) x) r+{-# INLINE foldl' #-}++{--------------------------------------------------------------------+ List variations+--------------------------------------------------------------------}+-- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order.+-- Subject to list fusion.+elems :: Set a -> [a]+elems = toAscList++{--------------------------------------------------------------------+ Lists+--------------------------------------------------------------------}+-- | /O(n)/. Convert the set to a list of elements. Subject to list fusion.+toList :: Set a -> [a]+toList = toAscList++-- | /O(n)/. Convert the set to an ascending list of elements. Subject to list fusion.+toAscList :: Set a -> [a]+toAscList = foldr (:) []++-- | /O(n)/. Convert the set to a descending list of elements. Subject to list+-- fusion.+toDescList :: Set a -> [a]+toDescList = foldl (flip (:)) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.+-- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.+foldrFB :: (a -> b -> b) -> b -> Set a -> b+foldrFB = foldr+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> b -> a) -> a -> Set b -> a+foldlFB = foldl+{-# INLINE[0] foldlFB #-}++-- Inline elems and toList, so that we need to fuse only toAscList.+{-# INLINE elems #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded to{Asc,Desc}List calls back to+-- to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were used in+-- a list fusion, otherwise it would go away in phase 1), and let compiler do+-- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it+-- before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "Set.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-}+{-# RULES "Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-}+{-# RULES "Set.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}+{-# RULES "Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}+#endif++-- | /O(n*log n)/. Create a set from a list of elements.+--+-- If the elemens are ordered, linear-time implementation is used,+-- with the performance equal to 'fromDistinctAscList'.++-- For some reason, when 'singleton' is used in fromList or in+-- create, it is not inlined, so we inline it manually.+fromList :: Ord a => [a] -> Set a+fromList [] = Tip+fromList [x] = Bin 1 x Tip Tip+fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0+ | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0+ where+ not_ordered _ [] = False+ not_ordered x (y : _) = x >= y+ {-# INLINE not_ordered #-}++ fromList' t0 xs = foldlStrict ins t0 xs+ where ins t x = insert x t++ STRICT_1_OF_3(go)+ go _ t [] = t+ go _ t [x] = insertMax x t+ go s l xs@(x : xss) | not_ordered x xss = fromList' l xs+ | otherwise = case create s xss of+ (r, ys, []) -> go (s `shiftL` 1) (join x l r) ys+ (r, _, ys) -> fromList' (join x l r) ys++ -- The create is returning a triple (tree, xs, ys). Both xs and ys+ -- represent not yet processed elements and only one of them can be nonempty.+ -- If ys is nonempty, the keys in ys are not ordered with respect to tree+ -- and must be inserted using fromList'. Otherwise the keys have been+ -- ordered so far.+ STRICT_1_OF_2(create)+ create _ [] = (Tip, [], [])+ create s xs@(x : xss)+ | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss)+ else (Bin 1 x Tip Tip, xss, [])+ | otherwise = case create (s `shiftR` 1) xs of+ res@(_, [], _) -> res+ (l, [y], zs) -> (insertMax y l, [], zs)+ (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys)+ | otherwise -> case create (s `shiftR` 1) yss of+ (r, zs, ws) -> (join y l r, zs, ws)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromList #-}+#endif++{--------------------------------------------------------------------+ Building trees from ascending/descending lists can be done in linear time.++ Note that if [xs] is ascending that:+ fromAscList xs == fromList xs+--------------------------------------------------------------------}+-- | /O(n)/. Build a set from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+fromAscList :: Eq a => [a] -> Set a+fromAscList xs+ = fromDistinctAscList (combineEq xs)+ where+ -- [combineEq xs] combines equal elements with [const] in an ordered list [xs]+ combineEq xs'+ = case xs' of+ [] -> []+ [x] -> [x]+ (x:xx) -> combineEq' x xx++ combineEq' z [] = [z]+ combineEq' z (x:xs')+ | z==x = combineEq' z xs'+ | otherwise = z:combineEq' x xs'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromAscList #-}+#endif+++-- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.+-- /The precondition (input list is strictly ascending) is not checked./++-- For some reason, when 'singleton' is used in fromDistinctAscList or in+-- create, it is not inlined, so we inline it manually.+fromDistinctAscList :: [a] -> Set a+fromDistinctAscList [] = Tip+fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0+ where+ STRICT_1_OF_3(go)+ go _ t [] = t+ go s l (x : xs) = case create s xs of+ (r, ys) -> go (s `shiftL` 1) (join x l r) ys++ STRICT_1_OF_2(create)+ create _ [] = (Tip, [])+ create s xs@(x : xs')+ | s == 1 = (Bin 1 x Tip Tip, xs')+ | otherwise = case create (s `shiftR` 1) xs of+ res@(_, []) -> res+ (l, y:ys) -> case create (s `shiftR` 1) ys of+ (r, zs) -> (join y l r, zs)++{--------------------------------------------------------------------+ Eq converts the set to a list. In a lazy setting, this+ actually seems one of the faster methods to compare two trees+ and it is certainly the simplest :-)+--------------------------------------------------------------------}+instance Eq a => Eq (Set a) where+ t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)++{--------------------------------------------------------------------+ Ord+--------------------------------------------------------------------}++instance Ord a => Ord (Set a) where+ compare s1 s2 = compare (toAscList s1) (toAscList s2)++{--------------------------------------------------------------------+ Show+--------------------------------------------------------------------}+instance Show a => Show (Set a) where+ showsPrec p xs = showParen (p > 10) $+ showString "fromList " . shows (toList xs)++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance (Read a, Ord a) => Read (Set a) where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++{--------------------------------------------------------------------+ Typeable/Data+--------------------------------------------------------------------}++#include "Typeable.h"+INSTANCE_TYPEABLE1(Set,setTc,"Set")++{--------------------------------------------------------------------+ NFData+--------------------------------------------------------------------}++instance NFData a => NFData (Set a) where+ rnf Tip = ()+ rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r++{--------------------------------------------------------------------+ Utility functions that return sub-ranges of the original+ tree. Some functions take a `Maybe value` as an argument to+ allow comparisons against infinite values. These are called `blow`+ (Nothing is -\infty) and `bhigh` (here Nothing is +\infty).+ We use MaybeS value, which is a Maybe strict in the Just case.++ [trim blow bhigh t] A tree that is either empty or where [x > blow]+ and [x < bhigh] for the value [x] of the root.+ [filterGt blow t] A tree where for all values [k]. [k > blow]+ [filterLt bhigh t] A tree where for all values [k]. [k < bhigh]++ [split k t] Returns two trees [l] and [r] where all values+ in [l] are <[k] and all keys in [r] are >[k].+ [splitMember k t] Just like [split] but also returns whether [k]+ was found in the tree.+--------------------------------------------------------------------}++data MaybeS a = NothingS | JustS !a++{--------------------------------------------------------------------+ [trim blo bhi t] trims away all subtrees that surely contain no+ values between the range [blo] to [bhi]. The returned tree is either+ empty or the key of the root is between @blo@ and @bhi@.+--------------------------------------------------------------------}+trim :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a+trim NothingS NothingS t = t+trim (JustS lx) NothingS t = greater lx t where greater lo (Bin _ x _ r) | x <= lo = greater lo r+ greater _ t' = t'+trim NothingS (JustS hx) t = lesser hx t where lesser hi (Bin _ x l _) | x >= hi = lesser hi l+ lesser _ t' = t'+trim (JustS lx) (JustS hx) t = middle lx hx t where middle lo hi (Bin _ x _ r) | x <= lo = middle lo hi r+ middle lo hi (Bin _ x l _) | x >= hi = middle lo hi l+ middle _ _ t' = t'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE trim #-}+#endif++{--------------------------------------------------------------------+ [filterGt b t] filter all values >[b] from tree [t]+ [filterLt b t] filter all values <[b] from tree [t]+--------------------------------------------------------------------}+filterGt :: Ord a => MaybeS a -> Set a -> Set a+filterGt NothingS t = t+filterGt (JustS b) t = filter' b t+ where filter' _ Tip = Tip+ filter' b' (Bin _ x l r) =+ case compare b' x of LT -> join x (filter' b' l) r+ EQ -> r+ GT -> filter' b' r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE filterGt #-}+#endif++filterLt :: Ord a => MaybeS a -> Set a -> Set a+filterLt NothingS t = t+filterLt (JustS b) t = filter' b t+ where filter' _ Tip = Tip+ filter' b' (Bin _ x l r) =+ case compare x b' of LT -> join x l (filter' b' r)+ EQ -> l+ GT -> filter' b' l+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE filterLt #-}+#endif++{--------------------------------------------------------------------+ Split+--------------------------------------------------------------------}+-- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@+-- comprises the elements of @set@ greater than @x@.+split :: Ord a => a -> Set a -> (Set a,Set a)+split x0 t0 = toPair $ go x0 t0+ where+ go _ Tip = (Tip :*: Tip)+ go x (Bin _ y l r)+ = case compare x y of+ LT -> let (lt :*: gt) = go x l in (lt :*: join y gt r)+ GT -> let (lt :*: gt) = go x r in (join y l lt :*: gt)+ EQ -> (l :*: r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE split #-}+#endif++-- | /O(log n)/. Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a)+splitMember _ Tip = (Tip, False, Tip)+splitMember x (Bin _ y l r)+ = case compare x y of+ LT -> let (lt, found, gt) = splitMember x l+ gt' = join y gt r+ in gt' `seq` (lt, found, gt')+ GT -> let (lt, found, gt) = splitMember x r+ lt' = join y l lt+ in lt' `seq` (lt', found, gt)+ EQ -> (l, True, r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE splitMember #-}+#endif++{--------------------------------------------------------------------+ Indexing+--------------------------------------------------------------------}++-- | /O(log n)/. Return the /index/ of an element, which is its zero-based+-- index in the sorted sequence of elements. The index is a number from /0/ up+-- to, but not including, the 'size' of the set. Calls 'error' when the element+-- is not a 'member' of the set.+--+-- > findIndex 2 (fromList [5,3]) Error: element is not in the set+-- > findIndex 3 (fromList [5,3]) == 0+-- > findIndex 5 (fromList [5,3]) == 1+-- > findIndex 6 (fromList [5,3]) Error: element is not in the set++-- See Note: Type of local 'go' function+findIndex :: Ord a => a -> Set a -> Int+findIndex = go 0+ where+ go :: Ord a => Int -> a -> Set a -> Int+ STRICT_1_OF_3(go)+ STRICT_2_OF_3(go)+ go _ _ Tip = error "Set.findIndex: element is not in the set"+ go idx x (Bin _ kx l r) = case compare x kx of+ LT -> go idx x l+ GT -> go (idx + size l + 1) x r+ EQ -> idx + size l+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE findIndex #-}+#endif++-- | /O(log n)/. Lookup the /index/ of an element, which is its zero-based index in+-- the sorted sequence of elements. The index is a number from /0/ up to, but not+-- including, the 'size' of the set.+--+-- > isJust (lookupIndex 2 (fromList [5,3])) == False+-- > fromJust (lookupIndex 3 (fromList [5,3])) == 0+-- > fromJust (lookupIndex 5 (fromList [5,3])) == 1+-- > isJust (lookupIndex 6 (fromList [5,3])) == False++-- See Note: Type of local 'go' function+lookupIndex :: Ord a => a -> Set a -> Maybe Int+lookupIndex = go 0+ where+ go :: Ord a => Int -> a -> Set a -> Maybe Int+ STRICT_1_OF_3(go)+ STRICT_2_OF_3(go)+ go _ _ Tip = Nothing+ go idx x (Bin _ kx l r) = case compare x kx of+ LT -> go idx x l+ GT -> go (idx + size l + 1) x r+ EQ -> Just $! idx + size l+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupIndex #-}+#endif++-- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based+-- index in the sorted sequence of elements. If the /index/ is out of range (less+-- than zero, greater or equal to 'size' of the set), 'error' is called.+--+-- > elemAt 0 (fromList [5,3]) == 3+-- > elemAt 1 (fromList [5,3]) == 5+-- > elemAt 2 (fromList [5,3]) Error: index out of range++elemAt :: Int -> Set a -> a+STRICT_1_OF_2(elemAt)+elemAt _ Tip = error "Set.elemAt: index out of range"+elemAt i (Bin _ x l r)+ = case compare i sizeL of+ LT -> elemAt i l+ GT -> elemAt (i-sizeL-1) r+ EQ -> x+ where+ sizeL = size l++-- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in+-- the sorted sequence of elements. If the /index/ is out of range (less than zero,+-- greater or equal to 'size' of the set), 'error' is called.+--+-- > deleteAt 0 (fromList [5,3]) == singleton 5+-- > deleteAt 1 (fromList [5,3]) == singleton 3+-- > deleteAt 2 (fromList [5,3]) Error: index out of range+-- > deleteAt (-1) (fromList [5,3]) Error: index out of range++deleteAt :: Int -> Set a -> Set a+deleteAt i t = i `seq`+ case t of+ Tip -> error "Set.deleteAt: index out of range"+ Bin _ x l r -> case compare i sizeL of+ LT -> balanceR x (deleteAt i l) r+ GT -> balanceL x l (deleteAt (i-sizeL-1) r)+ EQ -> glue l r+ where+ sizeL = size l+++{--------------------------------------------------------------------+ Utility functions that maintain the balance properties of the tree.+ All constructors assume that all values in [l] < [x] and all values+ in [r] > [x], and that [l] and [r] are valid trees.++ In order of sophistication:+ [Bin sz x l r] The type constructor.+ [bin x l r] Maintains the correct size, assumes that both [l]+ and [r] are balanced with respect to each other.+ [balance x l r] Restores the balance and size.+ Assumes that the original tree was balanced and+ that [l] or [r] has changed by at most one element.+ [join x l r] Restores balance and size.++ Furthermore, we can construct a new tree from two trees. Both operations+ assume that all values in [l] < all values in [r] and that [l] and [r]+ are valid:+ [glue l r] Glues [l] and [r] together. Assumes that [l] and+ [r] are already balanced with respect to each other.+ [merge l r] Merges two trees and restores balance.++ Note: in contrast to Adam's paper, we use (<=) comparisons instead+ of (<) comparisons in [join], [merge] and [balance].+ Quickcheck (on [difference]) showed that this was necessary in order+ to maintain the invariants. It is quite unsatisfactory that I haven't+ been able to find out why this is actually the case! Fortunately, it+ doesn't hurt to be a bit more conservative.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+ Join+--------------------------------------------------------------------}+join :: a -> Set a -> Set a -> Set a+join x Tip r = insertMin x r+join x l Tip = insertMax x l+join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)+ | delta*sizeL < sizeR = balanceL z (join x l lz) rz+ | delta*sizeR < sizeL = balanceR y ly (join x ry r)+ | otherwise = bin x l r+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: a -> Set a -> Set a+insertMax x t+ = case t of+ Tip -> singleton x+ Bin _ y l r+ -> balanceR y l (insertMax x r)++insertMin x t+ = case t of+ Tip -> singleton x+ Bin _ y l r+ -> balanceL y (insertMin x l) r++{--------------------------------------------------------------------+ [merge l r]: merges two trees.+--------------------------------------------------------------------}+merge :: Set a -> Set a -> Set a+merge Tip r = r+merge l Tip = l+merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)+ | delta*sizeL < sizeR = balanceL y (merge l ly) ry+ | delta*sizeR < sizeL = balanceR x lx (merge rx r)+ | otherwise = glue l r++{--------------------------------------------------------------------+ [glue l r]: glues two trees together.+ Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: Set a -> Set a -> Set a+glue Tip r = r+glue l Tip = l+glue l r+ | size l > size r = let (m,l') = deleteFindMax l in balanceR m l' r+ | otherwise = let (m,r') = deleteFindMin r in balanceL m l r'++-- | /O(log n)/. Delete and find the minimal element.+--+-- > deleteFindMin set = (findMin set, deleteMin set)++deleteFindMin :: Set a -> (a,Set a)+deleteFindMin t+ = case t of+ Bin _ x Tip r -> (x,r)+ Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balanceR x l' r)+ Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)++-- | /O(log n)/. Delete and find the maximal element.+--+-- > deleteFindMax set = (findMax set, deleteMax set)+deleteFindMax :: Set a -> (a,Set a)+deleteFindMax t+ = case t of+ Bin _ x l Tip -> (x,l)+ Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balanceL x l r')+ Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)++-- | /O(log n)/. Retrieves the minimal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+minView :: Set a -> Maybe (a, Set a)+minView Tip = Nothing+minView x = Just (deleteFindMin x)++-- | /O(log n)/. Retrieves the maximal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+maxView :: Set a -> Maybe (a, Set a)+maxView Tip = Nothing+maxView x = Just (deleteFindMax x)++{--------------------------------------------------------------------+ [balance x l r] balances two trees with value x.+ The sizes of the trees should balance after decreasing the+ size of one of them. (a rotation).++ [delta] is the maximal relative difference between the sizes of+ two trees, it corresponds with the [w] in Adams' paper.+ [ratio] is the ratio between an outer and inner sibling of the+ heavier subtree in an unbalanced setting. It determines+ whether a double or single rotation should be performed+ to restore balance. It is correspondes with the inverse+ of $\alpha$ in Adam's article.++ Note that according to the Adam's paper:+ - [delta] should be larger than 4.646 with a [ratio] of 2.+ - [delta] should be larger than 3.745 with a [ratio] of 1.534.++ But the Adam's paper is errorneous:+ - it can be proved that for delta=2 and delta>=5 there does+ not exist any ratio that would work+ - delta=4.5 and ratio=2 does not work++ That leaves two reasonable variants, delta=3 and delta=4,+ both with ratio=2.++ - A lower [delta] leads to a more 'perfectly' balanced tree.+ - A higher [delta] performs less rebalancing.++ In the benchmarks, delta=3 is faster on insert operations,+ and delta=4 has slightly better deletes. As the insert speedup+ is larger, we currently use delta=3.++--------------------------------------------------------------------}+delta,ratio :: Int+delta = 3+ratio = 2++-- The balance function is equivalent to the following:+--+-- balance :: a -> Set a -> Set a -> Set a+-- balance x l r+-- | sizeL + sizeR <= 1 = Bin sizeX x l r+-- | sizeR > delta*sizeL = rotateL x l r+-- | sizeL > delta*sizeR = rotateR x l r+-- | otherwise = Bin sizeX x l r+-- where+-- sizeL = size l+-- sizeR = size r+-- sizeX = sizeL + sizeR + 1+--+-- rotateL :: a -> Set a -> Set a -> Set a+-- rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r+-- | otherwise = doubleL x l r+-- rotateR :: a -> Set a -> Set a -> Set a+-- rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r+-- | otherwise = doubleR x l r+--+-- singleL, singleR :: a -> Set a -> Set a -> Set a+-- singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3+-- singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)+--+-- doubleL, doubleR :: a -> Set a -> Set a -> Set a+-- doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)+-- doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)+--+-- It is only written in such a way that every node is pattern-matched only once.+--+-- Only balanceL and balanceR are needed at the moment, so balance is not here anymore.+-- In case it is needed, it can be found in Data.Map.++-- Functions balanceL and balanceR are specialised versions of balance.+-- balanceL only checks whether the left subtree is too big,+-- balanceR only checks whether the right subtree is too big.++-- balanceL is called when left subtree might have been inserted to or when+-- right subtree might have been deleted from.+balanceL :: a -> Set a -> Set a -> Set a+balanceL x l r = case r of+ Tip -> case l of+ Tip -> Bin 1 x Tip Tip+ (Bin _ _ Tip Tip) -> Bin 2 x l Tip+ (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)+ (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)+ (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr))+ | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)+ | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)++ (Bin rs _ _ _) -> case l of+ Tip -> Bin (1+rs) x Tip r++ (Bin ls lx ll lr)+ | ls > delta*rs -> case (ll, lr) of+ (Bin lls _ _ _, Bin lrs lrx lrl lrr)+ | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)+ | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)+ (_, _) -> error "Failure in Data.Map.balanceL"+ | otherwise -> Bin (1+ls+rs) x l r+{-# NOINLINE balanceL #-}++-- balanceR is called when right subtree might have been inserted to or when+-- left subtree might have been deleted from.+balanceR :: a -> Set a -> Set a -> Set a+balanceR x l r = case l of+ Tip -> case r of+ Tip -> Bin 1 x Tip Tip+ (Bin _ _ Tip Tip) -> Bin 2 x Tip r+ (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr+ (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)+ (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _))+ | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr+ | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)++ (Bin ls _ _ _) -> case r of+ Tip -> Bin (1+ls) x l Tip++ (Bin rs rx rl rr)+ | rs > delta*ls -> case (rl, rr) of+ (Bin rls rlx rll rlr, Bin rrs _ _ _)+ | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr+ | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)+ (_, _) -> error "Failure in Data.Map.balanceR"+ | otherwise -> Bin (1+ls+rs) x l r+{-# NOINLINE balanceR #-}++{--------------------------------------------------------------------+ The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin :: a -> Set a -> Set a -> Set a+bin x l r+ = Bin (size l + size r + 1) x l r+{-# INLINE bin #-}+++{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}+foldlStrict :: (a -> b -> a) -> a -> [b] -> a+foldlStrict f = go+ where+ go z [] = z+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs+{-# INLINE foldlStrict #-}++{--------------------------------------------------------------------+ Debugging+--------------------------------------------------------------------}+-- | /O(n)/. Show the tree that implements the set. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => Set a -> String+showTree s+ = showTreeWith True False s+++{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows+ the tree that implements the set. If @hang@ is+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.++> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]+> 4+> +--2+> | +--1+> | +--3+> +--5+>+> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]+> 4+> |+> +--2+> | |+> | +--1+> | |+> | +--3+> |+> +--5+>+> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]+> +--5+> |+> 4+> |+> | +--3+> | |+> +--2+> |+> +--1++-}+showTreeWith :: Show a => Bool -> Bool -> Set a -> String+showTreeWith hang wide t+ | hang = (showsTreeHang wide [] t) ""+ | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS+showsTree wide lbars rbars t+ = case t of+ Tip -> showsBars lbars . showString "|\n"+ Bin _ x Tip Tip+ -> showsBars lbars . shows x . showString "\n"+ Bin _ x l r+ -> showsTree wide (withBar rbars) (withEmpty rbars) r .+ showWide wide rbars .+ showsBars lbars . shows x . showString "\n" .+ showWide wide lbars .+ showsTree wide (withEmpty lbars) (withBar lbars) l++showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS+showsTreeHang wide bars t+ = case t of+ Tip -> showsBars bars . showString "|\n"+ Bin _ x Tip Tip+ -> showsBars bars . shows x . showString "\n"+ Bin _ x l r+ -> showsBars bars . shows x . showString "\n" .+ showWide wide bars .+ showsTreeHang wide (withBar bars) l .+ showWide wide bars .+ showsTreeHang wide (withEmpty bars) r++showWide :: Bool -> [String] -> String -> String+showWide wide bars+ | wide = showString (concat (reverse bars)) . showString "|\n"+ | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+ = case bars of+ [] -> id+ _ -> showString (concat (reverse (tail bars))) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars = "| ":bars+withEmpty bars = " ":bars++{--------------------------------------------------------------------+ Assertions+--------------------------------------------------------------------}+-- | /O(n)/. Test if the internal set structure is valid.+valid :: Ord a => Set a -> Bool+valid t+ = balanced t && ordered t && validsize t++ordered :: Ord a => Set a -> Bool+ordered t+ = bounded (const True) (const True) t+ where+ bounded lo hi t'+ = case t' of+ Tip -> True+ Bin _ x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r++balanced :: Set a -> Bool+balanced t+ = case t of+ Tip -> True+ Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&+ balanced l && balanced r++validsize :: Set a -> Bool+validsize t+ = (realsize t == Just (size t))+ where+ realsize t'+ = case t' of+ Tip -> Just 0+ Bin sz _ l r -> case (realsize l,realsize r) of+ (Just n,Just m) | n+m+1 == sz -> Just sz+ _ -> Nothing
+ containers-0.5.2.1/Darcs/Data/StrictPair.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}+#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Trustworthy #-}+#endif+module Darcs.Data.StrictPair (StrictPair(..), toPair) where++-- | Same as regular Haskell pairs, but (x :*: _|_) = (_|_ :*: y) =+-- _|_+data StrictPair a b = !a :*: !b++toPair :: StrictPair a b -> (a, b)+toPair (x :*: y) = (x, y)+{-# INLINE toPair #-}
contrib/_darcs.zsh view
@@ -29,8 +29,7 @@ ;; # Otherwise, let's ask darcs for all possible options *)- _wanted args expl 'arg for darcs command' \- compadd -- $( darcs ${words[2]} --list-option )+ _arguments '*: :($(words[$CURRENT]="--list-options" && $words))' ;; esac fi
darcs.cabal view
@@ -1,5 +1,5 @@ Name: darcs-version: 2.8.5+version: 2.10.0 License: GPL License-file: COPYING Author: David Roundy <droundy@darcs.net>, <darcs-devel@darcs.net>@@ -33,11 +33,11 @@ Homepage: http://darcs.net/ Build-Type: Custom-Cabal-Version: >= 1.8+Cabal-Version: >= 1.10 extra-source-files: -- C headers- src/*.h src/Crypt/sha2.h+ src/*.h src/win32/send_email.h src/win32/sys/mman.h -- The contrib directory would make a sensible 'darcs-contrib' package@@ -45,11 +45,6 @@ contrib/cygwin-wrapper.bash, contrib/update_roundup.pl, contrib/upload.cgi, contrib/darcs-errors.hlint, - -- documentation files- doc/src/best_practices.tex, doc/src/building_darcs.tex, doc/src/configuring_darcs.tex,- doc/src/features.tex, doc/src/gpl.tex, doc/src/darcs.tex- doc/darcs.css- README, NEWS -- release data@@ -67,6 +62,10 @@ tests/data/example_binary.png tests/README.test_maintainers.txt + -- hashed-storage+ hashed-storage/LICENSE+ hashed-storage/testdata.zip+ GNUmakefile source-repository head@@ -76,13 +75,15 @@ flag curl description: Use libcurl for HTTP support. +-- in future this could extend to any other external libraries,+-- e.g. libiconv +flag pkgconfig+ description: Use pkgconfig to configure libcurl+ default: False+ flag http description: Use the pure Haskell HTTP package for HTTP support. -flag network-uri- description: Get Network.URI from the network-uri package- default: True- flag static description: Build static binary default: False@@ -94,26 +95,15 @@ description: Use threading and SMP support. default: True -flag library- description: Build darcs library- default: True- flag executable description: Build darcs executable default: True -flag color- description: Use ansi color escapes.--flag mmap- description: Compile with mmap support.- flag hpc default: False -flag test+flag rts default: False- description: Build test harness -- We need optimizations by default, regardless of what Hackage says flag optimize@@ -124,14 +114,12 @@ default: False description: Build with warnings-as-errors --- If base >= 4.4 is used, the standard directory functions--- do Unicode translation. Use a flag so we can--- detect this situation and use a workaround.-flag force-char8-encoding+-- To allow building with containers < 0.5, we keep a local copy of this+-- module.+flag use-local-data-map-strict default: False- description: Allow base 4.5 or above on Unix. base 4.4 introduces a change in- the behaviour of filenames that requires API calls in- base 4.5 to workaround. So base 4.4 is not supported at all.+ description: Support containers < 0.5, by using a local copy of the+ Data.Map.Strict module from containers 0.5. -- 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@@ -140,107 +128,56 @@ Description: Explicitly link against the libiconv library. Default: False +flag hashed-storage-diff+ default: False +-- with time>=1.5 (needed with GHC 7.10) we get defaultTimeLocale from time:Data.Time+-- with time<1.5 we get defaultTimeLocale from old-locale:System.Locale+flag use-time-1point5+ default: False+ -- ---------------------------------------------------------------------- -- darcs library -- ---------------------------------------------------------------------- Library- if !flag(library)- buildable: False- else- buildable: True+ build-tools: ghc >= 7.4 && < 7.12 - build-tools: ghc >= 6.10 && < 7.10+ default-language: Haskell2010 hs-source-dirs: src include-dirs: src - cpp-options: -DGADT_WITNESSES=1-- exposed-modules: CommandLine- Crypt.SHA256- Darcs.Annotate- Darcs.ArgumentDefaults- Darcs.Arguments- Darcs.Bug- Darcs.ColorPrinter- Darcs.Commands- Darcs.Commands.Add- Darcs.Commands.AmendRecord- Darcs.Commands.Annotate- Darcs.Commands.Apply- Darcs.CommandsAux- Darcs.Commands.Changes- Darcs.Commands.Check- Darcs.Commands.Convert- Darcs.Commands.Diff- Darcs.Commands.Dist- Darcs.Commands.Get- Darcs.Commands.GZCRCs- Darcs.Commands.Help- Darcs.Commands.Init- Darcs.Commands.MarkConflicts- Darcs.Commands.Move- Darcs.Commands.Optimize- Darcs.Commands.Pull- Darcs.Commands.Push- Darcs.Commands.Put- Darcs.Commands.Record- Darcs.Commands.Remove- Darcs.Commands.Replace- Darcs.Commands.Revert- Darcs.Commands.Rollback- Darcs.Commands.Send- Darcs.Commands.SetPref- Darcs.Commands.Show- Darcs.Commands.ShowAuthors- Darcs.Commands.ShowBug- Darcs.Commands.ShowContents- Darcs.Commands.ShowFiles- Darcs.Commands.ShowIndex- Darcs.Commands.ShowRepo- Darcs.Commands.ShowTags- Darcs.Commands.Tag- Darcs.Commands.Test- Darcs.Commands.TrackDown- Darcs.Commands.TransferMode- Darcs.Commands.Util- Darcs.Commands.Unrecord- Darcs.Commands.Unrevert- Darcs.Commands.WhatsNew- Darcs.Compat- Darcs.Diff- Darcs.Email- Darcs.External- Darcs.Flags- Darcs.Global- Darcs.IO- Darcs.Lock- Darcs.Match- Darcs.MonadProgress+ exposed-modules: Darcs.Patch+ Darcs.Patch.Annotate Darcs.Patch.Apply Darcs.Patch.ApplyMonad+ Darcs.Patch.ApplyPatches Darcs.Patch.Bracketed Darcs.Patch.Bracketed.Instances Darcs.Patch.Bundle Darcs.Patch.Choices Darcs.Patch.Commute+ Darcs.Patch.CommuteFn Darcs.Patch.Conflict Darcs.Patch.ConflictMarking+ Darcs.Patch.Debug Darcs.Patch.Depends Darcs.Patch.Dummy Darcs.Patch.Effect- Darcs.Patch.FileName Darcs.Patch.FileHunk+ Darcs.Patch.Index.Monad+ Darcs.Patch.Index.Types Darcs.Patch.Format Darcs.Patch.Info Darcs.Patch.Inspect Darcs.Patch.Invert Darcs.Patch.Match- Darcs.Patch.MatchData+ Darcs.Patch.Matchable+ Darcs.Patch.MaybeInternal Darcs.Patch.Merge+ Darcs.Patch.MonadProgress Darcs.Patch.Named Darcs.Patch.OldDate Darcs.Patch.PatchInfoAnd@@ -266,7 +203,14 @@ Darcs.Patch.Prim.V3.Details Darcs.Patch.Prim.V3.Read Darcs.Patch.Prim.V3.Show+ Darcs.Patch.Progress Darcs.Patch.Read+ Darcs.Patch.Rebase+ Darcs.Patch.Rebase.Fixup+ Darcs.Patch.Rebase.Name+ Darcs.Patch.Rebase.NameHack+ Darcs.Patch.Rebase.Recontext+ Darcs.Patch.Rebase.Viewing Darcs.Patch.ReadMonads Darcs.Patch.RegChars Darcs.Patch.Repair@@ -278,6 +222,7 @@ Darcs.Patch.SummaryData Darcs.Patch.TokenReplace Darcs.Patch.TouchesFiles+ Darcs.Patch.Type Darcs.Patch.Viewing Darcs.Patch.V1 Darcs.Patch.V1.Apply@@ -289,64 +234,148 @@ Darcs.Patch.V2 Darcs.Patch.V2.Non Darcs.Patch.V2.Real- Darcs.PrintPatch- Darcs.ProgressPatches- Darcs.RemoteApply- Darcs.RepoPath+ Darcs.Patch.Witnesses.Eq+ Darcs.Patch.Witnesses.Ordered+ Darcs.Patch.Witnesses.Sealed+ Darcs.Patch.Witnesses.Show+ Darcs.Patch.Witnesses.Unsafe+ Darcs.Patch.Witnesses.WZipper Darcs.Repository Darcs.Repository.ApplyPatches Darcs.Repository.Cache+ Darcs.Repository.PatchIndex+ Darcs.Repository.Compat+ Darcs.Repository.Diff+ Darcs.Repository.External+ Darcs.Repository.Flags Darcs.Repository.Format Darcs.Repository.HashedIO Darcs.Repository.HashedRepo Darcs.Repository.Internal+ Darcs.Repository.Job+ Darcs.Repository.Lock Darcs.Repository.LowLevel Darcs.Repository.Merge Darcs.Repository.InternalTypes+ Darcs.Repository.Match Darcs.Repository.Motd Darcs.Repository.Old Darcs.Repository.Prefs+ Darcs.Repository.Rebase Darcs.Repository.Repair+ Darcs.Repository.Read+ Darcs.Repository.Resolution+ Darcs.Repository.Ssh Darcs.Repository.State- Darcs.Resolution- Darcs.RunCommand- Darcs.SelectChanges- Darcs.SignalHandler- Darcs.Ssh- Darcs.Test- Darcs.TheCommands- Darcs.URL- Darcs.Utils- Darcs.Witnesses.Eq- Darcs.Witnesses.Ordered- Darcs.Witnesses.Sealed- Darcs.Witnesses.Show- Darcs.Witnesses.Unsafe- Darcs.Witnesses.WZipper- DateMatcher- Encoding- English- Exec- ByteStringUtils- IsoDate- Lcs- Printer- Progress- Ratified- SHA1- URL- URL.Request- URL.HTTP- Workaround+ Darcs.Repository.Test+ Darcs.Repository.Util+ Darcs.UI.ApplyPatches+ Darcs.UI.Commands+ Darcs.UI.Commands.Add+ Darcs.UI.Commands.Amend+ Darcs.UI.Commands.Annotate+ Darcs.UI.Commands.Apply+ Darcs.UI.CommandsAux+ Darcs.UI.Commands.Clone+ Darcs.UI.Commands.Convert+ Darcs.UI.Commands.Diff+ Darcs.UI.Commands.Dist+ Darcs.UI.Commands.GZCRCs+ Darcs.UI.Commands.Help+ Darcs.UI.Commands.Init+ Darcs.UI.Commands.Log+ Darcs.UI.Commands.MarkConflicts+ Darcs.UI.Commands.Move+ Darcs.UI.Commands.Optimize+ Darcs.UI.Commands.Pull+ Darcs.UI.Commands.Push+ Darcs.UI.Commands.Rebase+ Darcs.UI.Commands.Record+ Darcs.UI.Commands.Remove+ Darcs.UI.Commands.Repair+ Darcs.UI.Commands.Replace+ Darcs.UI.Commands.Revert+ Darcs.UI.Commands.Rollback+ Darcs.UI.Commands.Send+ Darcs.UI.Commands.SetPref+ Darcs.UI.Commands.Show+ Darcs.UI.Commands.ShowAuthors+ Darcs.UI.Commands.ShowBug+ Darcs.UI.Commands.ShowContents+ Darcs.UI.Commands.ShowFiles+ Darcs.UI.Commands.ShowIndex+ Darcs.UI.Commands.ShowPatchIndex+ Darcs.UI.Commands.ShowRepo+ Darcs.UI.Commands.ShowTags+ Darcs.UI.Commands.Tag+ Darcs.UI.Commands.Test+ Darcs.UI.Commands.TransferMode+ Darcs.UI.Commands.Util+ Darcs.UI.Commands.Util.Tree+ Darcs.UI.Commands.Unrecord+ Darcs.UI.Commands.Unrevert+ Darcs.UI.Commands.WhatsNew+ Darcs.UI.Email+ Darcs.UI.External+ Darcs.UI.Defaults+ Darcs.UI.Flags+ Darcs.UI.Options+ Darcs.UI.Options.All+ Darcs.UI.Options.Core+ Darcs.UI.Options.Flags+ Darcs.UI.Options.Iso+ Darcs.UI.Options.Markdown+ Darcs.UI.Options.Matching+ Darcs.UI.Options.Util+ Darcs.UI.PrintPatch+ Darcs.UI.RemoteApply+ Darcs.UI.RunCommand+ Darcs.UI.SelectChanges+ Darcs.UI.TheCommands+ Darcs.UI.Usage+ Darcs.UI.Message.Send+ Darcs.Util.AtExit+ Darcs.Util.Bug+ Darcs.Util.ByteString+ Darcs.Util.CommandLine+ Darcs.Util.Crypt.SHA1+ Darcs.Util.Crypt.SHA256+ Darcs.Util.DateMatcher+ Darcs.Util.DateTime+ Darcs.Util.Diff+ Darcs.Util.Diff.Myers+ Darcs.Util.Diff.Patience+ Darcs.Util.Download+ Darcs.Util.Download.Request+ Darcs.Util.Download.HTTP+ Darcs.Util.English+ Darcs.Util.Environment+ Darcs.Util.Exception+ Darcs.Util.Exec+ Darcs.Util.File+ Darcs.Util.Global+ Darcs.Util.IsoDate+ Darcs.Util.Path+ Darcs.Util.Printer+ Darcs.Util.Printer.Color+ Darcs.Util.Progress+ Darcs.Util.Prompt+ Darcs.Util.Ratified+ Darcs.Util.Show+ Darcs.Util.SignalHandler+ Darcs.Util.Ssh+ Darcs.Util.Text+ Darcs.Util.URL+ Darcs.Util.Workaround other-modules: Version- URL.Curl+ Darcs.Util.Download.Curl+ Darcs.Util.Encoding c-sources: src/atomic_create.c src/fpstring.c src/maybe_relink.c src/umask.c- src/Crypt/sha2.c src/system_encoding.c cc-options: -D_REENTRANT@@ -354,60 +383,78 @@ if os(windows) hs-source-dirs: src/win32 include-dirs: src/win32- other-modules: CtrlC- Encoding.Win32+ other-modules: Darcs.Util.CtrlC+ Darcs.Util.Encoding.Win32+ -- These are kept outside the Darcs.* namespace as System.Posix+ -- is well-established and its just trying to simulate that+ -- TODO try to abstract this out better 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+ build-depends: unix-compat >= 0.1.2 && < 0.5,+ Win32 >= 2.2 && < 2.4 else- other-modules: Encoding.IConv+ other-modules: Darcs.Util.Encoding.IConv c-sources: src/h_iconv.c- build-depends: utf8-string >= 0.3.6 && < 0.4 + if flag(use-local-data-map-strict)+ build-depends: containers >= 0.4 && < 0.5,+ deepseq >= 1.3 && < 1.4+ hs-source-dirs: containers-0.5.2.1+ other-modules:+ Darcs.Data.Map.Base+ Darcs.Data.Map.Strict+ Darcs.Data.Set.Base+ Darcs.Data.StrictPair+ cpp-options: -DUSE_LOCAL_DATA_MAP_STRICT+ else+ build-depends: containers >= 0.5 && < 0.6+ if os(solaris) cc-options: -DHAVE_SIGINFO_H - if os(windows)- build-depends: base >= 4 && < 4.8- else- if flag(force-char8-encoding)- build-depends: base >= 4.5 && < 4.8- cpp-options: -DFORCE_CHAR8_ENCODING- else- build-depends: base >= 4 && < 4.4+ build-depends: base >= 4.5 && < 4.9 - build-depends: extensible-exceptions >= 0.1 && < 0.2,- regex-compat >= 0.95.1,- mtl >= 1.0 && < 2.3,- parsec >= 2.0 && < 3.2,+ build-depends: binary >= 0.5 && < 0.8,+ regex-compat-tdfa >= 0.95.1 && < 0.96,+ regex-applicative >= 0.2 && < 0.4,+ mtl >= 2.1 && < 2.3,+ transformers >= 0.3 && < 0.4.0.0 || > 0.4.0.0 && < 0.5,+ -- for the Control.Monad.Error -> Control.Monad.Except+ -- transition+ transformers-compat >= 0.4 && < 0.5,+ parsec >= 3.1 && < 3.2, html == 1.0.*,- filepath >= 1.1.0.0 && < 1.5.0.0,+ filepath >= 1.2.0.0 && < 1.5.0.0, haskeline >= 0.6.3 && < 0.8,- hashed-storage >= 0.5.6 && < 0.6,- vector >= 0.7,- 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+ cryptohash >= 0.4 && < 0.12,+ base16-bytestring >= 0.1 && < 0.2,+ utf8-string >= 0.3.6 && < 1.1,+ vector >= 0.7 && < 0.11,+ tar == 0.4.*,+ data-ordlist == 0.4.*,+ attoparsec >= 0.11 && < 0.13,+ zip-archive >= 0.2.3 && < 0.3 if !os(windows)- build-depends: unix >= 1.0 && < 2.8+ build-depends: unix >= 2.5 && < 2.8 build-depends: bytestring >= 0.9.0 && < 0.11,- text >= 0.11.0.6 && < 1.2,- old-time >= 1.0 && < 1.2,- directory >= 1.0.0.0 && < 1.3.0.0,- process >= 1.0.0.0 && < 1.3.0.0,- containers >= 0.1 && < 0.6,- array >= 0.1 && < 0.6,- random == 1.0.*+ text >= 0.11.2.0 && < 1.3,+ old-time >= 1.1 && < 1.2,+ directory >= 1.1.0.2 && < 1.3.0.0,+ process >= 1.1.0.1 && < 1.3.0.0,+ array >= 0.4 && < 0.6,+ random >= 1.0 && < 1.2,+ hashable >= 1.0 && < 1.3 + if flag(use-time-1point5)+ build-depends: time >= 1.5 && < 1.6+ else+ build-depends: time >= 1.4 && < 1.5,+ old-locale >= 1.0 && < 1.1 if flag(optimize) ghc-options: -O2@@ -426,43 +473,40 @@ if flag(hpc) ghc-prof-options: -fhpc -hpcdir dist/hpc/libdarcs + if flag(rts)+ ghc-options: -rtsopts+ if flag(curl)- extra-libraries: curl- includes: curl/curl.h cpp-options: -DHAVE_CURL c-sources: src/hscurl.c cc-options: -DHAVE_CURL+ if flag(pkgconfig)+ pkgconfig-depends: libcurl+ else+ extra-libraries: curl+ includes: curl/curl.h if flag(http)- build-depends: HTTP >= 4000.0.8 && < 4000.3+ build-depends: network >= 2.3 && < 2.5,+ HTTP >= 4000.2.3 && < 4000.3 cpp-options: -DHAVE_HTTP x-have-http:- if flag(network-uri)- build-depends: network >= 2.6, network-uri >= 2.6- else- build-depends: network >= 2.2, network < 2.6 if (!flag(curl) && !flag(http)) buildable: False - if flag(mmap) && !os(windows)- build-depends: mmap >= 0.5 && < 0.6- cpp-options: -DHAVE_MMAP+ build-depends: mmap >= 0.5 && < 0.6 - build-depends: zlib >= 0.5.1.0 && < 0.6.0.0+ build-depends: zlib >= 0.5.3.0 && < 0.6.0.0 -- The terminfo package cannot be built on Windows. if flag(terminfo) && !os(windows) build-depends: terminfo == 0.3.* cpp-options: -DHAVE_TERMINFO - if flag(color)- x-use-color:- -- if true to work around cabal bug with flag ordering if true- extensions:- CPP+ default-extensions: BangPatterns PatternGuards GADTs@@ -473,17 +517,50 @@ KindSignatures RankNTypes TypeFamilies-- 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+ -- in ghc < 7.6 we need to import Prelude hiding (catch)+ -- in ghc >= 7.6 catch isn't in Prelude+ -- once the minimum version of ghc is >= 7.6 we can remove the hiding+ -- clauses and this flag+ ghc-options: -fno-warn-dodgy-imports + -- hashed-storage inclusion+ hs-source-dirs: hashed-storage++ exposed-modules:+ Storage.Hashed+ Storage.Hashed.AnchoredPath+ Storage.Hashed.Index+ Storage.Hashed.Monad+ Storage.Hashed.Tree+ Storage.Hashed.Hash+ Storage.Hashed.Packed++ Storage.Hashed.Plain+ Storage.Hashed.Darcs++ if flag(hashed-storage-diff)+ exposed-modules:+ Storage.Hashed.Diff+ build-depends: lcs++ other-modules:+ Bundled.Posix+ Storage.Hashed.Utils++ build-depends: dataenc >=0.11 && < 0.15,+ unix-compat >= 0.1.2 && < 0.5,+ cryptohash >= 0.4 && < 0.12++ if os(windows)+ cpp-options: -DWIN32+ build-depends: Win32 >= 2.2 && < 2.4++ -- end of hashed-storage inclusion+ -- ---------------------------------------------------------------------- -- darcs itself -- ----------------------------------------------------------------------@@ -493,18 +570,12 @@ buildable: False else buildable: True- build-tools: ghc >= 6.10 && < 7.10+ build-tools: ghc >= 7.4 && < 7.12 - main-is: darcs.hs- hs-source-dirs: src- include-dirs: src- c-sources: src/atomic_create.c- src/fpstring.c- src/maybe_relink.c- src/umask.c- src/Crypt/sha2.c- src/system_encoding.c+ default-language: Haskell2010 + main-is: darcs.hs+ hs-source-dirs: darcs if flag(optimize) ghc-options: -O2@@ -528,104 +599,20 @@ if flag(hpc) ghc-prof-options: -fhpc -hpcdir dist/hpc/darcs - cc-options: -D_REENTRANT-- if os(windows)- hs-source-dirs: src/win32- include-dirs: src/win32- other-modules: CtrlC- System.Posix- System.Posix.Files- System.Posix.IO- Preproc- 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.8- else- if flag(force-char8-encoding)- build-depends: base >= 4.5 && < 4.8- cpp-options: -DFORCE_CHAR8_ENCODING- else- build-depends: base >= 4 && < 4.4-- build-depends: extensible-exceptions >= 0.1 && < 0.2,- regex-compat >= 0.95.1,- mtl >= 1.0 && < 2.3,- parsec >= 2.0 && < 3.2,- html == 1.0.*,- filepath >= 1.1.0.0 && < 1.5.0.0,- haskeline >= 0.6.3 && < 0.8,- hashed-storage >= 0.5.6 && < 0.6,- vector >= 0.7,- 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.8-- build-depends: bytestring >= 0.9.0 && < 0.11,- text >= 0.11.0.6 && < 1.2,- old-time >= 1.0 && < 1.2,- directory >= 1.0.0.0 && < 1.3.0.0,- process >= 1.0.0.0 && < 1.3.0.0,- containers >= 0.1 && < 0.6,- array >= 0.1 && < 0.6,- random == 1.0.*-- if flag(curl)- extra-libraries: curl- includes: curl/curl.h- cpp-options: -DHAVE_CURL- c-sources: src/hscurl.c- cc-options: -DHAVE_CURL-- if flag(http)- build-depends: HTTP >= 4000.0.8 && < 4000.3- cpp-options: -DHAVE_HTTP- x-have-http:- if flag(network-uri)- build-depends: network >= 2.6, network-uri >= 2.6- else- build-depends: network >= 2.2, network < 2.6-- if (!flag(curl) && !flag(http))- buildable: False-- if flag(mmap) && !os(windows)- build-depends: mmap >= 0.5 && < 0.6- cpp-options: -DHAVE_MMAP+ if flag(rts)+ ghc-options: -rtsopts - build-depends: zlib >= 0.5.1.0 && < 0.6.0.0+ cc-options: -D_REENTRANT - -- The terminfo package cannot be built on Windows.- if flag(terminfo) && !os(windows)- build-depends: terminfo == 0.3.*- cpp-options: -DHAVE_TERMINFO+ build-depends: base >= 4.5 && < 4.9 - if flag(color)- x-use-color:+ build-depends: darcs,+ filepath >= 1.2.0.0 && < 1.5.0.0,+ regex-compat-tdfa >= 0.95.1 && < 0.96 -- if true to work around cabal bug with flag ordering if true- extensions:- CPP+ default-extensions: BangPatterns PatternGuards GADTs@@ -636,205 +623,170 @@ KindSignatures RankNTypes TypeFamilies-- 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- -- ---------------------------------------------------------------------- -- unit test driver -- ---------------------------------------------------------------------- -Executable darcs-test+test-suite darcs-test+ buildable: True+ build-tools: ghc >= 7.4 && < 7.12+ type: exitcode-stdio-1.0+ default-language: Haskell2010 main-is: test.hs-- build-tools: ghc >= 6.10 && < 7.10+ hs-source-dirs: harness + build-depends: base >= 4.5 && < 4.9 - if !flag(test)- buildable: False- else- buildable: True+ if os(windows)+ cpp-options: -DWIN32 - build-depends: extensible-exceptions >= 0.1 && < 0.2,- regex-compat >= 0.95.1,- mtl >= 1.0 && < 2.3,- 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,- shellish >= 0.1.3 && < 0.2,- test-framework >= 0.4.0,- test-framework-hunit >= 0.2.2,- test-framework-quickcheck2 >= 0.2.8+ build-depends: darcs,+ array >= 0.4 && < 0.6,+ bytestring >= 0.9.0 && < 0.11,+ cmdargs >= 0.10 && < 0.11,+ containers >= 0.1 && < 0.6,+ filepath >= 1.2.0.0 && < 1.5.0.0,+ html == 1.0.*,+ mtl >= 2.1 && < 2.3,+ parsec >= 3.1 && < 3.2,+ regex-compat-tdfa >= 0.95.1 && < 0.96,+ shelly >= 1.6 && < 1.7,+ split >= 0.1.4.1 && < 0.3,+ text >= 0.11.0.6 && < 1.3,+ directory >= 1.1.0.2 && < 1.3.0.0,+ FindBin >= 0.0 && < 0.1,+ QuickCheck >= 2.3 && < 2.8,+ HUnit >= 1.0 && < 1.3,+ test-framework >= 0.4.0 && < 0.9,+ test-framework-hunit >= 0.2.2 && < 0.4,+ test-framework-quickcheck2 >= 0.3 && < 0.4 - hs-source-dirs: src- include-dirs: src- c-sources: src/atomic_create.c- src/fpstring.c- src/maybe_relink.c- src/umask.c- src/Crypt/sha2.c- src/system_encoding.c- -- list all unit test modules not exported by libdarcs; otherwise Cabal won't- -- include them in the tarball- other-modules: Darcs.Test.Email- Darcs.Test.Patch.Check- Darcs.Test.Patch.Examples.Set1- Darcs.Test.Patch.Examples.Set2Unwitnessed- Darcs.Test.Patch.WSub- Darcs.Test.Patch.Info- Darcs.Test.Patch.Properties.V1Set1- Darcs.Test.Patch.Properties.V1Set2- Darcs.Test.Patch.Properties.Generic- Darcs.Test.Patch.Properties.GenericUnwitnessed- Darcs.Test.Patch.Properties.Check- Darcs.Test.Patch.Properties.Real- Darcs.Test.Patch.Arbitrary.Generic- Darcs.Test.Patch.Arbitrary.Real- Darcs.Test.Patch.Arbitrary.PrimV1- Darcs.Test.Patch.Arbitrary.PrimV3- Darcs.Test.Patch.Arbitrary.PatchV1- Darcs.Test.Patch.RepoModel- Darcs.Test.Patch.Utils- Darcs.Test.Patch.V1Model- Darcs.Test.Patch.V3Model- Darcs.Test.Patch.WithState- Darcs.Test.Patch- Darcs.Test.Misc- Darcs.Test.Util.TestResult- Darcs.Test.Util.QuickCheck+ -- list all unit test modules not exported by libdarcs; otherwise Cabal won't+ -- include them in the tarball+ other-modules: Darcs.Test.Email+ Darcs.Test.Patch.Check+ Darcs.Test.Patch.Examples.Set1+ Darcs.Test.Patch.Examples.Set2Unwitnessed+ Darcs.Test.Patch.WSub+ Darcs.Test.Patch.Info+ Darcs.Test.Patch.Properties.V1Set1+ Darcs.Test.Patch.Properties.V1Set2+ Darcs.Test.Patch.Properties.Generic+ Darcs.Test.Patch.Properties.GenericUnwitnessed+ Darcs.Test.Patch.Properties.Check+ Darcs.Test.Patch.Properties.Real+ Darcs.Test.Patch.Arbitrary.Generic+ Darcs.Test.Patch.Arbitrary.Real+ Darcs.Test.Patch.Arbitrary.PrimV1+ Darcs.Test.Patch.Arbitrary.PrimV3+ Darcs.Test.Patch.Arbitrary.PatchV1+ Darcs.Test.Patch.Rebase+ Darcs.Test.Patch.RepoModel+ Darcs.Test.Patch.Utils+ Darcs.Test.Patch.V1Model+ Darcs.Test.Patch.V3Model+ Darcs.Test.Patch.WithState+ Darcs.Test.Patch+ Darcs.Test.Misc+ Darcs.Test.Util.TestResult+ Darcs.Test.Util.QuickCheck - if flag(optimize)- ghc-options: -O2- else- ghc-options: -O0+ if flag(optimize)+ ghc-options: -O2+ else+ ghc-options: -O0 - if flag(warn-as-error)- ghc-options: -Werror+ if flag(warn-as-error)+ ghc-options: -Werror - -- Note: "if true" works around a cabal bug with order of flag composition- if true- ghc-options: -Wall -funbox-strict-fields -fwarn-tabs+ -- Note: "if true" works around a cabal bug with order of flag composition+ if true+ ghc-options: -Wall -funbox-strict-fields -fwarn-tabs ghc-prof-options: -prof -auto-all- if flag(threaded)- ghc-options: -threaded-- if flag(curl)- extra-libraries: curl- includes: curl/curl.h- cpp-options: -DHAVE_CURL- c-sources: src/hscurl.c- cc-options: -DHAVE_CURL--- if flag(hpc)- ghc-prof-options: -fhpc -hpcdir dist/hpc/darcs-test-- cc-options: -D_REENTRANT+ if flag(threaded)+ ghc-options: -threaded - cpp-options: -DGADT_WITNESSES=1+ if flag(hpc)+ ghc-prof-options: -fhpc -hpcdir dist/hpc/darcs-test - if os(windows)- hs-source-dirs: src/win32- include-dirs: src/win32- other-modules: CtrlC- 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- 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 flag(rts)+ ghc-options: -rtsopts - if os(solaris)- cc-options: -DHAVE_SIGINFO_H+ cc-options: -D_REENTRANT - if os(windows)- build-depends: base >= 4 && < 4.8- else- if flag(force-char8-encoding)- build-depends: base >= 4.5 && < 4.8- cpp-options: -DFORCE_CHAR8_ENCODING- else- build-depends: base >= 4 && < 4.4+ -- if true to work around cabal bug with flag ordering+ if true+ default-extensions:+ BangPatterns+ PatternGuards+ GADTs+ TypeOperators+ FlexibleContexts+ FlexibleInstances+ ScopedTypeVariables+ KindSignatures+ RankNTypes+ TypeFamilies+ NoMonoLocalBinds - if !os(windows)- build-depends: unix >= 1.0 && < 2.8+-- hashed-storage inclusion+test-suite hashed-storage-test+ buildable: True+ type: exitcode-stdio-1.0+ default-language: Haskell2010 - build-depends: bytestring >= 0.9.0 && < 0.11,- haskeline >= 0.6.3 && < 0.8,- text >= 0.11.0.6 && < 1.2,- old-time >= 1.0 && < 1.2,- directory >= 1.0.0.0 && < 1.3.0.0,- process >= 1.0.0.0 && < 1.3.0.0,- containers >= 0.1 && < 0.6,- array >= 0.1 && < 0.6,- hashed-storage >= 0.5.6 && < 0.6,- vector >= 0.7,- tar >= 0.3 && < 0.5,- random == 1.0.*+ hs-source-dirs: hashed-storage - if impl(ghc<7.0)- -- haskeline 0.6.4.7 doesn't build with ghc 6.12- build-depends: haskeline <= 0.6.4.6+ ghc-options: -Wall -O2 -fwarn-tabs+ ghc-prof-options: -prof -auto-all -O2 - if flag(mmap) && !os(windows)- build-depends: mmap >= 0.5 && < 0.6- cpp-options: -DHAVE_MMAP+ if flag(hpc)+ ghc-prof-options: -fhpc - build-depends: zlib >= 0.5.1.0 && < 0.6.0.0+ if flag(warn-as-error)+ ghc-options: -Werror - -- The terminfo package cannot be built on Windows.- if flag(terminfo) && !os(windows)- build-depends: terminfo == 0.3.*- cpp-options: -DHAVE_TERMINFO+ 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+ -- once the minimum version of ghc is >= 7.6 we can remove the hiding+ -- clauses and this flag+ ghc-options: -fno-warn-dodgy-imports - if flag(http)- build-depends: HTTP >= 4000.0.8 && < 4000.3- if flag(network-uri)- build-depends: network >= 2.6, network-uri >= 2.6- else- build-depends: network >= 2.2, network < 2.6+ main-is: test.hs+ other-modules: Bundled.Posix+ Storage.Hashed.Test - if flag(color)- x-use-color:+ if os(windows)+ cpp-options: -DWIN32+ build-depends: Win32 >= 2.2 && < 2.4 - -- if true to work around cabal bug with flag ordering- if true- extensions:- CPP- BangPatterns- PatternGuards- GADTs- TypeOperators- FlexibleContexts- FlexibleInstances- ScopedTypeVariables- KindSignatures- RankNTypes- TypeFamilies+ -- hashed-storage inclusion: duplicated these from the library -+ -- probably needed because of the higher cabal-version in darcs.cabal+ -- not using version constraints here to save on maintaining duplicates,+ -- since these packages are all constrained elsewhere in the cabal file.+ build-depends: base,+ containers,+ mtl,+ directory,+ filepath,+ bytestring,+ dataenc,+ cryptohash,+ binary,+ zlib,+ mmap,+ unix-compat - if impl(ghc>=7.0)- extensions:- NoMonoLocalBinds+ build-depends: test-framework,+ test-framework-hunit,+ test-framework-quickcheck2,+ QuickCheck,+ HUnit,+ process,+ zip-archive - 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+-- end of hashed-storage inclusion
+ darcs/darcs.hs view
@@ -0,0 +1,89 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++-- |+-- Module : Main+-- Copyright : 2002-2003 David Roundy+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++module Main ( main ) where++import Control.Exception ( AssertionFailed(..), handle )+import Control.Monad ( forM_ )+import System.IO ( stdin, stdout, stderr, hSetBinaryMode )+import System.Exit ( exitWith, ExitCode(..) )+import System.Environment ( getArgs )++import Darcs.UI.RunCommand ( runTheCommand )+import Darcs.UI.Commands.Help ( helpCmd, listAvailableCommands, printVersion,+ commandControlList )+import Darcs.UI.Flags ( DarcsFlag(Verbose) )+import Darcs.Util.AtExit ( withAtexit, atexit )+import Darcs.Repository( reportBadSources )+import Darcs.Util.SignalHandler ( withSignalsHandled )++import Darcs.Util.ByteString ( decodeString )+import Darcs.UI.External ( setDarcsEncodings )+import Darcs.Util.Exec ( ExecException(..) )+import Darcs.Util.Path ( getCurrentDirectory )+import Version ( version, context, builddeps )++#include "impossible.h"++execExceptionHandler :: ExecException -> IO a+execExceptionHandler (ExecException cmd args redirects reason) = do+ putStrLn . unlines $+ [ "Failed to execute external command: " ++ unwords (cmd:args)+ , "Lowlevel error: " ++ reason+ , "Redirects: " ++ show redirects+ ]+ exitWith $ ExitFailure 3++main :: IO ()+main = withAtexit . withSignalsHandled . handleExecFail . handleAssertFail $ do+ atexit reportBadSources+ setDarcsEncodings+ argv <- getArgs >>= mapM decodeString+ here <- getCurrentDirectory+ let runHelpCmd = helpCmd (here, here) [] []+ -- Explicitly handle no-args and special "help" arguments.+ case argv of+ [] -> printVersion >> runHelpCmd+ ["-h"] -> runHelpCmd+ ["--help"] -> runHelpCmd+ ["--overview"] -> helpCmd (here, here) [Verbose] []+ ["--commands"] -> listAvailableCommands+ ["-v"] -> putStrLn version+ ["--version"] -> putStrLn version+ ["--exact-version"] -> printExactVersion+ _ -> do+ forM_ [stdout, stdin, stderr] $ \h -> hSetBinaryMode h True+ runTheCommand commandControlList (head argv) (tail argv)+ where+ handleExecFail = handle execExceptionHandler+ handleAssertFail = handle $ \(AssertionFailed e) -> bug e+ printExactVersion = do+ putStrLn $ "darcs compiled on " ++ __DATE__ ++ ", at " ++ __TIME__+ putStrLn context+ putStrLn "Compiled with:\n"+ putStr builddeps+
− doc/darcs.css
@@ -1,103 +0,0 @@-BODY {- background: white;- color: black;- font-family: arial,sans-serif;- font-size: 90%;- margin: 0;- padding: 1em;-}--#col1, #col2 { float: left; width: 50%; }-#col2 { margin-left: -1px; }-.inner { margin: 0 1em; }--A:link {- background: transparent;- color: #494a82;-}--A:visited {- background: transparent;- color: #8081b3-}--IMG.thanks-left {- float: left;- margin-right: 5px;- height: 50px;-}--IMG.thanks-right {- float: right;- margin-left: 5px;- height: 50px;-}--BLOCKQUOTE.testimonial {- font-style: italic;-}--PRE {- background: #eeeeee;- border: 1px solid #888888;- color: black;- padding: 1em;- white-space: pre;-}--H1 {- color: #494a82;- font-size: 24px ;-}--H2 {- color: #494a82;- font-size: 18px;-}--H3 {- color: #494a82;- font-size: 16px;-}--H4 {- color: #494a82;- font-size: 14px;-}--/* headers for darcs command options */-.cmd-opt-hdr {- color: #494a82;- font-size: 14px;- font-weight: bold;-}--/* begin styles for RSS Feed This is the most basic style to use for a list with no bullets */--.rss_title, rss_title a {- margin: 0px 0;- padding: 0;-}--.rss_items {- list-style:none;- margin:0;- padding:0;-}--.rss_item {-/* font-size: x-small; */- margin-bottom: 1em;;-}--.rss_item a:link, .rss_item a:visited, .rss_item a:active {-- }--.rss_item a:hover { -- }- -.rss_date {- font-size: xx-small;- }
− doc/src/best_practices.tex
@@ -1,612 +0,0 @@-% This file (unlike the rest of darcs) is in the public domain.- --\chapter{Best practices}--This chapter is intended to review various scenarios and describe in each-case effective ways of using darcs. There is no one ``best practice'', and-darcs is a sufficiently low-level tool that there are many high-level ways-one can use it, which can be confusing to new users.--\section{Creating patches}--This section will lay down the concepts around patch creation.-The aim is to develop a way of thinking-that corresponds well to how darcs is behaving---- even in complicated situations.-- In a single darcs repository you can think of two ``versions'' of the source tree.- They are called the \emph{working} and \emph{pristine} trees.- \emph{Working} is your normal source tree, with or without darcs alongside.- The only thing that makes it part of a darcs repository- is the \verb!_darcs! directory in its root.- \emph{Pristine} is the recorded state of the source tree.- The pristine tree is constructed from groups of changes,- called {\em patches\/} (some other version control systems use the- term {\em changeset\/} instead of {\em patch\/}).\footnote{If- you look inside \_darcs you will find files or directories named- {\tt patches} and {\tt inventories}, which store all the patches- ever recorded. If the repository holds a cached pristine tree, it- is stored in a directory called {\tt pristine.hashed}.}- Darcs will create and store these patches- based on the changes you make in \emph{working}.---\subsection{Changes}- If \emph{working} and \emph{pristine} are the same,- there are ``no changes'' in the working copy.- Changes can be introduced (or removed) by editing the files in \emph{working}.- They can also be caused by darcs commands,- which can modify \emph{both} \emph{working} and \emph{pristine}.- It is important to understand for each darcs command- how it modifies \emph{working}, \emph{pristine} or both of them.-- \verb!whatsnew! (as well as \verb!diff!) can show- the difference between \emph{working} and \emph{pristine} to you.- It will be shown as a difference in \emph{working}.- In advanced cases it need \emph{not} be \emph{working} that has changed;- it can just as well have been \emph{pristine}, or both.- The important thing is the difference and what darcs can do with it.--\subsection{Keeping or discarding changes}- If you have a difference in \emph{working}, you do two things- with it: \verb!record! it to keep it, or \verb!revert! it to lose the changes.%- \footnote{%- Revert can undo precious work in a blink.- To protect you from great grief,- the discarded changes are saved temporarily- so the latest revert can be undone with unrevert.}-- If you have a difference between \emph{working} and \emph{pristine}%- ---for example after editing some files in \emph{working}---%- \verb!whatsnew! will show some ``unrecorded changes''.- To save these changes, use \verb!record!.- It will create a new patch in \emph{pristine} with the same changes,- so \emph{working} and \emph{pristine} are no longer different.- To instead undo the changes in \emph{working}, use \verb!revert!.- It will modify the files in \emph{working} to be the same as in \emph{pristine}- (where the changes do not exist).---\subsection{Unrecording changes}- \verb!unrecord! is a command meant to be run only in private- repositories. Its intended purpose is to allow developers the flexibility- to undo patches that haven't been distributed yet.-- If you \verb!unrecord! a patch, that patch will be deleted from \emph{pristine}.- This will cause \emph{working} to be different from \emph{pristine},- and \verb!whatsnew! to report unrecorded changes.- The difference will be the same as just before that patch was \verb!record!ed.- Think about it.- \verb!record! examines what's different with \emph{working}- and constructs a patch with the same changes in \emph{pristine}- so they are no longer different.- \verb!unrecord! deletes this patch;- the changes in \emph{pristine} disappear and the difference is back.-- If the recorded changes included an error,- the resulting flawed patch can be unrecorded.- When the changes have been fixed,- they can be recorded again as a new---hopefully flawless---patch.-- If the whole change was wrong it can be discarded from \emph{working} too,- with \verb!revert!.- \verb!revert! will update \emph{working} to the state of \emph{pristine},- in which the changes do no longer exist after the patch was deleted.-- Keep in mind that the patches are your history,- so deleting them with \verb!unrecord! makes it impossible to track- what changes you \emph{really} made.- Redoing the patches is how you ``cover the tracks''.- On the other hand,- it can be a very convenient way to manage and organize changes- while you try them out in your private repository.- When all is ready for shipping,- the changes can be reorganized in what seems as useful and impressive patches.- Use it with care.-- All patches are global,- so don't \emph{ever} replace an already ``shipped'' patch in this way!- If an erroneous patch is deleted and replaced with a better one,- you have to replace it in \emph{all} repositories that have a copy of it.- This may not be feasible, unless it's all private repositories.- If other developers have already made patches or tags in their repositories- that depend on the old patch, things will get complicated.---\subsection{Special patches and pending}--The patches described in the previous sections have mostly been hunks.-A \emph{hunk} is one of darcs' primitive patch types,-and it is used to remove old lines and/or insert new lines.-There are other types of primitive patches,-such as \emph{adddir} and \emph{addfile}-which add new directories and files,-and \emph{replace}-which does a search-and-replace on tokens in files.--Hunks are always calculated in place with a diff algorithm-just before \verb!whatsnew! or \verb!record!.-But other types of primitive patches need to be explicitly created-with a darcs command.-They are kept in \emph{pending}, ie, in the file {\tt\_darcs/patches/pending},-until they are either recorded or reverted.--\emph{Pending} can be thought of as a special extension of \emph{working}.-When you issue, e.g., a darcs \verb!replace! command,-the replace is performed on the files in \emph{working}-and at the same time a replace patch is put in \emph{pending}.-Patches in \emph{pending} describe special changes made in \emph{working}.-The diff algorithm will fictively apply these changes to \emph{pristine}-before it compares it to \emph{working},-so all lines in \emph{working} that are changed by a \verb!replace! command-will also be changed in \emph{pending} and \emph{pristine}-when the hunks are calculated.-That's why no hunks with the replaced lines will be shown by \verb!whatsnew!;-it only shows the replace patch in \emph{pending} responsible for the change.--If a special patch is recorded, it will simply be moved to \emph{pristine}.-If it is instead reverted, it will be deleted from \emph{pending}-and the accompanying change will be removed from \emph{working}.--Note that reverting a patch in pending is \emph{not} the same as-simply removing it from pending.-It actually applies the inverse of the change to \emph{working}.-Most notable is that reverting an addfile patch-will delete the file in \emph{working} (the inverse of adding it).-So if you add the wrong file to darcs by mistake,-\emph{don't} \verb!revert! the addfile.-Instead use \verb!remove!, which cancels out the addfile in pending.---\section{Using patches} % still basics--This section will lay down the concepts around patch distribution and branches.-The aim is to develop a way of thinking-that corresponds well to how darcs is behaving---- even in complicated situations.--A repository is a collection of patches.-Patches have no defined order,-but patches can have dependencies on other patches.-Patches can be added to a repository in any order-as long as all patches depended upon are there.-Patches can be removed from a repository in any order,-as long as no remaining patches depend on them.--Repositories can be cloned to create branches.-Patches created in different branches may conflict.-A conflict is a valid state of a repository.-A conflict makes the working tree ambiguous until the conflict is resolved.---\subsection{Dependencies}--There are two kinds of dependencies.--Implicit dependencies is the far most common kind.-These are calculated automatically by darcs.-If a patch removes a file or a line of code,-it will have to depend on the patch that added that file or line of code.-If a patch adds a line of code,-it will usually have to depend on the patch or patches that added the adjacent lines.--Explicit dependencies can be created if you give the \verb|--ask-deps| option to \verb|darcs record|.-This is good for assuring that logical dependencies hold between patches.-It can also be used to group patches---%-a patch with explicit dependencies doesn't need to change anything---%-and pulling the patch also pulls all patches it was made to depend on.---\subsection{Branches: just normal repositories}--Darcs does not have branches---it doesn't need to.-Any two repositories are ``branches'' in darcs,-but it is not of much use unless they have a large portion of patches in common.-If they are different projects they will have nothing in common,-but darcs may still very well be able to merge them,-although the result probably is nonsense.-Therefore the word ``branch'' isn't a technical term in darcs;-it's just the way we think of one repository in relation to another.--Branches are \emph{very} useful in darcs.-They are in fact \emph{necessary} if you want to do more than only simple work.-When you \verb|get| someone's repository from the Internet,-you are actually creating a branch of it.-But darcs is designed this way, and it has means to make it efficient.-The answer to many questions about how to do a thing with darcs is: ``use a branch''.-It is a simple and elegant solution with great power and flexibility,-which contributes to darcs' uncomplicated user interface.--You create new branches (i.e., clone repositories)-with the \verb|get| and \verb|put| commands.---\subsection{Moving patches around---no versions}--Patches are global, and a copy of a patch either is or is not present in a branch.-This way you can rig a branch almost any way you like,-as long as dependencies are fulfilled---%-darcs \emph{won't} let you break dependencies.-If you suspect a certain feature from some time ago introduced a bug,-you can remove the patch/patches that adds the feature,-and try without it.\footnote{%-darcs even has a special command, {\tt trackdown}-that automatically removes patches-until a specified test no longer fails.}--Patches are added to a repository with \verb|pull|-and removed from the repositories with \verb|obliterate|.-Don't confuse these two commands with \verb|record| and \verb|unrecord|,-which constructs and deconstructs patches.--It is important not to lose patches when (re)moving them around.-\verb|pull| needs a source repository to copy the patch from,-whereas \verb|obliterate| just erases the patch.-Beware that if you obliterate \emph{all} copies of a patch-it is completely lost---forever.-Therefore you should work with branches when you obliterate patches.-The \verb|obliterate| command can wisely be disabled in a dedicated main repository-by adding \verb|obliterate disable| to the repository's defaults file.--For convenience, there is a \verb|push| command.-It works like \verb|pull| but in the other direction.-It also differs from \verb|pull| in an important way:-it starts a second instance of darcs to apply the patch in the target repository,-even if it's on the same computer.-It can cause surprises if you have a ``wrong'' darcs in your PATH.---\subsection{Tags---versions}--While \verb|pull| and \verb|obliterate| can be used to-construct different ``versions'' in a repository,-it is often desirable to name specific configurations of patches-so they can be identified and retrieved easily later.-This is how darcs implements what is usually known as versions.-The command for this is \verb|tag|,-and it records a tag in the current repository.--A tag is just a patch, but it only contains explicit dependencies.-It will depend on all the patches in the current repository.\footnote{%-It will omit patches already depended upon by other patches,-since they will be indirectly depended upon anyway.}-Darcs can recognize if a patch is as a tag;-tags are sometimes treated specially by darcs commands.--While traditional revision control systems tag versions in the time line history,-darcs lets you tag any configuration of patches at any time,-and pass the tags around between branches.--With the option \verb|--tag| to \verb|get| you can easily get-a named version in the repository-as a new branch.---\subsection{Conflicts}--A conflict \emph{happens} when two conflicting patches meet in the same repository.-This is no problem for darcs; it can happily pull together just any patches.-But it is a problem for the files in \emph{working} (and \emph{pristine}).-The conflict can be thought of as-two patches telling darcs different things about what a file should look like.--Darcs escapes this problem-by ignoring those parts of the patches that conflict.-They are ignored in \emph{both} patches.-If patch~A changes the line ``FIXME'' to ``FIXED'',-and patch~B changes the same line to ``DONE'',-the two patches together will produce the line ``FIXME''.-Darcs doesn't care which one you pulled into the repository first,-you still get the same result when the conflicting patches meet.-All other changes made by A and B are performed as normal.--Darcs can mark a conflict for you in \emph{working}.-This is done with \verb|mark-conflicts|.-Conflicts are marked such that both conflicting changes-are inserted with special delimiter lines around them.-Then you can merge the two changes by hand,-and remove the delimiters.--When you pull patches,-darcs automatically performs a \verb|mark-conflicts| for you if a conflict happens.-You can remove the markup with \verb|revert|,-Remember that the result will be the lines from-the previous version common to both conflicting patches.-The conflict marking can be redone again with \verb|mark-conflicts|.--A special case is when a pulled patch conflicts with unrecorded changes in the repository.-The conflict will be automatically marked as usual,-but since the markup is \emph{also} an unrecorded change,-it will get mixed in with your unrecorded changes.-There is no guarantee you can revert \emph{only} the markup after this,-and \verb|mark-conflicts| will not be able to redo this markup later if you remove it.-It is good practice to record important changes before pulling.--\verb|mark-conflicts| can't mark complicated conflicts.-In that case you'll have to use \verb|darcs diff| and other commands-to understand what the conflict is all about.-If for example two conflicting patches create the same file,-\verb|mark-conflicts| will pick just one of them,-and no delimiters are inserted.-So watch out if darcs tells you about a conflict.--\verb|mark-conflicts| can also be used to check for unresolved conflicts.-If there are none, darcs replies ``No conflicts to mark.''.-While \verb|pull| reports when a conflict happens,-\verb|obliterate| and \verb|get| don't.---\subsection{Resolving conflicts}--A conflict is resolved-(not marked, as with the command \verb|mark-conflicts|)-as soon as some new patch depends on the conflicting patches.-This will usually be the resolve patch you record after manually putting together the pieces-from the conflict markup produced by \verb|mark-conflicts| (or \verb|pull|).-But it can just as well be a tag.-So don't forget to fix conflicts before you accidentally ``resolve'' them by recording other patches.--If the conflict is with one of your not-yet-published patches,-you may choose to amend that patch rather than creating a resolve patch.--If you want to back out and wait with the conflict,-you can \verb|obliterate| the conflicting patch you just pulled.-Before you can do that you have to \verb|revert| the conflict markups-that \verb|pull| inserted when the conflict happened.--\section{Global and per-repository caches}--Darcs uses a global cache, as this is one of its biggest performance-enhancing tools. The global-cache acts as a giant patch pool where darcs first looks for a patch when-grabbing new patches. This saves time by not downloading the same patch-twice from a remote server. It also saves space by storing the patch only-once, if you ensure your cache and your repositories are on the same-hardlink-supporting filesystem. --Darcs now enables a global patch cache under your home directory by default.-Older darcs 2.x versions required this manual step:--\begin{verbatim}-$ mkdir -p $HOME/.darcs/cache-$ echo cache:$HOME/.darcs/cache > $HOME/.darcs/sources-\end{verbatim}--On MS Windows~\ref{ms_win}, using \verb|cmd.exe| (Command Prompt under Accessories):--\begin{verbatim}-> md "%APPDATA%\darcs\cache" (notice double quotes!)-> echo cache:%APPDATA%\darcs\cache > "%APPDATA%\darcs\sources"-\end{verbatim}--Individual repositories also contain cache location information.-Each time a repository is got, its location is added as an-entry in \verb!_darcs/prefs/sources!. If one of these repositories were to-become totally or temporarily unreachable, it can cause darcs to hang-for a long time trying to reach it. Fortunately darcs has a mechanism-which helps us to deal with that problem: if an unreachable entry is-discovered, darcs stops using it for the rest of the session and then-notifies the user to take further action. It will display a message-like the following:-\begin{verbatim}> I could not reach the following repository:-> http://darcs.net/-> If you're not using it, you should probably delete-> the corresponding entry from _darcs/prefs/sources.-\end{verbatim}--There are some other advanced things you can do in \verb!_darcs/prefs/sources!,-such as create read-only caches and even set a-primary source repository above any used in a \verb|darcs get| or-\verb|darcs pull| command.--\section{Distributed development with one primary developer}-\label{darcs-development-practices}--This is how a project with many contributors, but every contribution is reviewed-and manually applied by the project leader, can be run.-For this sort of a situation, \verb|darcs send| is ideal, since the barrier for-contributions is very low, which helps encourage contributors.--One could simply set the \verb!_darcs/prefs/email! value to the project-mailing list, but you may also want to use darcs send to send your changes to the main-server, so instead the email address could be set to something like-``\verb!Darcs Repo <maintainer@host.com>!''. Then the-\verb-.procmailrc--file on the server should have the following rule:-\begin{verbatim}-:0-* ^TODarcs Repo-|(umask 022; darcs apply --reply project-mailing-list@host.com \- --repodir /path/to/repo --verify /path/to/allowed_keys)-\end{verbatim}-This causes darcs apply to be run on any email sent to ``Darcs Repo''.-\verb'apply' actually applies them only if they are signed by an-authorized key.--The central darcs repository contains the following values in its-\verb!_darcs/prefs/defaults!:-\begin{verbatim}-apply test-apply verbose-apply happy-forwarding-\end{verbatim}-The first line tells apply to always run the test suite. The test suite can-be a reason to use send rather than push, since it allows to-easily continue working (or put one's computer to sleep) while the tests are-being run on the main server. The second line is just there to improve the-email response that the maintainer gets when a patch has either been applied or failed-the tests. The third line makes darcs not complain about unsigned patches,-but just to forward them to \verb!darcs-devel!.--On one's development computer, one can have in their \verb!.muttrc! the following-alias, which allows to easily apply patches received via email-directly to one's darcs working directory:-\begin{verbatim}-macro pager A "<pipe-entry>(umask 022; darcs apply --no-test -v \- --repodir ~/darcs)"-\end{verbatim}--\section{Sending signed patches by email}--Darcs send can be configured to send a cryptographically signed patch by email.-You can then set up your mail system to have darcs verify that patches were-signed by an authorized user and apply them when a patch is received by-email. The results of the apply can be returned to the user by email.-Unsigned patches (or patches signed by unauthorized users) will be-forwarded to the repository owner (or whoever you configure them to be-forwarded to\ldots).--This method is especially nice when combined with the \verb!--test! option-of darcs apply, since it allows you to run the test suite (assuming you-have one) and reject patches that fail---and it's all done on the server,-so you can happily go on working on your development machine without-slowdown while the server runs the tests.--Setting up darcs to run automatically in response to email is by far the-most complicated way to get patches from one repository to another\ldots\ so it'll-take a few sections to explain how to go about it.--\paragraph{Security considerations}--When you set up darcs to run apply on signed patches, you should assume-that a user with write access can write to any file or directory that is-writable by the user under which the apply process runs. Unless you-specify the \verb!--no-test! flag to darcs apply (and this is \emph{not}-the default), you are also allowing anyone with write access to that-repository to run arbitrary code on your machine (since they can run a test-suite---which they can modify however they like). This is quite a-potential security hole.--For these reasons, if you don't implicitly trust your users, it is-recommended that you create a user for each repository to limit the damage-an attacker can do with access to your repository. When considering who to-trust, keep in mind that a security breach on any developer's machine could-give an attacker access to their private key and passphrase, and thus to-your repository.--\paragraph{Installing necessary programs}--You also must install the following programs: gnupg, a mailer configured to-receive mail (e.g.\ exim, sendmail or postfix), and a web server (usually-apache).--\paragraph{Granting access to a repository}--You create your gpg key by running (as your normal user):-\begin{verbatim}-$ gpg --gen-key-\end{verbatim}-You will be prompted for your name and email address, among other options.-%%To add your public key to the allowed keys keyring.-Of course, you can-skip this step if you already have a gpg key you wish to use.--You now need to export the public key so we can tell the patcher about it.-You can do this with the following command (again as your normal user):-\begin{verbatim}-$ gpg --export "email@address" > /tmp/exported_key-\end{verbatim}-And now we can add your key to the \verb!allowed_keys!:-\begin{verbatim}-(as root)> gpg --keyring /var/lib/darcs/repos/myproject/allowed_keys \- --no-default-keyring --import /tmp/exported_key-\end{verbatim}-You can repeat this process any number of times to authorize multiple users-to send patches to the repository.--You should now be able to send a patch to the repository by running as your-normal user, in a working copy of the repository:-\begin{verbatim}-$ darcs send --sign http://your.computer/repos/myproject-\end{verbatim}-You may want to add ``send sign'' to the file \verb!_darcs/prefs/defaults!-so that you won't need to type \verb!--sign! every time you want to-send\ldots--If your gpg key is protected by a passphrase, then executing \verb!send!-with the \verb!--sign! option might give you the following error:-\begin{verbatim}-darcs failed: Error running external program 'gpg'-\end{verbatim}-The most likely cause of this error is that you have a misconfigured-gpg that tries to automatically use a non-existent gpg-agent-program. GnuPG will still work without gpg-agent when you try to sign-or encrypt your data with a passphrase protected key. However, it will-exit with an error code 2 (\verb!ENOENT!) causing \verb!darcs! to-fail. To fix this, you will need to edit your \verb!~/.gnupg/gpg.conf!-file and comment out or remove the line that says:-\begin{verbatim}-use-agent-\end{verbatim}-If after commenting out or removing the \verb!use-agent! line in your-gpg configuration file you still get the same error, then you probably-have a modified GnuPG with use-agent as a hard-coded option. In that-case, you should change \verb!use-agent! to \verb!no-use-agent! to-disable it explicitly.--\paragraph{Setting up a sendable repository using procmail}-If you don't have root access on your machine, or perhaps simply don't want-to bother creating a separate user, you can set up a darcs repository using-procmail to filter your mail. Let us assume that you already use procmail-to filter your email. If not, you will need to read up on it, or perhaps-should use a different method for routing the email to darcs.--To begin with, you must configure your repository so that a darcs send to-your repository will know where to send the email. Do this by creating a-file in \verb!/path/to/your/repo/_darcs/prefs! called \verb!email!-containing your email address. As a trick (to be explained below), we will-create the email address with ``darcs repo'' as your name, in an email-address of the form ``User Name $<$user@host.com$>$.''-\begin{verbatim}-$ echo 'my darcs repo <user@host.com>' \- > /path/to/your/repo/_darcs/prefs/email-\end{verbatim}--The next step is to set up a gnupg keyring containing the public keys of-people authorized to send to your repository. Here is a second way of-going about this (see above for the first). This time let us assume you-want to give someone write access to your repository. You can do this by:-\begin{verbatim}-gpg --no-default-keyring \- --keyring /path/to/the/allowed_keys --recv-keys FFFFFFFF-\end{verbatim}-With ``FFFFFFFF'' being the ID of the gpg key of the person to be-authorised, if this person has uploaded their key to the gpg keyservers.-Actually, this also requires that-you have configured gpg to access a valid keyserver. You can, of course,-repeat this command for all keys you want to allow access to.--Finally, we add a few lines to your \verb!.procmailrc!:-\begin{verbatim}-:0-* ^TOmy darcs repo-|(umask 022; darcs apply --reply user@host.com \- --repodir /path/to/your/repo --verify /path/to/the/allowed_keys)-\end{verbatim}-The purpose for the ``my darcs repo'' trick is partially to make it easier-to recognize patches sent to the repository, but is even more crucial to-avoid nasty bounce loops by making the \verb!--reply! option have an email-address that won't go back to the repository. This means that unsigned-patches that are sent to your repository will be forwarded to your ordinary-email.--Like most mail-processing programs, Procmail by default sets a tight umask.-However, this will prevent the repository from remaining world-readable;-thus, the ``umask 022'' is required to relax the umask.-(Alternatively, you could set Procmail's global \verb!UMASK! variable-to a more suitable value.)--\paragraph{Checking if your e-mail patch was applied}--After sending a patch with \verb!darcs send!, you may not receive any feedback,-even if the patch is applied. You can confirm whether or not your patch was applied-to the remote repository by pointing \verb!darcs changes! at a remote repository:-\begin{verbatim}-darcs changes --last=10 --repo=http://darcs.net/-\end{verbatim}--That shows you the last 10 changes in the remote repository. You can adjust the options given-to \verb!changes! if a more advanced query is needed.--
− doc/src/building_darcs.tex
@@ -1,33 +0,0 @@-\chapter{Building darcs}-If your distribution provides a pre-built binary package of a recent-Darcs release, you are strongly encouraged to use that rather than-building Darcs yourself.--If you have (or can install) the-\htmladdnormallinkfoot{Haskell Platform}{http://haskell.org/platform/}-this is the next best option, as this will resolve build dependencies-automatically. To download, compile and install Darcs and its-dependencies via \texttt{cabal-install}, the build tool provided by the-Haskell Platform, simply run-\begin{verbatim}-cabal update-cabal install darcs-\end{verbatim}--If you cannot install the Haskell Platform or \texttt{cabal-install}, you need to run-\begin{verbatim}-ghc --make Setup-./Setup configure-./Setup build-./Setup install-\end{verbatim}--This will require the following build dependencies:-\begin{itemize}-\item GHC 6.10 or higher; and-\item Cabal 1.6 or higher.-\end{itemize}--Additional build dependencies are declared in the \texttt{darcs.cabal}-file, and \texttt{./Setup configure} will tell you if any required-build dependencies aren't found.
− doc/src/configuring_darcs.tex
@@ -1,472 +0,0 @@-% Copyright (C) 2004 David Roundy-%-% This program is free software; you can redistribute it and/or modify-% it under the terms of the GNU General Public License as published by-% the Free Software Foundation; either version 2, or (at your option)-% any later version.-%-% This program is distributed in the hope that it will be useful,-% but WITHOUT ANY WARRANTY; without even the implied warranty of-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the-% GNU General Public License for more details.-%-% You should have received a copy of the GNU General Public License-% along with this program; if not, write to the Free Software Foundation,-% Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.--\chapter{Configuring darcs}\label{configuring}--There are several ways you can adjust darcs' behavior to suit your needs.-The first is to edit files in the \verb!_darcs/prefs/! directory of a-repository. Such configuration only applies when working with that-repository. To configure darcs on a per-user rather than per-repository-basis (but with essentially the same methods), you can edit (or create)-files in the \verb!~/.darcs/! directory.-Finally, the behavior of some darcs commands can be modified by setting-appropriate environment variables.--\paragraph{Microsoft Windows}\label{ms_win}--The global darcs directory is \verb!%APPDATA%\darcs\!. This typically expands to-\texttt{C:\textbackslash{}Documents And Settings\textbackslash{}\emph{user}\textbackslash{}Application Data\textbackslash{}darcs\textbackslash{}}.-This folder contains the cache, as well as all the per-user-settings files: preferences, boring etc... These will became the new defaults-that can be overridden on per-repository basis.--\section{prefs}--The \verb!_darcs! directory contains a \verb!prefs! directory. This-directory exists simply to hold user configuration settings specific to-this repository. The contents of this directory are intended to be-modifiable by the user, although in some cases a mistake in such a-modification may cause darcs to behave strangely.--\paragraph{defaults}\label{defaults}--Default values for darcs commands can be configured on a per-repository-basis by editing (and possibly creating) the \verb!_darcs/prefs/defaults!-file. Each line of this file has the following form:-\begin{verbatim}-COMMAND FLAG VALUE-\end{verbatim}-where \verb!COMMAND! is either the name of the command to which the default-applies, or \verb!ALL! to indicate that the default applies to all commands-accepting that flag. The \verb!FLAG! term is the name of the long argument-option without the ``\verb!--!'', i.e.\ \verb!verbose! rather than-\verb!--verbose!. Finally, the \verb!VALUE! option can be omitted if the-flag is one such as \verb!verbose! that doesn't involve a value.-If the value has spaces in it, use single quotes, not double quotes, to surround it.-Each line only takes one flag. To set multiple defaults for the same-command (or for \verb!ALL! commands), use multiple lines.--Note that the use of \verb|ALL| easily can have unpredicted consequences,-especially if commands in newer versions of darcs accepts flags that they-didn't in previous versions. A command like \verb|obliterate| could be-devastating with the ``wrong'' flags (for example --all). Only use safe-flags with \verb|ALL|.--\begin{tabular}{ll}-{\tt \verb!~/.darcs/defaults!} & provides defaults for this user account- (for MS Windows, see ~\ref{ms_win}) \\-{\tt \verb!repo/_darcs/prefs/defaults!} & provides defaults for one project,\\- & overrules changes per user \\-\end{tabular}--For example, if your system clock is bizarre, you could instruct darcs to-always ignore the file modification times by adding the following line to-your \verb!_darcs/prefs/defaults! file. (Note that this would have to be-done for each repository!)-\begin{verbatim}-ALL ignore-times-\end{verbatim}--If you never want to run a test when recording to a particular repository-(but still want to do so when running-\verb'check' on that repository), and like to name-all your patches ``Stupid patch'', you could use the following:-\begin{verbatim}-record no-test-record patch-name Stupid patch-\end{verbatim}--If you would like a command to be run every time patches are recorded-in a particular repository (for example if you have one central-repository, that all developers contribute to), then you can set apply-to always run a command when apply is successful. For example, if you-need to make sure that the files in the repository have the correct-access rights you might use the following. There are two things-to note about using darcs this way:-\begin{itemize}-\item Without the second line you will get errors, because the sub- process that runs apply cannot prompt interactively.-\item Whatever script is run by the post apply command should not be- added to the repository with \verb!darcs add!; doing so would- allow people to modify that file and then run arbitrary scripts on- your main repository, possibly damaging or violating security.-\end{itemize}-\begin{verbatim}-apply posthook chmod -R a+r *-apply run-posthook-\end{verbatim}--Similarly, if you need a command to run automatically before darcs-performs an action you can use a prehook. Using prehooks it could be-possible to canonicalize line endings before recording patches.--There are some options which are meant specifically for use in-\verb!_darcs/prefs/defaults!. One of them is \verb!--disable!. As the name-suggests, this option will disable every command that got it as argument. So,-if you are afraid that you could damage your repositories by inadvertent use of-a command like amend-record, add the following line to-\verb!_darcs/prefs/defaults!:-\begin{verbatim}-amend-record disable-\end{verbatim}--Also, a global preferences file can be created with the name-\verb!.darcs/defaults! in your home directory, on MS Windows~\ref{ms_win}.-Options present there will be added to the repository-specific preferences.-If they conflict with repository-specific options, the repository-specific-ones will take precedence.--\paragraph{repos}-The \verb!_darcs/prefs/repos! file contains a list of repositories you have-pulled from or pushed to, and is used for autocompletion of pull and push-commands in bash. Feel free to delete any lines from this list that might-get in there, or to delete the file as a whole.--\paragraph{author}\label{author_prefs}-The \verb!_darcs/prefs/author! file contains the email address (or name) to-be used as the author when patches are recorded in this repository,-e.g.\ \verb!David Roundy <droundy@abridgegame.org>!. This-file overrides the contents of the environment variables-\verb!$DARCS_EMAIL! and \verb!$EMAIL!.--\paragraph{boring}\label{boring}-The \verb!_darcs/prefs/boring! file may contain a list of regular-expressions describing files, such as object files, that you do not expect-to add to your project. As an example, you could have:-\begin{verbatim}-\.hi$-\.o$-^\.[^/]-^_-~$-(^|/)CVS($|/)-\end{verbatim}-A newly created repository has a longer boring file that-includes many common source control, backup, temporary, and compiled files.--You may want to have the boring file under version-control. To do this you can use darcs setpref to set the value-``boringfile'' to the name of your desired boring file-(e.g.\ \verb-darcs setpref boringfile .boring-, where \verb-.boring--is the repository path of a file-that has been-darcs added to your repository). The boringfile preference overrides-\verb!_darcs/prefs/boring!, so be sure to copy that file to the boringfile.--You can also set up a ``boring'' regexps-file in your home directory, named \verb!~/.darcs/boring!,-(see \ref{ms_win} on MS Windows), which will be-used with all of your darcs repositories.--Any file not already managed by darcs and whose repository path (such-as \verb!manual/index.html!) matches any of-the boring regular expressions is considered boring. The boring file is-used to filter the files provided to darcs add, to allow you to use a-simple \verb-darcs add newdir newdir/-\verb-*- % cabal haddock barfs on adjacent / *-without accidentally adding a bunch of-object files. It is also used when the \verb!--look-for-adds! flag is-given to whatsnew or record.-Note that once a file has been added to darcs, it is not considered-boring, even if it matches the boring file filter.---\paragraph{binaries}-The \verb!_darcs/prefs/binaries! file may contain a list of regular-expressions describing files that should be treated as binary files rather-than text files. Darcs automatically treats files containing-\verb!^Z\! or \verb!'\0'! within the first 4096 bytes as being binary files.-You probably will want to have the binaries file under-version control. To do this you can use darcs setpref to set the value-``binariesfile'' to the name of your desired binaries file-(e.g.\ \verb'darcs setpref binariesfile ./.binaries', where-\verb'.binaries' is a file that has been-darcs added to your repository). As with the boring file, you can also set-up a \verb!~/.darcs/binaries! file if you like-(see \ref{ms_win} on MS Windows).--\paragraph{email}-The \verb!_darcs/prefs/email! file is used to provide the e-mail address for your-repository that others will use when they \verb!darcs send! a patch back to you.-The contents of the file should simply be an e-mail address.---\paragraph{sources}-The \verb!_darcs/prefs/sources! file is used to indicate alternative-locations from which to download patches when using a ``hashed''-repository. This file contains lines such as:-\begin{verbatim}-cache:/home/droundy/.darcs/cache-readonly:/home/otheruser/.darcs/cache-repo:http://darcs.net-\end{verbatim}-This would indicate that darcs should first look in-\verb!/home/droundy/.darcs/cache! for patches that might be missing, and if-the patch isn't there, it should save a copy there for future use. In that-case, darcs will look in \verb!/home/otheruser/.darcs/cache! to see if that-user might have downloaded a copy, but won't try to save a copy there, of-course. Finally, it will look in \verb!http://darcs.net!. Note that the-\verb!sources! file can also exist in \verb!~/.darcs/!. Also note that the-sources mentioned in your \verb!sources! file will be tried \emph{before}-the repository you are pulling from. This can be useful in avoiding-downloading patches multiple times when you pull from a remote repository-to more than one local repository.--A global cache is enabled by default in your home directory. The cache-allows darcs to avoid re-downloading patches (for example, when doing a-second darcs get of the same repository), and also allows darcs to use hard-links to reduce disk usage.--Note that the cache directory should reside on the same filesystem as your-repositories, so you may need to vary this. You can also use multiple-cache directories on different filesystems, if you have several filesystems-on which you use darcs.--\paragraph{motd}\label{motd}-The \verb!_darcs/prefs/motd! file may contain a ``message of the day''-which will be displayed to users who get or pull from the repository without the-\verb!--quiet! option.--\section{Environment variables}--There are a few environment variables whose contents affect darcs'-behavior. Here is a quick list of all the variables and their-documentation in the rest of the manual:--\begin{tabular}{|l|r|}-\hline-\textbf{Variable} & \textbf{Section} \\-\hline-DARCS\_EDITOR, EDITOR, VISUAL & \ref{env:DARCS_EDITOR} \\-DARCS\_PAGER, PAGER & \ref{env:DARCS_PAGER} \\-HOME & \ref{env:HOME} \\-TERM & \ref{env:TERM} \\-\hline-DARCS\_EMAIL, EMAIL & \ref{env:DARCS_EMAIL} \\-\hline-DARCS\_APPLY\_FOO & \ref{env:DARCS_X_FOO} \\-DARCS\_GET\_FOO & \ref{env:DARCS_X_FOO} \\-DARCS\_MGET\_FOO & \ref{env:DARCS_X_FOO} \\-DARCS\_MGETMAX & \ref{env:DARCS_MGETMAX} \\-DARCS\_PROXYUSERPWD & \ref{env:DARCS_PROXYUSERPWD} \\-DARCS\_CONNECTION\_TIMEOUT & \ref{env:DARCS_CONNECTION_TIMEOUT}\\-DARCS\_SSH & \ref{env:DARCS_SSH} \\-DARCS\_SCP & \ref{env:DARCS_SCP} \\-DARCS\_SFTP & \ref{env:DARCS_SFTP} \\-SSH\_PORT & \ref{env:SSH_PORT} \\-\hline-DARCS\_ALTERNATIVE\_COLOR & \ref{env:DARCS_ALWAYS_COLOR}\\-DARCS\_ALWAYS\_COLOR & \ref{env:DARCS_ALWAYS_COLOR}\\-DARCS\_DO\_COLOR\_LINES & \ref{env:DARCS_DO_COLOR_LINES}\\-DARCS\_DONT\_COLOR & \ref{env:DARCS_ALWAYS_COLOR} \\-DARCS\_DONT\_ESCAPE\_TRAILING\_CR & \ref{env:DARCS_DONT_ESCAPE_white}\\-DARCS\_DONT\_ESCAPE\_TRAILING\_SPACES & \ref{env:DARCS_DONT_ESCAPE_white} \\-DARCS\_DONT\_ESCAPE\_8BIT & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\-DARCS\_DONT\_ESCAPE\_ANYTHING & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\-DARCS\_DONT\_ESCAPE\_ISPRINT & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\-DARCS\_ESCAPE\_EXTRA & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\-DARCS\_DONT\_ESCAPE\_EXTRA & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\-\hline-\end{tabular}--\section{General-purpose variables}--\darcsEnv{DARCS_EDITOR}-\darcsEnv{DARCS_PAGER}-\darcsEnv{DARCS_TMPDIR}-\darcsEnv{DARCS_KEEP_TMPDIR}-\darcsEnv{HOME}--\section{Remote repositories}-\paragraph{DARCS\_CONNECTION\_TIMEOUT}-\label{env:DARCS_CONNECTION_TIMEOUT}-Set the maximum time in seconds that darcs allows and connection to-take. If the variable is not specified the default are 30 seconds. This-option only works with curl.-\darcsEnv{DARCS_SSH}-\darcsEnv{DARCS_SCP}-\darcsEnv{SSH_PORT}-\darcsEnv{HTTP_PROXY}-\darcsEnv{DARCS_PROXYUSERPWD}--\paragraph{DARCS\_GET\_FOO, DARCS\_MGET\_FOO and DARCS\_APPLY\_FOO}-\label{env:DARCS_X_FOO}-When trying to access a repository with a URL beginning foo://,-darcs will invoke the program specified by the DARCS\_GET\_FOO-environment variable (if defined) to download each file, and the-command specified by the DARCS\_APPLY\_FOO environment variable (if-defined) when pushing to a foo:// URL. --This method overrides all other ways of getting \verb!foo://xxx! URLs.--Note that each command should be constructed so that it sends the downloaded-content to STDOUT, and the next argument to it should be the URL\@. Here are some-examples that should work for DARCS\_GET\_HTTP:--\begin{verbatim}-fetch -q -o - -curl -s -f-lynx -source -wget -q -O --\end{verbatim}--Apart from such toy examples, it is likely that you will need to-manipulate the argument before passing it to the actual fetcher-program. For example, consider the problem of getting read access to-a repository on a CIFS (SMB) share without mount privileges:--\begin{verbatim}-export DARCS_GET_SMB="smbclient -c get"-darcs get smb://fs/twb/Desktop/hello-world-\end{verbatim}--The above command will not work for several reasons. Firstly, Darcs-will pass it an argument beginning with `smb:', which smbclient does-not understand. Secondly, the host and share `//fs/twb' must be-presented as a separate argument to the path `Desktop/hello-world'.-Thirdly, smbclient requires that `get' and the path be a single-argument (including a space), rather than two separate arguments.-Finally, smbclient's `get' command writes the file to disk, while-Darcs expects it to be printed to standard output.--In principle, we could get around such problems by making the variable-contain a shell script, e.g.--\begin{verbatim}-export DARCS_GET_SMB='sh -c "...; smbclient $x -c \"get $y\""'-\end{verbatim}--Unfortunately, Darcs splits the command on whitespace and does not-understand that quotation or escaping, so there is no way to make-Darcs pass the text after `-c' to sh as a single argument. Therefore,-we instead need to put such one-liners in separate, executable scripts.--Continuing our smbclient example, we create an executable script-\verb|~/.darcs/libexec/get_smb| with the following contents:--\begin{verbatim}-#!/bin/bash -e-IFS=/ read host share file <<<"${1#smb://}"-smbclient //$host/$share -c "get $file -"-\end{verbatim}--And at last we can say--\begin{verbatim}-export DARCS_GET_SMB=~/.darcs/libexec/get_smb-darcs get smb://fs/twb/Desktop/hello-world-\end{verbatim}---If set, DARCS\_MGET\_FOO-will be used to fetch many files from a single repository simultaneously.-Replace FOO and foo as appropriate to handle other URL schemes.-These commands are \emph{not} interpreted by a shell, so you cannot-use shell metacharacters, and the first word in the command must-be the name of an executable located in your path. The GET command-will be called with a URL for each file. The MGET command will be-invoked with a number of URLs and is expected to download the files-to the current directory, preserving the file name but not the path.-The APPLY command will be called with a darcs patchfile piped into-its standard input. Example:--\begin{verbatim}-wget -q -\end{verbatim}--\paragraph{DARCS\_MGETMAX}-\label{env:DARCS_MGETMAX}-When invoking a DARCS\_MGET\_FOO command, darcs will limit the-number of URLs presented to the command to the value of this variable,-if set, or 200.--These commands are \emph{not} interpreted by a shell, so you cannot use shell-meta-characters.--\section{Highlighted output}-\label{env:DARCS_ALWAYS_COLOR}-\label{env:DARCS_DO_COLOR_LINES}-\label{env:DARCS_DONT_ESCAPE_white}--If the terminal understands ANSI color escape sequences,-darcs will highlight certain keywords and delimiters when printing patches.-This can be turned off by setting the environment variable DARCS\_DONT\_COLOR to 1.-If you use a pager that happens to understand ANSI colors, like \verb!less -R!,-darcs can be forced always to highlight the output-by setting DARCS\_ALWAYS\_COLOR to 1.-If you can't see colors you can set DARCS\_ALTERNATIVE\_COLOR to 1,-and darcs will use ANSI codes for bold and reverse video instead of colors.-In addition, there is an extra-colorful mode, which is not enabled by-default, which can be activated with DARCS\_DO\_COLOR\_LINES.--By default darcs will escape (by highlighting if possible) any kind of spaces at the end of lines-when showing patch contents.-If you don't want this you can turn it off by setting-DARCS\_DONT\_ESCAPE\_TRAILING\_SPACES to 1.-A special case exists for only carriage returns:-DARCS\_DONT\_ESCAPE\_TRAILING\_CR.---\section{Character escaping and non-ASCII character encodings}-\label{env:DARCS_DONT_ESCAPE_nonascii}--Darcs needs to escape certain characters when printing patch contents to a terminal.-Characters like \emph{backspace} can otherwise hide patch content from the user,-and other character sequences can even in some cases redirect commands to the shell-if the terminal allows it.--By default darcs will only allow printable 7-bit ASCII characters (including space),-and the two control characters \emph{tab} and \emph{newline}.-(See the last paragraph in this section for a way to tailor this behavior.)-All other octets are printed in quoted form (as \verb!^<control letter>! or-\verb!\!\verb!<hex code>!).--Darcs has some limited support for locales.-If the system's locale is a single-byte character encoding,-like the Latin encodings,-you can set the environment variable DARCS\_DONT\_ESCAPE\_ISPRINT to 1-and darcs will display all the printables in the current system locale-instead of just the ASCII ones.-NOTE: This curently does not work on some architectures if darcs is-compiled with GHC~6.4 or later. Some non-ASCII control characters might be printed-and can possibly spoof the terminal.--For multi-byte character encodings things are less smooth.-UTF-8 will work if you set DARCS\_DONT\_ESCAPE\_8BIT to 1,-but non-printables outside the 7-bit ASCII range are no longer escaped.-E.g., the extra control characters from Latin-1-might leave your terminal at the mercy of the patch contents.-Space characters outside the 7-bit ASCII range are no longer recognized-and will not be properly escaped at line endings.--As a last resort you can set DARCS\_DONT\_ESCAPE\_ANYTHING to 1.-Then everything that doesn't flip code sets should work,-and so will all the bells and whistles in your terminal.-This environment variable can also be handy-if you pipe the output to a pager or external filter-that knows better than darcs how to handle your encoding.-Note that \emph{all} escaping,-including the special escaping of any line ending spaces,-will be turned off by this setting.--There are two environment variables you can set-to explicitly tell darcs to not escape or escape octets.-They are-DARCS\_DONT\_ESCAPE\_EXTRA and DARCS\_ESCAPE\_EXTRA.-Their values should be strings consisting of the verbatim octets in question.-The do-escapes take precedence over the dont-escapes.-Space characters are still escaped at line endings though.-The special environment variable DARCS\_DONT\_ESCAPE\_TRAILING\_CR-turns off escaping of carriage return last on the line (DOS style).
− doc/src/darcs.tex
@@ -1,1538 +0,0 @@-% Copyright (C) 2002-2003 David Roundy-%-% This program is free software; you can redistribute it and/or modify-% it under the terms of the GNU General Public License as published by-% the Free Software Foundation; either version 2, or (at your option)-% any later version.-%-% This program is distributed in the hope that it will be useful,-% but WITHOUT ANY WARRANTY; without even the implied warranty of-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the-% GNU General Public License for more details.-%-% You should have received a copy of the GNU General Public License-% along with this program; see the file COPYING. If not, write to-% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,-% Boston, MA 02110-1301, USA.--\documentclass[oneside]{book}-%\usepackage{color}--\usepackage{fullpage}-\usepackage{verbatim}-\usepackage{html}-\usepackage{fancyvrb}-\newenvironment{code}{\comment}{\endcomment}-% \newenvironment{code}{\color{blue}\verbatim}{\endverbatim}--\begin{document}---% Definition of title page:-\title{Darcs User Manual}-\date{-\darcsVersion-} % icky newline before closing brace is to appease preproc.hs.-\author{David Roundy}--\maketitle--\tableofcontents--\chapter{Introduction}--This manual provides a stable documentation for using darcs.-To find more up-to-date and complementary information, please consult the-\htmladdnormallinkfoot{darcs wiki}{http://wiki.darcs.net}.--Darcs is a revision control system, along the lines of Subversion, Git or-Mercurial. That means that it keeps track of various revisions and branches of your-project, allows for changes to propagate from one branch to another. Darcs has two-particularly distinctive features which differ from other revision control-systems:--\paragraph{Every source tree a branch}-The primary simplifying notion of darcs is that \emph{every} copy of your-source code is a full repository. This is dramatically different from Subversion,-in which the normal usage is for there to be one central repository from-which source code will be checked out.-This has several advantages, since you can harness the full-power of darcs in any scratch copy of your code, without committing your-possibly destabilizing changes to a central repository.--\paragraph{Darcs keeps track of changes rather than versions}--In the world of darcs, the source tree is \emph{not} the fundamental-object, but rather the patch is the fundamental object. Rather than a-patch being defined in terms of the difference between two trees, a tree is-defined as the result of applying a given set of patches to an empty tree.-Moreover, these patches may be reordered without changing the tree.-This makes many operations, like cherry-picking or merging, much more natural.--\input{features.tex}--\chapter{Getting started}--This chapter will lead you through an example use of darcs, which hopefully-will allow you to get started using darcs with your project.--\section{Creating your repository}--Creating your repository in the first place just involves telling darcs to-create the special directory (called {\tt \_darcs}) in your project tree,-which will hold the revision information. This is done by simply calling-from the root directory of your project:-\begin{verbatim}-$ cd my_project/-$ darcs initialize-\end{verbatim}-This creates the \verb|_darcs| directory and populates it with whatever-files and directories are needed to describe an empty project. You now-need to tell darcs what files and directories in your project should be-under revision control. You do this using the command \verb|darcs add|:-\begin{verbatim}-$ darcs add *.c Makefile.am configure.ac-\end{verbatim}-When you have added all your files (or at least, think you have), you will-want to record your changes. ``Recording'' always includes adding a note-as to why the change was made, or what it does. In this case, we'll just-note that this is the initial version.-\begin{verbatim}-$ darcs record --all-What is the patch name? Initial revision.-\end{verbatim}-Note that since we didn't specify a patch name on the command line we were-prompted for one. If the environment variable `EMAIL' isn't set, you will-also be prompted for your email address. Each patch that is recorded is-given a unique identifier consisting of the patch name, its creator's email-address, the date when it was created, and a random hash.--\section{Making changes}--Now that we have created our repository, make a change to one or more of-your files. After making the modification run:-\begin{verbatim}-$ darcs whatsnew-\end{verbatim}-This should show you the modifications that you just made, in the darcs-patch format. If you prefer to see your changes in a different format,-read Section~\ref{whatsnew}, which describes the whatsnew command in-detail.--Let's say you have now made a change to your project. The next thing to do-is to record a patch. Recording a patch consists of grouping together a-set of related changes, and giving them a name. It also tags the patch-with the date it was recorded and your email address.--To record a patch simply type:-\begin{verbatim}-$ darcs record-\end{verbatim}-darcs will then prompt you with all the changes that you have made that-have not yet been recorded, asking you which ones you want to include in-the new patch. Finally, darcs will ask you for a name for the patch.--You can now rerun whatsnew, and see that indeed the changes you have-recorded are no longer marked as new.--\section{Making your repository visible to others}-How do you let the world know about these wonderful changes? Obviously,-they must be able to see your repository. Currently the easiest way to do-this is is to look for-\htmladdnormallinkfoot{hosting services}{http://wiki.darcs.net/Hosting}-for darcs repositories.--You can also self-host your repositories by using any web server.-The recommended way to do-this (using apache in a UNIX environment) is to create a directory called-{\tt /var/www/repos}, and then put a symlink to your repository there:-\begin{verbatim}-$ cd /var/www/repos-$ ln -s /home/username/myproject .-\end{verbatim}--\section{Getting changes made to another repository}-Ok, so your repository is browsable using any web browser\ldots\ so-what? How does one get your changes into \emph{their} repository, where they can-do some good? It couldn't be easier. One just \verb|cd| into their repository,-and there type:-\begin{verbatim}-$ darcs pull http://your.server.org/repos/yourproject-\end{verbatim}-Darcs will check to see if you have recorded any changes that aren't in their-current repository. If so, it'll prompt them for each one, to see which ones-one want to add to their repository. Note that you may see a different series-of prompts depending on your answers, since sometimes one patch depends on-another, so if you answer yes to the first one, you won't be prompted for-the second if the first depends on it.--Of course, maybe people don't even have a copy of your repository. In that case-they'd want to do a-\begin{verbatim}-$ darcs get http://your.server.org/repos/yourproject-\end{verbatim}-which gets the whole repository.--Get, pull and push also work over ssh. Ssh-paths are of the same form-accepted by scp, namely \verb|[username@]host:/path/to/repository|.--\section{Moving patches from one repository to another}--Darcs is flexible as to how you move patches from one repository to another.-This section will introduce all the ways you can get patches from one place-to another, starting with the simplest and moving to the most complicated.--\subsection{Push}--If you use ssh, you can use the push method to transfer changes.-Push can also be used when the target repository is local, in which case-ssh isn't needed.--Note that you can use push to administer a multiple-user repository. You-just need to create a user for the repository (or repositories), and give-everyone with write access ssh access, perhaps using-\verb!.ssh/authorized_keys!. Then they run-\begin{verbatim}-$ darcs push repouser@repo.server:repo/directory-\end{verbatim}--If you like this idea about creating a repository user to own a repository-which is writable by a number of users, you have one other option.--Push \verb!--apply-as! can run on either a local repository or one accessed-with ssh, but uses \verb!sudo! to run a darcs apply command (having created-a patch bundle as in send) as another user. You can add the following line-in your \verb|sudoers| file to allow the users to apply their patches to a-centralized repository:-{\small-\begin{verbatim}-ALL ALL = (repo-user) NOPASSWD: /usr/bin/darcs apply --all --repodir /repo/path*-\end{verbatim}-}-This method is ideal for a centralized repository when all the users have-accounts on the same computer, if you don't want your users to be able to-run arbitrary commands as repo-user.--\subsection{All pulls}--This method involves making each-repository readable (by http, ftp, nfs-mounted disk, or a public web hosting), and you-run \verb|darcs pull| in the repository you want to move the patch to. This is nice,-as it doesn't require you to give write access to anyone else, and is-reasonably simple.--\subsection{Send and apply manually}--Sometimes the push method is impossible because the owner of the main repository-does not want or cannot create a user to write into it, and you cannot use the all-pull-method because you cannot set up a web server on your machine, perhaps because-it's behind a firewall or perhaps for security reasons, or because it is often-turned off. In this case you can use-\verb|darcs send|-from that computer to generate a patch bundle for the remote-repository. You can either let darcs email the patch for you, or save it-as a file and transfer it by hand. Then in the destination repository-the owner of that repository runs \verb|darcs apply| to apply the patches contained-in the bundle. This is also quite a simple method since, like the all-pull-method, it doesn't require that you give anyone write access to your-repository. But it's less convenient, since the owner of the remote repository has-to keep track of the patch bundle (in the email, or whatever).--To use the send and apply method with email, the best is probably to create a-\verb!_darcs/prefs/email! file in the target repository containing the email-address of the maintainer.-This way anyone who sends to this repository will automatically send the-patch bundle to that email address.--If you receive many patches by email, you probably will benefit by running-darcs apply directly from your mail program. You can place in your \verb!.muttrc!-the following:-\begin{verbatim}-auto_view text/x-patch text/x-darcs-patch-macro pager A "<pipe-entry>darcs apply --verbose --mark-conflicts \- --reply droundy@abridgegame.org --repodir ~/darcs"-\end{verbatim}-which will allow you to view a sent patch, and then apply the patch directly from \verb!mutt!, sending a-confirmation email to the person who sent you the patch. The autoview line relies on on the following-lines, or something like them, being present in one's \verb!.mailcap!:-\begin{verbatim}-text/x-patch; cat; copiousoutput-text/x-darcs-patch; cat; copiousoutput-\end{verbatim}--\input{configuring_darcs.tex}--\input{best_practices.tex}--\chapter{Darcs commands}--The general format of a darcs command is-\begin{verbatim}-% darcs COMMAND OPTIONS ARGUMENTS ...-\end{verbatim}-Here \verb|COMMAND| is a command such as \verb|add| or \verb|record|, which of-course may have one or more arguments. Options have the form-\verb!--option! or \verb!-o!, while arguments vary from command to-command. There are many options which are common to a number of different-commands, which will be summarized here.--If you wish, you may use any unambiguous beginning of a command name as a-shortcut: for \verb!darcs record!, you could type \verb!darcs recor! or-\verb!darcs rec!, but not \verb!darcs re! since that could be confused with-\verb!darcs replace!, \verb!darcs revert! and \verb!darcs remove!.--In some cases, \verb|COMMAND| actually consists of two words, a-super-command and a subcommand. For example, the ``display the-manifest'' command has the form \verb|darcs query manifest|.--\paragraph{Command overview}--Not all commands modify the ``patches'' of your repository (that-is, the named patches which other users can pull); some commands only-affect the copy of the source tree you're working on (your ``working-directory''), and some affect both. This table summarizes what you should-expect from each one and will hopefully serve as guide when you're having-doubts about which command to use.--\begin{center}-\footnotetext[1]{But it affects the repository and working directory targeted- by the push}-\footnotetext[2]{As for the other end, see apply}-\begin{tabular}{|c|c|c|}-\hline-affects & patches & working directory\\-\hline-record & yes & no\\-\hline-unrecord & yes & no\\-\hline-rollback & yes & yes\\-\hline-revert & no & yes\\-\hline-unrevert & no & yes\\-\hline-pull & yes & yes\\-\hline-obliterate & yes & yes\\-\hline-apply & yes & yes\\-\hline-push\footnote{But it affects the repository and working directory targeted by-the push} & no & no\\-\hline-send\footnote{As for the other end, see apply} & no & no\\-\hline-put\footnote{Creates a new repository} & no & no\\-\hline-\end{tabular}-\end{center}--\section{Common options to darcs commands}--\begin{options}---help-\end{options}-Every \verb|COMMAND| accepts \verb!--help! as an argument, which tells it to-provide a bit of help. Among other things, this help always provides an-accurate listing of the options available with that command, and is-guaranteed never to be out of sync with the version of darcs you actually-have installed (unlike this manual, which could be for an entirely-different version of darcs).-\begin{verbatim}-% darcs COMMAND --help-\end{verbatim}--\begin{options}---disable-\end{options}-Every {\tt COMMAND} accepts the \verb!--disable! option, which can be used in-\verb!_darcs/prefs/defaults! to disable some commands in the repository. This-can be helpful if you want to protect the repository from accidental use of-advanced commands like obliterate, unpull, unrecord or amend-record.--\begin{options}---verbose, --quiet, --normal-verbosity-\end{options}-Most commands also accept the \verb!--verbose! option, which tells darcs to-provide additional output. The amount of verbosity varies from command to-command. Commands that accept \verb!--verbose! also accept \verb!--quiet!,-which surpresses non-error output, and \verb!--normal-verbosity! which can be-used to restore the default verbosity if \verb!--verbose! or \verb!--quiet! is in-the defaults file.--\begin{options}---debug, --debug-http-\end{options}-Many commands also accept the \verb!--debug! option, which causes darcs to generate-additional output that may be useful for debugging its behavior, but which otherwise-would not be interesting. Option \verb!--debug-http! makes darcs output debugging-info for libcurl.--\begin{options}---repodir-\end{options}-Another common option is the \verb!--repodir! option, which allows you to-specify the directory of the repository in which to perform the command.-This option is used with commands, such as whatsnew, that ordinarily would-be performed within a repository directory, and allows you to use those-commands without actually being in the repository directory when calling the-command. This is useful when running darcs in a pipe, as might be the case-when running \verb'apply' from a mailer.--\begin{options}---remote-repo-\end{options}--Some commands, such as \verb'pull' require a remote repository to be specified,-either from the command line or as a default. The \verb!--remote-repo!-provides an alternative way to supply this remote repository path. This flag-can be seen as temporarily ``replacing'' the default repository. Setting it-causes the command to ignore the default repository (it also does not affect,-i.e. overwrite the default repository). On the other hand, if any other-repositories are supplied as command line arguments, this flag will be ignored-(and the default repository may be overwritten).---\paragraph{Selecting patches}\label{selecting}--Many commands operate on a patch or patches that have already been recorded.-There are a number of options that specify which patches are selected for-these operations: \verb!--patch!, \verb!--match!, \verb!--tag!, and variants-on these, which for \verb!--patch! are \verb!--patches!,-\verb!--from-patch!, and \verb!--to-patch!. The \verb!--patch! and-\verb!--tag! forms simply take (POSIX extended, aka \verb!egrep!) regular-expressions and match them against tag and patch names. \verb!--match!,-described below, allows more powerful patterns.--The plural forms of these options select all matching patches. The singular-forms select the last matching patch. The range (from and to) forms select-patches after or up to (both inclusive) the last matching patch.--These options use the current order of patches in the repository. darcs may-reorder patches, so this is not necessarily the order of creation or the-order in which patches were applied. However, as long as you are just-recording patches in your own repository, they will remain in order.--% NOTE --no-deps is implemented in SelectChanges.lhs, but documented here-% for concistency.-When a patch or a group of patches is selected, all patches they depend on-get silently selected too. For example: \verb!darcs pull --patches bugfix!-means ``pull all the patches with `bugfix' in their name, along with any-patches they require.'' If you really only want patches with `bugfix' in-their name, you should use the \verb!--no-deps! option, which makes darcs-exclude any matched patches from the selection which have dependencies that-are themselves not explicitly matched by the selection.--For \verb!unrecord!, \verb!unpull! and \verb!obliterate!, patches that-depend on the selected patches are silently included, or if-\verb!--no-deps! is used selected patches with dependencies on not selected-patches are excluded from the selection.---\subsection{Match}--Currently \verb!--match! accepts eight primitive match types, although-there are plans to expand it to match more patterns. Also, note that the-syntax is still preliminary and subject to change.--The first match type accepts a literal string which is checked against-the patch name. The syntax is-\begin{verbatim}-darcs annotate --summary --match 'exact foo+bar'-\end{verbatim}-This is useful for situations where a patch name contains characters that-could be considered special for regular expressions.--In this and the other match types, the argument must be enclosed in double-quotes if it contains spaces. You can escape a quote in the argument with a-backslash; backslash escapes itself, but it is treated literally if followed-by a character other than a double quote or backslash, so it is typically not-necessary to escape a backslash. No such escaping is necessary unless the-argument is enclosed in double quotes.--The second match type accepts a regular expression which is checked against-the patch name. The syntax is-\begin{verbatim}-darcs annotate --summary --match 'name foo'-\end{verbatim}-Note that to match regexp metacharacters, such as \verb|(|, literally, they-must be escaped with backslash along with any embedded double quotes. To-match a literal backslash it must be written quadrupled in general, but often-it need not be escaped, since backslash is only special in regexps when-followed by a metacharacter. In the following example pairs, the first-literal is matched by the second sequence in the match name:-``\verb|"|'':``\verb|\"|'', ``\verb|\|'':``\verb|\\\\|'',-``\verb|\x|'':``\verb|\x|'', ``\verb|(|'':``\verb|\(|''.--The third match type matches the darcs hash for each patch:-\begin{verbatim}-darcs annotate --summary --match \- 'hash 20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef'-\end{verbatim}-Note you need to provide the full hash string as above.-This is intended to be used, for example, by programs allowing you to view-darcs repositories (e.g.\ CGI scripts like viewCVS).--The fourth match type accepts a regular expression which is checked against-the patch author. The syntax is-\begin{verbatim}-darcs annotate --summary --match 'author foo'-\end{verbatim}--There is also support for matching by date. This is done using commands such as-\begin{verbatim}-darcs annotate --summary --match 'date "last week"'-darcs annotate --summary --match 'date yesterday'-darcs annotate --summary --match 'date "today 14:00"'-darcs annotate --summary --match 'date "tea time yesterday"'-darcs annotate --summary --match 'date "3 days before last year at 17:00"'-darcs changes --from-match 'date "Sat Jun 30 11:31:30 EDT 2004"'-\end{verbatim}--Only English date specifications are supported---specifically you must use-English day and month names. Also, only a limited set of time zones is-supported (compatible with GNU coreutils' date parsing). Unrecognized zones-are treated as UTC, which may result in the timestamps printed in change-entries not being recognized by the date matching. You can avoid this problem-on a POSIX-like system by running darcs in the UTC zone to get the times-initially, e.g.:-\begin{verbatim}-TZ=UTC darcs changes-\end{verbatim}--When matching on the ISO format, a partial date is treated as a range.-English dates can either refer to a specific day (``6 months ago',``day before-yesterday''), or to an interval-from some past date (``last month'') to the present. Putting this all-together, if today is ``2004-07-24'' then the following matches should work:--\begin{tabular}{|ll|}-\hline-\textbf{date} & \textbf{patches selected} \\-\hline-2004 & from 2004-01-01 up to and including 2004-12-31 \\-2004-01 & from 2004-01-01 up to and including 2004-01-31 \\-2004-01-01 & during 2004-01-01 \\-\hline-today & during 2004-07-24 (starting midnight in your timezone) \\-yesterday & during 2004-07-23 \\-6 months ago & during 2004-01-23 \\-\hline-last 6 months & since 2004-01-23 \\-last month & since 2004-06-23 (not 2004-06-01!) \\-last week & since 2004-07-16 \\-\hline-\end{tabular}--For more precise control, you may specify an interval, either-in a small subset of English or-of \htmladdnormallinkfoot{the ISO 8601 format}{http://www.w3.org/TR/NOTE-datetime}.-If you use the ISO format, note that durations, when-specified alone, are interpreted as being relative to the current date and time.-\begin{verbatim}-darcs annotate --summary --match 'date "between 2004-03-12 and last week"'-darcs annotate --summary --match 'date "after 2005"'-darcs annotate --summary --match 'date "in the last 3 weeks"'-darcs annotate --summary --match 'date "P3M/2006-03-17"'-darcs annotate --summary --match 'date "2004-01-02/2006-03-17"'-darcs annotate --summary --match 'date "P2M6D"'-\end{verbatim}--You may also prefer to combine date matching with a more specific pattern.-\begin{verbatim}-darcs annotate --summary --match 'date "last week" && name foo'-\end{verbatim}--The sixth match type accepts a regular expression which is checked against-file paths that the patch touches. The syntax is-\begin{verbatim}-darcs annotate --summary --match 'touch foo/bar.c'-\end{verbatim}--The seventh match type accepts a regular expression which is checked-against every hunk. The syntax is-\begin{verbatim}-darcs annotate --summary --match 'hunk "^instance .* Foo where$"'-\end{verbatim}--The eight match type accepts a regular expression which is checked-against the long comment. The syntax is-\begin{verbatim}-darcs annotate --summary --match 'comment "remote repository"'-\end{verbatim}--The \verb!--match! pattern can include the logical operators \verb!&&!,-\verb!||! and \verb!not!, as well as grouping of patterns with parentheses.-For example-\begin{verbatim}-darcs annotate --summary --match 'name record && not name overrode'-\end{verbatim}--\begin{options}---ignore-times, --no-ignore-times-\end{options}-Darcs optimizes its operations by keeping track of the modification times-of your files. This dramatically speeds up commands such as-\verb!whatsnew! and \verb!record! which would otherwise require reading-every file in the repository and comparing it with a reference version. However,-there are times when this can cause problems, such as when running a series-of darcs commands from a script, in which case often a file will be-modified twice in the same second, which can lead to the second-modification going unnoticed. The solution to such predicaments is the-\verb!--ignore-times! option, which instructs darcs not to trust the file-modification times, but instead to check each file's contents explicitly.---\begin{options}---author-\end{options}-\darcsEnv{DARCS_EMAIL}--\begin{options}---dont-compress, --compress-\end{options}-By default, darcs commands that write patches to disk will compress the-patch files. If you don't want this, you can choose the-\verb!--dont-compress! option, which causes darcs not to compress the patch-file.--\begin{options}---dry-run-\end{options}-The \verb!--dry-run! option will cause darcs not to actually take the specified-action, but only print what would have happened. Not all commands accept-\verb!--dry-run!, but those that do should accept the \verb!--summary! option.--\begin{options}---summary, --no-summary-\end{options}-The \verb!--summary! option shows a summary of the patches that would have been-pulled/pushed/whatever. The format is similar to the output format of-\verb!cvs update! and looks like this:--\begin{verbatim}-A ./added_but_not_recorded.c-A! ./added_but_not_recorded_conflicts.c-a ./would_be_added_if_look_for_adds_option_was_used.h--M ./modified.t -1 +1-M! ./modified_conflicts.t -1 +1--R ./removed_but_not_recorded.c-R! ./removed_but_not_recorded_conflicts.c--\end{verbatim}--You can probably guess what the flags mean from the clever file names.-\begin{description}-\item{\texttt{A}} is for files that have been added but not recorded yet.-\item{\texttt{a}} is for files found using the \verb!--look-for-adds! option available for-\verb!whatsnew! and \verb!record!. They have not been added yet, but would be-added automatically if \verb!--look-for-adds! were used with the next-\verb!record! command.--\item{\texttt{M}} is for files that have been modified in the working directory but not-recorded yet. The number of added and subtracted lines is also shown.--\item{\texttt{R}} is for files that have been removed, but the removal is not-recorded yet.-\end{description}-An exclamation mark appears next to any option that has a conflict.---\paragraph{Resolution of conflicts}\label{resolution}--To resolve conflicts using an external tool, you need to specify a command-to use, e.g.-\begin{verbatim}---external-merge 'opendiff %1 %2 -ancestor %a -merge %o'-\end{verbatim}-The \verb!%1! and \verb!%2! are replaced with the two versions to be-merged, \verb!%a! is replaced with the common ancestor of the two versions.-Most importantly, \verb!%o! is replaced with the name of the output file-that darcs will require to be created holding the merged version. The-above example works with the FileMerge.app tool that comes with Apple's-developer tools. To use xxdiff, you would use-\begin{verbatim}---external-merge 'xxdiff -m -O -M %o %1 %a %2'-\end{verbatim}-To use \verb!kdiff3!, you can use-\begin{verbatim}---external-merge 'kdiff3 --output %o %a %1 %2'-\end{verbatim}-To use \verb!tortoiseMerge!, you can use-\begin{verbatim}---external-merge 'tortoiseMerge /base:"%a" /mine:"%1" /theirs:"%2" /merged:"%o"'-\end{verbatim}-(\verb!tortoiseMerge! is a nice merge tool that comes with TortoiseSVN and works well-on Windows.)--% Fixme: Is it actually a shell command on MS Windows?-Note that the command is split into space-separated words and the first one is-\verb!exec!ed with the rest as arguments---it is not a shell command. In particular,-on Windows this means that the first command path should not contain spaces and-you should make sure the command is in your \verb!PATH!.--The substitution of the \verb!%! escapes is done everywhere. If you need to prevent-substitution you can use a double percentage sign, i.e. \verb!%%a! is substituted with-\verb!%a!. Here is an example script to use the Emacs' Ediff package for merging.-% This is indented so that the leading #s don't confuse the preprocessor.-\begin{verbatim}- #! /bin/sh- # External merge command for darcs, using Emacs Ediff, via server if possible.- # It needs args %1 %2 %a %o, i.e. the external merge command is, say,- # `emerge3 %1 %2 %a %o'.- test $# -eq 4 || exit 1- form="(ediff-merge-files-with-ancestor"- while test $# -gt 0; do- count=$count.- if [ $count = .... ]; then- form=$form\ nil # Lisp STARTUP-HOOKS arg- fi- case $1 in # Worry about quoting -- escape " and \- *[\"\\]* ) form=$form\ \"$(echo $1 | sed -e's/["\\]/\\\0/g')\" ;;- *) form=$form\ \"$1\" ;;- esac- shift- done- form=$form')'- ( emacsclient --eval "$form" || # Emacs 22 server- gnudoit "$form" || # XEmacs/Emacs 21 server- emacs --eval "$form" || # Relatively slow to start up- xemacs -eval "$form" # Horribly slow to start up- ) 2>/dev/null-\end{verbatim}-It would be invoked like:-\begin{verbatim}---external-merge 'emerge3 %1 %2 %a %o'-\end{verbatim}--Note that if you do use an external merge tool, most likely you will want-to add to your defaults file-(\verb!_darcs/prefs/defaults! or \verb!~/.darcs/prefs!, see \ref{defaults},-on MS Windows~\ref{ms_win})-a line such as-\begin{verbatim}-ALL external-merge kdiff3 --output %o %a %1 %2-\end{verbatim}-or-\begin{verbatim}-ALL external-merge tortoiseMerge /base:"%a" /mine:"%1" /theirs:"%2" /merged:"%o"-\end{verbatim}--Note that the defaults file does not want quotes around the command.--\begin{options}---sendmail-command-\end{options}-\darcsEnv{SENDMAIL}--\subsection{Posthooks}--\begin{options}---posthook=COMMAND, --no-posthook-\end{options}-To provide a command that should be run whenever a darcs command completes-successfully, use \verb!--posthook! to specify the command. This is useful-for people who want to have a command run whenever a patch is applied. Using-\verb!--no-posthook! will disable running the command.-\begin{options}---run-posthook, --prompt-posthook-\end{options}-These options control prompting before running the posthook. Use-\verb!--prompt-posthook! to have darcs prompt before running the-posthook command. You may use --run-posthook to reenable the default-behavior of running user-specified posthooks.--Some darcs commands export to the posthook command information about the-changes being made. In particular, three environment variables are defined.-\verb!DARCS_PATCHES! contains a human-readable summary of the patches being-acted upon. The format is the same as "darcs changes". \verb!DARCS_PATCHES_XML!-Contains the same details, in the same XML format as "darcs changes". Finally,-\verb!DARCS_FILES! contains a list of the files affected, one file per line.-If your repository has filenames including newlines, you'll just have to-cope. Note, however, that \emph{none} of these environment variables are-defined when running under windows. Note also that we refuse to pass-environment variables greater in size than 10k, in order to avoid triggering-\verb!E2BIG! errors.---\subsection{Prehooks}--\begin{options}---prehook=COMMAND, --no-prehook-\end{options}-To provide a command that should be run before a darcs command is executed,- use \verb!--prehook! to specify the command. An example use is-for people who want to have a command run whenever a patch is to be recorded, such as-translating line endings before recording patches. Using-\verb!--no-prehook! will disable running the command.-\begin{options}---run-prehook, --prompt-prehook-\end{options}-These options control prompting before running the prehook. See the-posthook documentation above for details.--\begin{options}---http-pipelining, --no-http-pipelining-\end{options}--When compiled with libcurl (version 7.18.0 and above), darcs can-use HTTP pipelining. It is enabled by default for libcurl-(version 7.19.1 and above). This option will make darcs enable or-disable HTTP pipelining, overwriting default. Note that if HTTP-pipelining is really used depends on the server.--\begin{options}---no-cache-\end{options}--Do not use patch caches.--\begin{options}---umask-\end{options}-By default, Darcs will use your current umask. The option-\verb|--umask| will cause Darcs to switch to a different umask before-writing to the repository.--\begin{options}---dont-restrict-paths, --restrict-paths-\end{options}-By default darcs is only allowed to manage and modify files and directories-contained inside the current repository and not being part of any darcs-repository's meta data (including the current one). This is mainly for-security, to protect you from spoofed patches modifying arbitrary files-with sensitive data---say, in your home directory---or tampering with any-repository's meta data to switch off this safety guard.--But sometimes you may want to manage a group of ``sub'' repositories'-preference files with a global repository, or use darcs in some other-advanced way. The best way is probably to put-\verb!ALL dont-restrict-paths! in \verb!_darcs/prefs/defaults!. This turns-off all sanity checking for file paths in patches.--Path checking can be temporarily turned on with \verb!--restrict-paths! on-the command line, when pulling or applying unknown patches.--\begin{options}---allow-unrelated-repos-\end{options}-By default darcs checks and warns user if repositories are unrelated when-doing pull, push and send. This option makes darcs skip this check.---\section{Options apart from darcs commands}-\begin{options}---help-\end{options}-Calling darcs with just \verb|--help| as an argument gives a brief-summary of what commands are available.-\begin{options}---version, --exact-version-\end{options}-Calling darcs with the flag \verb|--version| tells you the version of-darcs you are using. Calling darcs with the flag \verb|--exact-version|-gives the precise version of darcs, even if that version doesn't correspond-to a released version number. This is helpful with bug reports, especially-when running with a ``latest'' version of darcs.-\begin{options}---commands-\end{options}-Similarly calling darcs with only \verb|--commands| gives a simple list-of available commands. This latter arrangement is primarily intended for-the use of command-line autocompletion facilities, as are available in-bash.--\section{Getting help}--\darcsCommand{help}--\section{Creating repositories}--\darcsCommand{initialize}-\darcsCommand{get}--\section{Modifying the contents of a repository}--\darcsCommand{add}-\darcsCommand{remove}-\darcsCommand{move}-\darcsCommand{replace}--\section{Working with changes}--\darcsCommand{record}--\begin{options}---ask-deps-\end{options}--Each patch may depend on any number of previous patches. If you choose to-make your patch depend on a previous patch, that patch is required to be-applied before your patch can be applied to a repository. This can be used, for-example, if a piece of code requires a function to be defined, which was-defined in an earlier patch.--If you want to manually define any dependencies for your patch, you can use-the \verb!--ask-deps! flag, and darcs will ask you for the patch's-dependencies.--It is possible to record a patch which has no actual changes but which-has specific dependencies. This type of patch can be thought of as a-``partial tag''. The \verb!darcs tag! command will record a patch-with no actual changes but which depends on the entire current-inventory of the repository. The \verb!darcs record --ask-deps! with-no selected changes will record a patch that depends on only those-patches selected via the \verb!--ask-deps! operation, resulting in a-patch which describes a set of patches; the presence of this primary-patch in a repository implies the presence of (at least) the-depended-upon patches.--\begin{options}---pipe-\end{options}--If you run record with the \verb!--pipe! option, you will be prompted for-the patch date, author, and the long comment. The long comment will extend-until the end of file or stdin is reached (ctrl-D on Unixy systems, ctrl-Z-on systems running a Microsoft OS).--This interface is intended for scripting darcs, in particular for writing-repository conversion scripts. The prompts are intended mostly as a useful-guide (since scripts won't need them), to help you understand the format in-which to provide the input. Here's an example of what the \verb!--pipe!-prompts look like:--\begin{verbatim}- What is the date? Mon Nov 15 13:38:01 EST 2004- Who is the author? David Roundy- What is the log? One or more comment lines-\end{verbatim}---\begin{options}---interactive-\end{options}--By default, \verb!record! works interactively. Probably the only thing you need-to know about using this is that you can press \verb!?! at the prompt to be-shown a list of the rest of the options and what they do. The rest should be-clear from there. Here's a-``screenshot'' to demonstrate:--\begin{verbatim}-hunk ./hello.pl +2-+#!/usr/bin/perl-+print "Hello World!\n";-Shall I record this patch? (2/2) [ynWsfqadjk], or ? for help: ?-How to use record...-y: record this patch-n: don't record it-w: wait and decide later, defaulting to no--s: don't record the rest of the changes to this file-f: record the rest of the changes to this file--d: record selected patches-a: record all the remaining patches-q: cancel record--j: skip to next patch-k: back up to previous patch-h or ?: show this help--<Space>: accept the current default (which is capitalized)--\end{verbatim}-What you can't see in that ``screenshot'' is that \verb!darcs! will also try to use-color in your terminal to make the output even easier to read.--\darcsCommand{pull}--\begin{options}---intersection, --union [DEFAULT], --complement-\end{options}--If you provide more than one repository as an argument to pull, darcs'-behavior is determined by the presence of the \verb!--complement!,-\verb!--intersection!, and \verb!--union! flags.--\begin{itemize}--\item The default (\verb!--union!) behavior is to pull any patches-that are in any of the specified repositories.--\item If you instead specify the \verb!--intersection! flag, darcs-will only pull those patches which are present in all source-repositories.--\item If you specify the \verb!--complement! flag, darcs will only-pull elements in the first repository that do not exist in any of the-remaining repositories.-\end{itemize}---\begin{options}---external-merge-\end{options}--You can use an external interactive merge tool to resolve conflicts with the-flag \verb!--external-merge!. For more details see-subsection~\ref{resolution}.--\begin{options}---matches, --patches, --tags, --no-deps-\end{options}--The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!-options can be used to select which patches to pull, as described in-subsection~\ref{selecting}.--\begin{options}---no-test, --test-\end{options}--If you specify the \verb!--test! option, pull will run the test (if a test-exists) on a scratch copy of the repository contents prior to actually performing-the pull. If the test fails, the pull will be aborted.--\begin{options}---verbose-\end{options}--Adding the \verb!--verbose! option causes another section to appear in the-output which also displays a summary of patches that you have and the remote-repository lacks. Thus, the following syntax can be used to show you all the patch-differences between two repositories:--\begin{verbatim}-darcs pull --dry-run --verbose-\end{verbatim}--\darcsCommand{push}--For obvious reasons, you can only push to repositories to which you have-write access. In addition, you can only push to repos that you access-either on the local file system or with ssh. In order to apply with ssh,-darcs must also be installed on the remote computer. The command invoked-to run ssh may be configured by the \verb!DARCS_SSH! environment variable-(see subsection~\ref{env:DARCS_SSH}). The command invoked via ssh is always-\verb!darcs!, i.e.\ the darcs executable must be in the default path on-the remote machine.--Push works by creating a patch bundle, and then running darcs apply in the-target repository using that patch bundle. This means that the default-options for \emph{apply} in the \emph{target} repository (such as, for-example, \verb!--test!) will affect the behavior of push. This also means-that push is somewhat less efficient than pull.--When you receive an error message such as-\begin{verbatim}-bash: darcs: command not found-\end{verbatim}-then this means that the darcs on the remote machine could-not be started. Make sure that the darcs executable is called-\verb!darcs! and is found in the default path. The default path can-be different in interactive and in non-interactive shells. Say-\begin{verbatim}-ssh login@remote.machine darcs-\end{verbatim}-to try whether the remote darcs can be found, or-\begin{verbatim}-ssh login@remote.machine 'echo $PATH'-\end{verbatim}-(note the single quotes) to check the default path.--\begin{options}---apply-as-\end{options}--If you give the \verb!--apply-as! flag, darcs will use sudo to apply the-changes as a different user. This can be useful if you want to set up a-system where several users can modify the same repository, but you don't-want to allow them full write access. This isn't secure against skilled-malicious attackers, but at least can protect your repository from clumsy,-inept or lazy users.--\begin{options}---matches, --patches, --tags, --no-deps-\end{options}--The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!-options can be used to select which patches to push, as described in-subsection~\ref{selecting}.--When there are conflicts, the behavior of push is determined by the default-flags to \verb!apply! in the \emph{target} repository. Most commonly, for-pushed-to repositories, you'd like to have \verb!--dont-allow-conflicts! as-a default option to apply (by default, it is already the default\ldots). If-this is the case, when there are conflicts on push, darcs will fail with an-error message. You can then resolve by pulling the conflicting patch,-recording a resolution and then pushing the resolution together with the-conflicting patch.--Darcs does not have an explicit way to tell you which patch conflicted, only the-file name. You may want to pull all the patches from the remote repository just-to be sure. If you don't want to do this in your working directory,-you can create another darcs working directory for this purpose.--If you want, you could set the target repository to use \verb!--allow-conflicts!.-In this case conflicting patches will be applied, but the conflicts will-not be marked in the working directory.--If, on the other hand, you have \verb!--mark-conflicts! specified as a-default flag for apply in the target repository, when there is a conflict,-it will be marked in the working directory of the target repository. In-this case, you should resolve the conflict in the target repository itself.--\darcsCommand{send}--Do not confuse the \verb!--author! options with the return address-that \verb!darcs send! will set for your patch bundle.--For example, if you have two email addresses A and B:-\begin{description}-\item If you use-\verb!--author A! but your machine is configured to send mail from-address B by default, then the return address on your message will be B.--\item If you use \verb!--from A! and your mail client supports setting the-From: address arbitrarily (some non-Unix-like mail clients, especially,-may not support this), then the return address will be A; if it does-not support this, then the return address will be B.--\item If you supply neither \verb!--from! nor \verb!--author!, then the return-address will be B.-\end{description}--In addition, unless you specify the sendmail command with-\verb!--sendmail-command!, darcs sends email using the default email-command on your computer. This default command is determined by the-\verb!configure! script. Thus, on some non-Unix-like OSes,-\verb!--from! is likely to not work at all.--\begin{options}---output, --to, --cc-\end{options}--The \verb!--output!, \verb!--output-auto-name!, and \verb!--to! flags determine-what darcs does with the patch bundle after creating it. If you provide an-\verb!--output! argument, the patch bundle is saved to that file. If you-specify \verb!--output-auto-name!, the patch bundle is saved to a file with an-automatically generated name. If you give one or more \verb!--to! arguments,-the bundle of patches is sent to those locations. The locations may either be email-addresses or urls that the patch should be submitted to via HTTP.--If you don't provide any of these options, darcs will look at the contents of-the \verb!_darcs/prefs/email! file in the target repository (if it exists), and-send the patch by email to that address. In this case, you may use the-\verb!--cc! option to specify additional recipients without overriding the-default repository email address.--If \texttt{\_darcs/prefs/post} exists in the target repository, darcs will-upload to the URL contained in that file, which may either be a-\texttt{mailto:} URL, or an \texttt{http://} URL. In the latter case, the-patch is posted to that URL.--If there is no email address associated with the repository, darcs will-prompt you for an email address.--\begin{options}---subject-\end{options}--Use the \verb!--subject! flag to set the subject of the e-mail to be sent.-If you don't provide a subject on the command line, darcs will make one up-based on names of the patches in the patch bundle.--\begin{options}---in-reply-to-\end{options}--Use the \verb!--in-reply-to! flag to set the In-Reply-To and References headers-of the e-mail to be sent. By default no additional headers are included so e-mail-will not be treated as reply by mail readers.--\begin{options}---matches, --patches, --tags, --no-deps-\end{options}--The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!-options can be used to select which patches to send, as described in-subsection~\ref{selecting}.--\begin{options}---edit-description-\end{options}--If you want to include a description or explanation along with the bundle-of patches, you need to specify the \verb!--edit-description! flag, which-will cause darcs to open up an editor with which you can compose a message-to go along with your patches.--\begin{options}---sendmail-command-\end{options}--If you want to use a command different from the default one for sending email,-you need to specify a command line with the \verb!--sendmail-command! option. The-command line can contain some format specifiers which are replaced by the actual-values. Accepted format specifiers are \verb!%s! for subject, \verb!%t! for to,-\verb!%c! for cc, \verb!%b! for the body of the mail, \verb!%f! for from, \verb!%a!-for the patch bundle and the same specifiers in uppercase for the URL-encoded values.-Additionally you can add \verb!%<! to the end of the command line if the command-expects the complete email message on standard input. E.g.\ the command lines for evolution-and msmtp look like this:--\begin{verbatim}-evolution "mailto:%T?subject=%S&attach=%A&cc=%C&body=%B"-msmtp -t %<-\end{verbatim}--\darcsCommand{apply}--Darcs apply accepts a single argument, which is the name of the patch-file to be applied. If you omit this argument, the patch is read from-standard input. Darcs also interprets an argument of `\-' to mean it-should read the file from standard input. This allows you to use apply-with a pipe from your email program, for example.--\begin{options}---verify-\end{options}--\begin{options}---external-merge-\end{options}--You can use an external interactive merge tool to resolve conflicts with the-flag \verb!--external-merge!. For more details see-subsection~\ref{resolution}.--\begin{options}---sendmail-command-\end{options}--If you want to use a command different from the default one for sending mail,-you need to specify a command line with the \verb!--sendmail-command! option.-The command line can contain the format specifier \verb!%t! for to-and you can add \verb!%<! to the end of the command line if the command-expects the complete mail on standard input. For example, the command line for-msmtp looks like this:--\begin{verbatim}-msmtp -t %<-\end{verbatim}---\section{Seeing what you've done}--\darcsCommand{whatsnew}-\darcsCommand{changes}--\section{More advanced commands}--\darcsCommand{tag}-\darcsCommand{setpref}-\darcsCommand{test}--If you like, you can configure your repository to be able to run a test-suite of some sort. You can do this by using ``setpref'' to set the-``test'' value to be a command to run, e.g.-\begin{verbatim}-% darcs setpref test "sh configure && make && make test"-\end{verbatim}-Or, if you want to define a test specific to one copy of the repository,-you could do this by editing the file \verb!_darcs/prefs/prefs!.--\begin{options}---leave-test-directory, --remove-test-directory-\end{options}--Normally darcs deletes the directory in which the test was run afterwards.-Sometimes (especially when the test fails) you'd prefer to be able to be-able to examine the test directory after the test is run. You can do this-by specifying the \verb!--leave-test-directory! flag. Alas, there is no-way to make darcs leave the test directory only if the test fails. The-opposite of \verb!--leave-test-directory! is-\verb!--remove-test-directory!, which could come in handy if you choose to-make \verb!--leave-test-directory! the default (see-section~\ref{defaults}).--\darcsCommand{repair}-\darcsCommand{optimize}--\begin{options}---reorder-patches-\end{options}--The \verb|--reorder-patches| option causes Darcs to create an optimal-ordering of its internal patch inventory. This may help to produce shorter-`context' lists when sending patches, and may improve performance for some-other operations as well. You should not run \verb!--reorder-patches! on a-repository from which someone may be simultaneously pulling or getting, as-this could lead to repository corruption.--The \verb|--upgrade| option for \verb!darcs optimize! performs an inplace-upgrade of your repository to the latest \emph{compatible} format. Right now-means that darcs 1 old-fashioned repositories will be upgraded to darcs-1-hashed repositories (and notably, not to darcs 2 repositories as that would not-be compatible; see \verb!darcs convert!).--\section{Undoing, redoing and running in circles}--\darcsCommand{amend-record}-\darcsCommand{rollback}-\darcsCommand{unrecord}--Unrecord can be thought of as undo-record.-If a record is followed by an unrecord, everything looks like before-the record; all the previously unrecorded changes are back, and can be-recorded again in a new patch. The unrecorded patch however is actually-removed from your repository, so there is no way to record it again to get-it back.\footnote{The patch file itself is not actually deleted, but its-context is lost, so it cannot be reliably read---your only choice would be-to go in by hand and read its contents.}.--If you want to remove-the changes from the working copy too (where they otherwise will show-up as unrecorded changes again), you'll also need to \verb!darcs revert!.-To do unrecord and revert in one go, you can use \verb!darcs obliterate!.--If you don't revert after unrecording, then the changes made by the-unrecorded patches are left in your working tree. If these patches are-actually from another repository, interaction (either pushes or pulls) with-that repository may be massively slowed down, as darcs tries to cope with-the fact that you appear to have made a large number of changes that-conflict with those present in the other repository. So if you really want-to undo the result of a \emph{pull} operation, use obliterate! Unrecord is-primarily intended for when you record a patch, realize it needs just one-more change, but would rather not have a separate patch for just that one-change.--\newcommand{\pullwarning}[1]{-\textbf{WARNING:} #1 should not be run when there is a possibility-that another user may be pulling from the same repository. Attempting to do so-may cause repository corruption.}--\pullwarning{Unrecord}--\begin{options}---from-match, --from-patch, --from-tag, --last-\end{options}--Usually you only want to unrecord the latest changes,-and almost never would you want to unrecord changes before a tag---you-would have to have unrecorded the tag as well to do that.-Therefore, and for efficiency, darcs only prompts you for the latest patches,-after some optimal tag.--If you do want to unrecord more patches in one go,-there are the \verb!--from! and \verb!--last! options-to set the earliest patch selectable to unrecord.--\begin{options}---matches, --patches, --tags, --no-deps-\end{options}--The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!-options can be used to select which patches to unrecord, as described in-subsection~\ref{selecting}.--With these options you can specify-what patch or patches to be prompted for by unrecord.-This is especially useful when you want to unrecord patches with dependencies,-since all the dependent patches (but no others) will be included in the choices.-Or if you use \verb!--no-deps! you won't be asked about patches that can't be-unrecorded due to depending patches.--Selecting patches can be slow, so darcs cuts the search at the last-optimized tag. Use the \verb!--from! or \verb!--last! options to search-more or fewer patches.--\darcsCommand{obliterate}--Obliterate deletes a patch from the repository \emph{and} removes those-changes from the working directory. It is therefore a \emph{very-dangerous} command. When there are no local changes, obliterate is-equivalent to an unrecord followed by a revert, except that revert can be-unreverted. In the case of tags, obliterate removes the tag itself, not-any other patches.--Note that unpull was the old name for obliterate. Unpull is still an-hidden alias for obliterate.--\pullwarning{Obliterate}--\begin{options}---from-match, --from-patch, --from-tag, --last-\end{options}--Usually you only want to obliterate the latest changes, and almost never would-you want to obliterate changes before a tag---you would have to have obliterated-the tag as well to do that. Therefore, and for efficiency, darcs only-prompts you for the latest patches, after some optimal tag.--If you do want to obliterate more patches in one go, there are the-\verb!--from! and \verb!--last! options to set the earliest patch-selectable to obliterate.--\begin{options}---matches, --patches, --tags, --no-deps-\end{options}--The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!-options can be used to select which patches to obliterate, as described in-subsection~\ref{selecting}.--With these options you can specify what patch or patches to be prompted for-by obliterate. This is especially useful when you want to obliterate patches with-dependencies, since all the dependent patches (but no others) will be-included in the choices. Or if you use \verb!--no-deps! you won't be asked-about patches that can't be obliterated due to depending patches.--Selecting patches can be slow, so darcs cuts the search at the last-optimized tag. Use the \verb!--from! or \verb!--last! options to search-more or fewer patches.---\darcsCommand{revert}-\darcsCommand{unrevert}--\section{Advanced examination of the repository}--\darcsCommand{diff}-\darcsCommand{annotate}--%% FIXME: AFAICT -u does nothing. Remove it from anno's options?-%% --twb, 2009-09-20-Giving the \verb!--unified! flag implies \verb!--human-readable!, and causes-the output to remain in a darcs-specific format that is similar to that produced-by \verb!diff --unified!.--If a directory name is given, annotate will output details of the last-modifying patch for each file in the directory and the directory itself. The-details look like this:--\begin{verbatim}- # Created by [bounce handling patch- # mark**20040526202216] as ./test/m7/bounce_handling.pl- bounce_handling.pl-\end{verbatim}--If a patch name and a directory are given, these details are output for the time after-that patch was applied. If a directory and a tag name are given, the-details of the patches involved in the specified tagged version will be output.--If a file name is given, the last modifying patch details of that file will be output, along-with markup indicating patch details when each line was last (and perhaps next) modified.--If a patch name and a file name are given, these details are output for the time after-that patch was applied.--\begin{options}---creator-hash HASH-\end{options}--The \verb!--creator-hash! option should only be used in combination with a-file or directory to be annotated. In this case, the name of that file or-directory is interpreted to be its name \emph{at the time it was created},-and the hash given along with \verb!--creator-hash! indicates the patch-that created the file or directory. This allows you to (relatively) easily-examine a file even if it has been renamed multiple times.--\subsection{darcs show}--The show command provides access to several subcommands which can be-used to investigate the state of a repository.--\darcsCommand{show authors}-\darcsCommand{show contents}-\darcsCommand{show files}-\darcsCommand{show index}-\darcsCommand{show tags}-\darcsCommand{show repo}--\section{Rarely needed and obscure commands}--\darcsCommand{mark-conflicts}-\darcsCommand{trackdown}--Trackdown is helpful for locating when something was broken. It creates-a temporary directory with the latest repository content in it and cd to it.-First, and only once, it runs the initialization command if any,-for example-\begin{verbatim}-'autoconf; ./configure >/dev/null'-\end{verbatim}-Then it runs the test command, for example-\begin{verbatim}-'make && cd tests && sh /tmp/test.sh'-\end{verbatim}-While the test command exits with an error return code, darcs-``unapplies'' one patch from the version controlled files to retrieve-an earlier version, and repeats the test command. If the test command-finally succeeds, the name of the hunted down patch is found in the-output before the last test run.--The \verb!--bisect! variant of trackdown can be useful when the sought after-patch is likely buried deep in the repository history; however, it currently-requires an potentially expensive process of applying or unapplying half the-repository's patches at a time. You may often find the straightforward linear-trackdown to be more efficient in practice.--\subsubsection{Example usage}-If you want to find the last version of darcs that had a FIXME note in the-file Record.lhs, you could run-\begin{verbatim}-% darcs trackdown 'grep FIXME Record.lhs'-\end{verbatim}--To find the latest version that compiles, you can run-\begin{verbatim}-% darcs trackdown 'autoconf' './configure && make'-\end{verbatim}--Trackdown can also be used to see how other features of the code changed-with time. For example-\begin{verbatim}-% darcs trackdown 'autoconf; ./configure' \- "make darcs > /dev/null && cd ~/darcs && time darcs check && false"-\end{verbatim}-would let you see how long `darcs check' takes to run on each previous-version of darcs that will actually compile. The ``\verb!&& false!''-ensures that trackdown keeps going.--\darcsCommand{dist}-\darcsCommand{put}-\darcsCommand{fetch}-\darcsCommand{convert}--A project cannot mix both patch formats.-By default, repositories created with `darcs initialize' are set-to use the `darcs-2' format (\ref{initialize}).-Cloning an existing repository with `darcs get' or `darcs put'-preserves the patch format used.--The `darcs-2' format improves on the `darcs-1' format in the following-ways:--\begin{itemize}-\item The `exponential merge' problem is \emph{far} less likely to- occur (it can still be produced in deliberately pathological cases).-\item Identical primitive changes no longer conflict. For example, if- two patches both attempt to add a directory `tests', these patches- will not conflict.-\end{itemize}--\appendix--\input{building_darcs.tex}--\input{gpl.tex}--\end{document}--
− doc/src/features.tex
@@ -1,71 +0,0 @@-\section{Features}--\paragraph{Record changes locally}-In darcs, the equivalent of a svn ``commit'' is called record, because it-doesn't put the change into any remote or centralized repository. Changes-are always recorded locally, meaning no net access is required in order to-work on your project and record changes as you make them.--\paragraph{Interactive records}-You can choose to perform an interactive record, in which case darcs will-prompt you for each change you have made and ask if you wish to record it.-Of course, you can tell darcs to record all the changes in a given file, or-to skip all the changes in a given file, or go back to a previous change,-or whatever.--\paragraph{Unrecord local changes}-As a corollary to the ``local'' nature of the record operation, if a change-hasn't yet been published to the world---that is, if the local repository-isn't accessible by others---you can safely unrecord a change (even if it-wasn't the most recently recorded change) and then re-record it-differently, for example if you forgot to add a file, introduced a bug or-realized that what you recorded as a single change was really two separate-changes.--\paragraph{Interactive everything else}-Most darcs commands support an interactive interface. The ``revert''-command, for example, which undoes unrecorded changes has the same-interface as record, so you can easily revert just a single change. Pull,-push, send and apply all allow you to view and interactively select which-changes you wish to pull, push, send or apply.--\paragraph{Test suites}-Darcs has support for integrating a test suite with a repository. If you-choose to use this, you can define a test command (e.g.\ ``make check'') and-have darcs run that command on a clean copy of the project either prior to-recording a change or prior to applying changes---and to reject changes-that cause the test to fail.--\paragraph{Any old server}-Darcs does not require a specialized server in order to make a repository-available for read access. You can use http, ftp, or even just a plain old-ssh server to access your darcs repository.--\paragraph{You decide write permissions}-Darcs doesn't try to manage write access. That's your business. Supported-push methods include direct ssh access (if you're willing to \emph{give}-direct ssh access away), using sudo to allow users who already have shell-access to only apply changes to the repository, or verification of-gpg-signed changes sent by email against a list of allowed keys. In-addition, there is support for submission of patches by email that-are not automatically applied, but can easily be applied with a shell escape-from a mail reader.--\paragraph{File and directory moves}-Renames or moves of files and directories, of course are handled properly,-so when you rename a file or move it to a different directory, its history-is unbroken, and merges with repositories that don't have the file renamed-will work as expected.--\paragraph{Token replace}-You can use the ``darcs replace'' command to modify all occurrences of a-particular token (defined by a configurable set of characters that are-allowed in ``tokens'') in a file. This has the advantage that merges with-changes that introduce new copies of the old token will have the effect of-changing it to the new token---which comes in handy when changing a-variable or function name that is used throughout a project.--\paragraph{Configurable defaults}-You can easily configure the default flags passed to any command on either-a per-repository or a per-user basis or a combination thereof.-
− doc/src/gpl.tex
@@ -1,420 +0,0 @@-% This is the FSF GPL, reformatted as an appendix by David Roundy--% This file is intended to be included in another file.--\chapter{License}--This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2, or (at your option)-any later version.--\label{gpl}-\section*{The GNU General Public License}--\begin{center}-Version 2, June 1991--Copyright \copyright\ 1989, 1991 Free Software Foundation, Inc.--\bigskip--51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA--\bigskip--Everyone is permitted to copy and distribute verbatim copies-of this license document, but changing it is not allowed.--\end{center}--\subsection*{Preamble}-\begin{quote}-The licenses for most software are designed to take away your freedom to-share and change it. By contrast, the GNU General Public License is-intended to guarantee your freedom to share and change free software---to-make sure the software is free for all its users. This General Public-License applies to most of the Free Software Foundation's software and to-any other program whose authors commit to using it. (Some other Free-Software Foundation software is covered by the GNU Library General Public-License instead.) You can apply it to your programs, too.--When we speak of free software, we are referring to freedom, not price.-Our General Public Licenses are designed to make sure that you have the-freedom to distribute copies of free software (and charge for this service-if you wish), that you receive source code or can get it if you want it,-that you can change the software or use pieces of it in new free programs;-and that you know you can do these things.--To protect your rights, we need to make restrictions that forbid anyone to-deny you these rights or to ask you to surrender the rights. These-restrictions translate to certain responsibilities for you if you-distribute copies of the software, or if you modify it.--For example, if you distribute copies of such a program, whether gratis or-for a fee, you must give the recipients all the rights that you have. You-must make sure that they, too, receive or can get the source code. And-you must show them these terms so they know their rights.--We protect your rights with two steps: (1) copyright the software, and (2)-offer you this license which gives you legal permission to copy,-distribute and/or modify the software.--Also, for each author's protection and ours, we want to make certain that-everyone understands that there is no warranty for this free software. If-the software is modified by someone else and passed on, we want its-recipients to know that what they have is not the original, so that any-problems introduced by others will not reflect on the original authors'-reputations.--Finally, any free program is threatened constantly by software patents.-We wish to avoid the danger that redistributors of a free program will-individually obtain patent licenses, in effect making the program-proprietary. To prevent this, we have made it clear that any patent must-be licensed for everyone's free use or not licensed at all.--The precise terms and conditions for copying, distribution and-modification follow.-\end{quote}--\begin{center}-{\Large \sc GNU General Public License-\\\vspace{3mm}Terms and Conditions For Copying, Distribution and Modification}-\end{center}---\begin{enumerate}--\addtocounter{enumi}{-1}--\item --This License applies to any program or other work which contains a notice-placed by the copyright holder saying it may be distributed under the-terms of this General Public License. The ``Program'', below, refers to-any such program or work, and a ``work based on the Program'' means either-the Program or any derivative work under copyright law: that is to say, a-work containing the Program or a portion of it, either verbatim or with-modifications and/or translated into another language. (Hereinafter,-translation is included without limitation in the term ``modification''.)-Each licensee is addressed as ``you''.--Activities other than copying, distribution and modification are not-covered by this License; they are outside its scope. The act of-running the Program is not restricted, and the output from the Program-is covered only if its contents constitute a work based on the-Program (independent of having been made by running the Program).-Whether that is true depends on what the Program does.--\item You may copy and distribute verbatim copies of the Program's source- code as you receive it, in any medium, provided that you conspicuously- and appropriately publish on each copy an appropriate copyright notice- and disclaimer of warranty; keep intact all the notices that refer to- this License and to the absence of any warranty; and give any other- recipients of the Program a copy of this License along with the Program.--You may charge a fee for the physical act of transferring a copy, and you-may at your option offer warranty protection in exchange for a fee.--\item--You may modify your copy or copies of the Program or any portion-of it, thus forming a work based on the Program, and copy and-distribute such modifications or work under the terms of Section 1-above, provided that you also meet all of these conditions:--\begin{enumerate}--\item --You must cause the modified files to carry prominent notices stating that-you changed the files and the date of any change.--\item--You must cause any work that you distribute or publish, that in-whole or in part contains or is derived from the Program or any-part thereof, to be licensed as a whole at no charge to all third-parties under the terms of this License.--\item-If the modified program normally reads commands interactively-when run, you must cause it, when started running for such-interactive use in the most ordinary way, to print or display an-announcement including an appropriate copyright notice and a-notice that there is no warranty (or else, saying that you provide-a warranty) and that users may redistribute the program under-these conditions, and telling the user how to view a copy of this-License. (Exception: if the Program itself is interactive but-does not normally print such an announcement, your work based on-the Program is not required to print an announcement.)--\end{enumerate}---These requirements apply to the modified work as a whole. If-identifiable sections of that work are not derived from the Program,-and can be reasonably considered independent and separate works in-themselves, then this License, and its terms, do not apply to those-sections when you distribute them as separate works. But when you-distribute the same sections as part of a whole which is a work based-on the Program, the distribution of the whole must be on the terms of-this License, whose permissions for other licensees extend to the-entire whole, and thus to each and every part regardless of who wrote it.--Thus, it is not the intent of this section to claim rights or contest-your rights to work written entirely by you; rather, the intent is to-exercise the right to control the distribution of derivative or-collective works based on the Program.--In addition, mere aggregation of another work not based on the Program-with the Program (or with a work based on the Program) on a volume of-a storage or distribution medium does not bring the other work under-the scope of this License.--\item-You may copy and distribute the Program (or a work based on it,-under Section 2) in object code or executable form under the terms of-Sections 1 and 2 above provided that you also do one of the following:--\begin{enumerate}--\item--Accompany it with the complete corresponding machine-readable-source code, which must be distributed under the terms of Sections-1 and 2 above on a medium customarily used for software interchange; or,--\item--Accompany it with a written offer, valid for at least three-years, to give any third party, for a charge no more than your-cost of physically performing source distribution, a complete-machine-readable copy of the corresponding source code, to be-distributed under the terms of Sections 1 and 2 above on a medium-customarily used for software interchange; or,--\item--Accompany it with the information you received as to the offer-to distribute corresponding source code. (This alternative is-allowed only for noncommercial distribution and only if you-received the program in object code or executable form with such-an offer, in accord with Subsection b above.)--\end{enumerate}---The source code for a work means the preferred form of the work for-making modifications to it. For an executable work, complete source-code means all the source code for all modules it contains, plus any-associated interface definition files, plus the scripts used to-control compilation and installation of the executable. However, as a-special exception, the source code distributed need not include-anything that is normally distributed (in either source or binary-form) with the major components (compiler, kernel, and so on) of the-operating system on which the executable runs, unless that component-itself accompanies the executable.--If distribution of executable or object code is made by offering-access to copy from a designated place, then offering equivalent-access to copy the source code from the same place counts as-distribution of the source code, even though third parties are not-compelled to copy the source along with the object code.--\item-You may not copy, modify, sublicense, or distribute the Program-except as expressly provided under this License. Any attempt-otherwise to copy, modify, sublicense or distribute the Program is-void, and will automatically terminate your rights under this License.-However, parties who have received copies, or rights, from you under-this License will not have their licenses terminated so long as such-parties remain in full compliance.--\item-You are not required to accept this License, since you have not-signed it. However, nothing else grants you permission to modify or-distribute the Program or its derivative works. These actions are-prohibited by law if you do not accept this License. Therefore, by-modifying or distributing the Program (or any work based on the-Program), you indicate your acceptance of this License to do so, and-all its terms and conditions for copying, distributing or modifying-the Program or works based on it.--\item-Each time you redistribute the Program (or any work based on the-Program), the recipient automatically receives a license from the-original licensor to copy, distribute or modify the Program subject to-these terms and conditions. You may not impose any further-restrictions on the recipients' exercise of the rights granted herein.-You are not responsible for enforcing compliance by third parties to-this License.--\item-If, as a consequence of a court judgment or allegation of patent-infringement or for any other reason (not limited to patent issues),-conditions are imposed on you (whether by court order, agreement or-otherwise) that contradict the conditions of this License, they do not-excuse you from the conditions of this License. If you cannot-distribute so as to satisfy simultaneously your obligations under this-License and any other pertinent obligations, then as a consequence you-may not distribute the Program at all. For example, if a patent-license would not permit royalty-free redistribution of the Program by-all those who receive copies directly or indirectly through you, then-the only way you could satisfy both it and this License would be to-refrain entirely from distribution of the Program.--If any portion of this section is held invalid or unenforceable under-any particular circumstance, the balance of the section is intended to-apply and the section as a whole is intended to apply in other-circumstances.--It is not the purpose of this section to induce you to infringe any-patents or other property right claims or to contest validity of any-such claims; this section has the sole purpose of protecting the-integrity of the free software distribution system, which is-implemented by public license practices. Many people have made-generous contributions to the wide range of software distributed-through that system in reliance on consistent application of that-system; it is up to the author/donor to decide if he or she is willing-to distribute software through any other system and a licensee cannot-impose that choice.--This section is intended to make thoroughly clear what is believed to-be a consequence of the rest of this License.--\item-If the distribution and/or use of the Program is restricted in-certain countries either by patents or by copyrighted interfaces, the-original copyright holder who places the Program under this License-may add an explicit geographical distribution limitation excluding-those countries, so that distribution is permitted only in or among-countries not thus excluded. In such case, this License incorporates-the limitation as if written in the body of this License.--\item-The Free Software Foundation may publish revised and/or new versions-of the General Public License from time to time. Such new versions will-be similar in spirit to the present version, but may differ in detail to-address new problems or concerns.--Each version is given a distinguishing version number. If the Program-specifies a version number of this License which applies to it and ``any-later version'', you have the option of following the terms and conditions-either of that version or of any later version published by the Free-Software Foundation. If the Program does not specify a version number of-this License, you may choose any version ever published by the Free Software-Foundation.--\item-If you wish to incorporate parts of the Program into other free-programs whose distribution conditions are different, write to the author-to ask for permission. For software which is copyrighted by the Free-Software Foundation, write to the Free Software Foundation; we sometimes-make exceptions for this. Our decision will be guided by the two goals-of preserving the free status of all derivatives of our free software and-of promoting the sharing and reuse of software generally.--\begin{center}-{\Large\sc-No Warranty-}-\end{center}--\item-{\sc Because the program is licensed free of charge, there is no warranty-for the program, to the extent permitted by applicable law. Except when-otherwise stated in writing the copyright holders and/or other parties-provide the program ``as is'' without warranty of any kind, either expressed-or implied, including, but not limited to, the implied warranties of-merchantability and fitness for a particular purpose. The entire risk as-to the quality and performance of the program is with you. Should the-program prove defective, you assume the cost of all necessary servicing,-repair or correction.}--\item-{\sc In no event unless required by applicable law or agreed to in writing-will any copyright holder, or any other party who may modify and/or-redistribute the program as permitted above, be liable to you for damages,-including any general, special, incidental or consequential damages arising-out of the use or inability to use the program (including but not limited-to loss of data or data being rendered inaccurate or losses sustained by-you or third parties or a failure of the program to operate with any other-programs), even if such holder or other party has been advised of the-possibility of such damages.}--\end{enumerate}---\begin{center}-{\Large\sc End of Terms and Conditions}-\end{center}--\subsection*{Appendix: How to Apply These Terms to Your New Programs}--If you develop a new program, and you want it to be of the greatest-possible use to the public, the best way to achieve this is to make it-free software which everyone can redistribute and change under these-terms.-- To do so, attach the following notices to the program. It is safest to- attach them to the start of each source file to most effectively convey- the exclusion of warranty; and each file should have at least the- ``copyright'' line and a pointer to where the full notice is found.--\begin{quote}-$<$one line to give the program's name and a brief idea of what it does.$>$ \\-Copyright (C) $<$year$>$ $<$name of author$>$ \\--This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2 of the License, or-(at your option) any later version.--This program is distributed in the hope that it will be useful,-but WITHOUT ANY WARRANTY; without even the implied warranty of-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the-GNU General Public License for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.-\end{quote}--Also add information on how to contact you by electronic and paper mail.--If the program is interactive, make it output a short notice like this-when it starts in an interactive mode:--\begin{quote}-Gnomovision version 69, Copyright (C) $<$year$>$ $<$name of author$>$ \\-Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. \\-This is free software, and you are welcome to redistribute it-under certain conditions; type `show c' for details.-\end{quote}---The hypothetical commands {\tt show w} and {\tt show c} should show the-appropriate parts of the General Public License. Of course, the commands-you use may be called something other than {\tt show w} and {\tt show c};-they could even be mouse-clicks or menu items---whatever suits your-program.--You should also get your employer (if you work as a programmer) or your-school, if any, to sign a ``copyright disclaimer'' for the program, if-necessary. Here is a sample; alter the names:--\begin{quote}-Yoyodyne, Inc., hereby disclaims all copyright interest in the program \\-`Gnomovision' (which makes passes at compilers) written by James Hacker. \\--$<$signature of Ty Coon$>$, 1 April 1989 \\-Ty Coon, President of Vice-\end{quote}---This General Public License does not permit incorporating your program-into proprietary programs. If your program is a subroutine library, you-may consider it more useful to permit linking proprietary applications-with the library. If this is what you want to do, use the GNU Library-General Public License instead of this License.
+ harness/Darcs/Test/Email.hs view
@@ -0,0 +1,93 @@+-- Copyright (C) 2002-2005,2007 David Roundy+-- Copyright (C) 2009 Reinier Lamers+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- | This module contains unit tests of the code in 'Darcs.Email'+--+-- These tests check whether the emails generated by darcs meet a few criteria.+-- We check for line length and non-ASCII characters. We apparently do not have+-- to check for CR-LF newlines because that's handled by sendmail.+module Darcs.Test.Email ( testSuite ) where+import Data.Char ( isPrint )+import qualified Data.ByteString as B ( length, unpack, null, head,+ cons, empty, foldr, ByteString )+import qualified Data.ByteString.Char8 as BC ( unpack )+import Test.Framework ( Test, testGroup )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Darcs.Util.Printer ( text, renderPS, RenderMode(..) )+import Darcs.UI.Email ( makeEmail, readEmail, formatHeader )++testSuite :: Test+testSuite = testGroup "Darcs.Email"+ [ emailParsing+ , emailHeaderNoLongLines+ , emailHeaderAsciiChars+ , emailHeaderLinesStart+ , emailHeaderNoEmptyLines+ ]++-- | Checks that darcs can read the emails it generates+emailParsing :: Test+emailParsing = testProperty "Checking that email can be parsed" $ \s ->+ unlines ("":s++["", ""]) ==+ BC.unpack (readEmail (renderPS Standard+ $ makeEmail "reponame" [] (Just (text "contents\n"))+ Nothing+ (text $ unlines s) (Just "filename")))++-- | Check that formatHeader never creates lines longer than 78 characters+-- (excluding the carriage return and line feed)+emailHeaderNoLongLines :: Test+emailHeaderNoLongLines =+ testProperty "Checking email header line length" $ \field value ->+ let cleanField = cleanFieldString field+ in not $ any (>78) $ map B.length $ bsLines $ formatHeader cleanField value++-- Check that an email header does not contain non-ASCII characters+-- formatHeader doesn't escape field names, there is no such thing as non-ascii+-- field names afaik+emailHeaderAsciiChars :: Test+emailHeaderAsciiChars =+ testProperty "Checking email for illegal characters" $ \field value ->+ let cleanField = cleanFieldString field+ in not (any (>127) (B.unpack (formatHeader cleanField value)))++-- Check that header the second and later lines of a header start with a space+emailHeaderLinesStart :: Test+emailHeaderLinesStart =+ testProperty "Checking for spaces at start of folded email header lines" $ \field value ->+ let headerLines = bsLines (formatHeader cleanField value)+ cleanField = cleanFieldString field+ in all (\l -> B.null l || B.head l == 32) (tail headerLines)++-- Checks that there are no lines in email headers with only whitespace+emailHeaderNoEmptyLines :: Test+emailHeaderNoEmptyLines =+ testProperty "Checking that there are no empty lines in email headers" $ \field value ->+ let headerLines = bsLines (formatHeader cleanField value)+ cleanField = cleanFieldString field+ in all (not . B.null) headerLines --(not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines++bsLines :: B.ByteString -> [B.ByteString]+bsLines = finalizeFold . B.foldr splitAtLines (B.empty, [])+ where splitAtLines 10 (thisLine, prevLines) = (B.empty, thisLine:prevLines)+ splitAtLines c (thisLine, prevLines) = (B.cons c thisLine, prevLines)+ finalizeFold (lastLine, otherLines) = lastLine : otherLines++cleanFieldString :: String -> String+cleanFieldString = filter (\c -> isPrint c && c < '\x80' && c /= ':')+
+ harness/Darcs/Test/Misc.hs view
@@ -0,0 +1,107 @@+-- Copyright (C) 2002-2005,2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.Test.Misc ( testSuite ) where++import Darcs.Util.ByteString ( unpackPSFromUTF8, fromHex2PS, fromPS2Hex )+import Darcs.Util.Diff.Myers ( shiftBoundaries )++import qualified Data.ByteString.Char8 as BC ( unpack, pack )+import qualified Data.ByteString as B ( concat, empty )+import Data.Array.Base+import Control.Monad.ST+import Test.HUnit ( assertBool, assertEqual, assertFailure )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework ( Test, testGroup )+++testSuite :: Test+testSuite = testGroup ""+ [ byteStringUtilsTestSuite+ , lcsTestSuite+ ]+++-- ----------------------------------------------------------------------+-- * Darcs.Util.ByteString+-- Here are a few quick tests of the shiftBoundaries function.+-- ----------------------------------------------------------------------++byteStringUtilsTestSuite :: Test+byteStringUtilsTestSuite = testGroup "Darcs.Util.ByteString"+ [ testCase "UTF-8 packing and unpacking preserves 'hello world'"+ (assertBool "" (unpackPSFromUTF8 (BC.pack "hello world") == "hello world"))+ , testCase "Checking that hex packing and unpacking preserves 'hello world'"+ (assertEqual "" (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world"))+ "hello world")+ , testProperty "Checking that B.concat works" propConcatPS+ , testProperty "Checking that hex conversion works" propHexConversion+ ]++propHexConversion :: String -> Bool+propHexConversion s =+ fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s++propConcatPS :: [String] -> Bool+propConcatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss)++-- ----------------------------------------------------------------------+-- * LCS+-- Here are a few quick tests of the shiftBoundaries function.+-- ----------------------------------------------------------------------++lcsTestSuite :: Test+lcsTestSuite = testGroup "LCS"+ [ testCase "lcs code" (mapM_ assertFailure showLcsTests)+ ]++showLcsTests :: [String]+showLcsTests = concatMap checkKnownShifts knownShifts+checkKnownShifts :: ([Int],[Int],String,String,[Int],[Int])+ -> [String]+checkKnownShifts (ca, cb, sa, sb, ca', cb') = runST (+ do ca_arr <- newListArray (0, length ca) $ toBool (0:ca)+ cb_arr <- newListArray (0, length cb) $ toBool (0:cb)+ let p_a = listArray (0, length sa) $ B.empty:(toPS sa)+ p_b = listArray (0, length sb) $ B.empty:(toPS sb)+ shiftBoundaries ca_arr cb_arr p_a 1 1+ shiftBoundaries cb_arr ca_arr p_b 1 1+ ca_res <- fmap (fromBool . tail) $ getElems ca_arr+ cb_res <- fmap (fromBool . tail) $ getElems cb_arr+ return $ if ca_res == ca' && cb_res == cb' then []+ else ["shiftBoundaries failed on "++sa++" and "++sb++" with "+ ++(show (ca,cb))++" expected "++(show (ca', cb'))+ ++" got "++(show (ca_res, cb_res))++"\n"])+ where toPS = map (\c -> if c == ' ' then B.empty else BC.pack [c])+ toBool = map (>0)+ fromBool = map (\b -> if b then 1 else 0)++knownShifts :: [([Int],[Int],String,String,[Int],[Int])]+knownShifts =+ [([0,0,0],[0,1,0,1,0],"aaa","aaaaa",+ [0,0,0],[0,0,0,1,1]),+ ([0,1,0],[0,1,1,0],"cd ","c a ",+ [0,1,0],[0,1,1,0]),+ ([1,0,0,0,0,0,0,0,0],[1,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","dg{} ih{} if{}",+ [1,0,0,0,0,0,0,0,0],[1,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end+ ([0,0,0,0,0,0,0,0,0],[0,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","fg{} ih{} if{}",+ [0,0,0,0,0,0,0,0,0],[0,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end+ ([],[1,1],"","aa",[],[1,1]),+ ([1,1],[],"aa","",[1,1],[])]
+ harness/Darcs/Test/Patch.hs view
@@ -0,0 +1,374 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP, ImpredicativeTypes #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE AllowAmbiguousTypes #-}+#endif+-- Copyright (C) 2002-2005,2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Test.Patch ( testSuite ) where++import Data.Maybe( isNothing )+import Test.Framework ( Test, testGroup )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.QuickCheck.Arbitrary( Arbitrary )+import Test.QuickCheck( Testable )+import Test.HUnit ( assertBool )++import Darcs.Test.Util.TestResult ( TestResult, isOk, fromMaybe )+import Darcs.Test.Patch.Utils ( testConditional )++import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq ( MyEq, unsafeCompare )+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.Prim( PrimPatch, coalesce, FromPrim, PrimOf, PrimPatchBase )+import qualified Darcs.Patch.Prim.V1 as V1 ( Prim )+import qualified Darcs.Patch.Prim.V3 as V3 ( Prim )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Type ( PatchType(..) )+import Darcs.Patch.V1 as V1 ( Patch )+import Darcs.Patch.V2.Real ( isConsistent, isForward, RealPatch )+import Darcs.Patch.Patchy ( Commute(..), Patchy )+import Darcs.Patch.Merge( Merge )+import Darcs.Patch.Show ( ShowPatchBasic )+import Darcs.Patch.Apply( ApplyState )++import Darcs.Test.Patch.Arbitrary.Generic+import qualified Darcs.Test.Patch.Arbitrary.PrimV1 as P1+import Darcs.Test.Patch.Arbitrary.PrimV3()+import Darcs.Test.Patch.Arbitrary.Real+import Darcs.Test.Patch.Arbitrary.PatchV1 ()+import Darcs.Test.Patch.Arbitrary.PrimV1 ()+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.WithState( WithState, WithStartState )++import qualified Darcs.Test.Patch.Info++import qualified Darcs.Test.Patch.Examples.Set1 as Ex+import qualified Darcs.Test.Patch.Examples.Set2Unwitnessed as ExU++import Darcs.Test.Patch.Properties.Check( Check(..) )+import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop+import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop+import qualified Darcs.Test.Patch.Properties.Generic as Prop+import qualified Darcs.Test.Patch.Properties.Real as Prop+import qualified Darcs.Test.Patch.Properties.GenericUnwitnessed as PropU++import qualified Darcs.Test.Patch.Rebase as Rebase++import qualified Darcs.Test.Patch.WSub as WSub+++type instance ModelOf (FL prim) = ModelOf prim++type TestGenerator thing gen = (forall t ctx . ((forall wXx wYy . thing wXx wYy -> t) -> (gen ctx -> t)))+type TestCondition thing = (forall wYy wZz . thing wYy wZz -> Bool)+type TestCheck thing t = (forall wYy wZz . thing wYy wZz -> t)++-- arbitraryThing :: (forall wXx wYy . thing wXx wYy -> t) -> (thing wA wB -> t)+arbitraryThing :: x -> TestGenerator thing (thing x)+arbitraryThing _ f p = f p++-- | Run a test function on a set of data, using HUnit. The test function should+-- return @Nothing@ upon success and a @Just x@ upon failure.+testCases :: Show a => String -- ^ The test name+ -> (a -> TestResult) -- ^ The test function+ -> [a] -- ^ The test data+ -> Test+testCases name test datas = testCase name (assertBool assertName res)+ where assertName = "Boolean assertion for \"" ++ name ++ "\""+ res = and $ map (isOk . test) datas++unit_V1P1:: [Test]+unit_V1P1 =+ [ testCases "known commutes" Prop.checkCommute Ex.knownCommutes+ , testCases "known non-commutes" Prop.checkCantCommute Ex.knownCantCommutes+ , testCases "known merges" Prop.checkMerge Ex.knownMerges+ , testCases "known merges (equiv)" Prop.checkMergeEquiv Ex.knownMergeEquivs+ , testCases "known canons" Prop.checkCanon Ex.knownCanons+ , testCases "merge swaps" Prop.checkMergeSwap Ex.mergePairs2+ , testCases "the patch validation works" Prop.tTestCheck Ex.validPatches+ , testCases "commute/recommute" (Prop.recommute commute) Ex.commutePairs+ , testCases "merge properties: merge either way valid" Prop.tMergeEitherWayValid Ex.mergePairs+ , testCases "merge properties: merge swap" Prop.mergeEitherWay Ex.mergePairs+ , testCases "primitive patch IO functions" (Prop.tShowRead eqFLUnsafe) Ex.primitiveTestPatches+ , testCases "IO functions (test patches)" (Prop.tShowRead eqFLUnsafe) Ex.testPatches+ , testCases "IO functions (named test patches)" (Prop.tShowRead unsafeCompare) Ex.testPatchesNamed+ , testCases "primitive commute/recommute" (Prop.recommute commute) Ex.primitiveCommutePairs+ ]++unit_V2P1 :: [Test]+unit_V2P1 =+ [ testCases "coalesce commute" (PropU.coalesceCommute WSub.coalesce) ExU.primPermutables+ , testCases "prim recommute" (PropU.recommute WSub.commute) ExU.commutables+ , testCases "prim patch and inverse commute" (PropU.patchAndInverseCommute WSub.commute) ExU.commutables+ , testCases "prim inverses commute" (PropU.commuteInverses WSub.commute) ExU.commutables+ , testCases "FL prim recommute" (PropU.recommute WSub.commute) ExU.commutablesFL+ , testCases "FL prim patch and inverse commute" (PropU.patchAndInverseCommute WSub.commute) ExU.commutablesFL+ , testCases "FL prim inverses commute" (PropU.commuteInverses WSub.commute) $ ExU.commutablesFL+ , testCases "fails" (PropU.commuteFails WSub.commute) ([] :: [(V1.Prim WSub.:> V1.Prim) wX wY])+ , testCases "read and show work on Prim" PropU.show_read ExU.primPatches+ , testCases "read and show work on RealPatch" PropU.show_read ExU.realPatches+ , testCases "example flattenings work" PropU.consistentTreeFlattenings ExU.realPatchLoopExamples+ , testCases "real merge input consistent" (PropU.mergeArgumentsConsistent isConsistent) ExU.realMergeables+ , testCases "real merge input is forward" (PropU.mergeArgumentsConsistent isForward) ExU.realMergeables+ , testCases "real merge output is forward" (PropU.mergeConsistent isForward) ExU.realMergeables+ , testCases "real merge output consistent" (PropU.mergeConsistent isConsistent) ExU.realMergeables+ , testCases "real merge either way" PropU.mergeEitherWay ExU.realMergeables+ , testCases "real merge and commute" PropU.mergeCommute ExU.realMergeables++ , testCases "real recommute" (PropU.recommute WSub.commute) ExU.realCommutables+ , testCases "real inverses commute" (PropU.commuteInverses WSub.commute) ExU.realCommutables+ , testCases "real permutivity" (PropU.permutivity WSub.commute) ExU.realNonduplicateTriples+ , testCases "real partial permutivity" (PropU.partialPermutivity WSub.commute) ExU.realNonduplicateTriples+ ]++instance PrimPatch prim => Check (RealPatch prim) where+ checkPatch p = return $ isNothing $ isConsistent p++instance Check V3.Prim where+ checkPatch _ = return True -- XXX++commuteReals :: PrimPatch prim => (RealPatch prim :> RealPatch prim) wX wY -> Maybe ((RealPatch prim :> RealPatch prim) wX wY)+commuteReals = commute++qc_prim :: forall prim wX wY wA model.+ (PrimPatch prim, ArbitraryPrim prim, Show2 prim+ , model ~ ModelOf prim, RepoModel model+ , RepoState model ~ ApplyState (PrimOf prim)+ , Show1 (ModelOf prim)+ , Check prim, PrimPatchBase prim, PrimOf prim ~ prim+ , FromPrim prim+ , Show1 (prim wA)+ , Show1 ((prim :> prim) wA)+ , Show1 (WithState model prim wA)+ , Arbitrary (Sealed ((prim :> prim) wA))+ , Arbitrary (Sealed ((prim :> prim :> prim) wA))+ , Arbitrary (Sealed (prim wA))+ , Arbitrary (Sealed (FL prim wA))+ , Arbitrary (Sealed ((FL prim :> FL prim) wA))+ , Arbitrary (Sealed (WithState model prim wA))+ , Arbitrary (Sealed (WithState model (FL prim) wA))+ , Arbitrary (Sealed2 (WithState model (prim :> prim)))+ , Arbitrary (Sealed ((WithState model (prim :> prim)) wA))+ , Arbitrary (Sealed ((WithState model (FL prim :> FL prim)) wA))+ ) => prim wX wY -> [Test]+qc_prim p =+ -- The following fails because of setpref patches...+ -- testProperty "prim inverse doesn't commute" (inverseDoesntCommute :: Prim -> Maybe Doc)+ (if runCoalesceTests p then+ [ testProperty "prim coalesce effect preserving... "+ (unseal2 $ Prop.coalesceEffectPreserving coalesce :: Sealed2 (WithState model (prim :> prim)) -> TestResult)+ ]+ else [])+ ++ concat+ [ pair_properties (undefined :: prim wX wY) "arbitrary" arbitraryThing'+ , pair_properties (undefined :: FL prim wX wY) "arbitrary FL" arbitraryThing'+ , coalesce_properties (undefined :: prim wX wY) "arbitrary" arbitraryThing'+ , nonreal_commute_properties (undefined :: prim wX wY) "arbitrary" arbitraryThing'+ , nonreal_commute_properties (undefined :: FL prim wX wY) "arbitrary FL" arbitraryThing'+ , patch_properties (undefined :: prim wX wA) "arbitrary" arbitraryThing'+ , patch_properties (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing'+ , patch_repo_properties (undefined :: prim wX wA) "arbitrary" arbitraryThing'+ , patch_repo_properties (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing'+ , pair_repo_properties (undefined :: prim wX wA) "arbitrary" arbitraryThing'+ , pair_repo_properties (undefined :: FL prim wX wA) "arbitrary FL" arbitraryThing'+ ]+ where arbitraryThing' = arbitraryThing (undefined :: wA) -- bind the witness for generator++qc_V2P1 :: [Test]+qc_V2P1 =+ [ testProperty "tree flattenings are consistent... "+ Prop.propConsistentTreeFlattenings+ , testProperty "with quickcheck that real patches are consistent... "+ (unseal $ P1.patchFromTree $ fromMaybe . isConsistent)+ -- permutivity ----------------------------------------------------------------------------+ , testConditional "permutivity"+ (unseal $ P1.commuteTripleFromTree notDuplicatestriple)+ (unseal $ P1.commuteTripleFromTree $ Prop.permutivity commuteReals)+ , testConditional "partial permutivity"+ (unseal $ P1.commuteTripleFromTree notDuplicatestriple)+ (unseal $ P1.commuteTripleFromTree $ Prop.partialPermutivity commuteReals)+ , testConditional "nontrivial permutivity"+ (unseal $ P1.commuteTripleFromTree (\t -> nontrivialTriple t && notDuplicatestriple t))+ (unseal $ P1.commuteTripleFromTree $ (Prop.permutivity commuteReals))+ ]++qc_V2 :: forall prim wXx wYy . (PrimPatch prim, Show1 (ModelOf prim), RepoModel (ModelOf prim),+ Check (RealPatch prim), ArbitraryPrim prim, Show2 prim,+ RepoState (ModelOf prim) ~ ApplyState prim)+ => prim wXx wYy -> [Test]+qc_V2 _ =+ [ testProperty "readPatch and showPatch work on RealPatch... "+ (unseal $ patchFromTree $ (Prop.show_read :: RealPatch prim wX wY -> TestResult))+ , testProperty "readPatch and showPatch work on FL RealPatch... "+ (unseal2 $ (Prop.show_read :: FL (RealPatch prim) wX wY -> TestResult))+ , testProperty "we can do merges using QuickCheck"+ (isNothing . (Prop.propIsMergeable ::+ Sealed (WithStartState (ModelOf prim) (Tree prim))+ -> Maybe (Tree (RealPatch prim) wX)))+ ]+ ++ concat+ [ merge_properties (undefined :: RealPatch prim wX wY) "tree" mergePairFromTree+ , merge_properties (undefined :: RealPatch prim wX wY) "twfp" mergePairFromTWFP+ , pair_properties (undefined :: RealPatch prim wX wY) "tree" commutePairFromTree+ , pair_properties (undefined :: RealPatch prim wX wY) "twfp" commutePairFromTWFP+ , patch_properties (undefined :: RealPatch prim wX wY) "tree" patchFromTree+ ]++properties :: forall thing gen. (Show1 gen, Arbitrary (Sealed gen)) =>+ TestGenerator thing gen+ -- -> forall xx yy. thing xx yy+ -> String -> String+ -> forall t. Testable t => [(String, TestCondition thing, TestCheck thing t)]+ -> [Test]+properties gen prefix genname tests =+ [ cond name condition check | (name, condition, check) <- tests ]+ where cond :: forall testable. Testable testable+ => String -> TestCondition thing -> TestCheck thing testable -> Test+ cond t c p =+ testConditional (prefix ++ " (" ++ genname ++ "): " ++ t) (unseal $ gen c) (unseal $ gen p)++type PropList what gen = String -> TestGenerator what gen -> [Test]++pair_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, ShowPatchBasic p, MyEq p)+ => p x y -> PropList (p :> p) gen+pair_properties _ genname gen =+ properties gen "commute" genname+ [ ("recommute" , const True , Prop.recommute commute )+ , ("nontrivial recommute" , nontrivialCommute, Prop.recommute commute )+ , ("inverses commute" , const True , Prop.commuteInverses commute )+ , ("nontrivial inverses" , nontrivialCommute, Prop.commuteInverses commute )+ , ("inverse composition" , const True , Prop.inverseComposition )+ ]++coalesce_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, PrimPatch p, ArbitraryPrim p)+ => p x y -> PropList (p :> p :> p) gen+coalesce_properties p genname gen =+ properties gen "commute" genname+ (if runCoalesceTests p then [ ("coalesce commutes with commute", const True, Prop.coalesceCommute coalesce) ] else [])++-- The following properties do not hold for "Real" patches (conflictors and+-- duplicates, specifically) .+nonreal_commute_properties :: forall p gen x y+ . (Show1 gen, Arbitrary (Sealed gen), Patchy p, ShowPatchBasic p, MyEq p)+ => p x y -> PropList (p :> p) gen+nonreal_commute_properties _ genname gen =+ properties gen "commute" genname+ [ ("patch & inverse commute", const True , Prop.patchAndInverseCommute commute)+ , ("patch & inverse commute", nontrivialCommute, Prop.patchAndInverseCommute commute)+ ]++patch_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, MyEq p)+ => p x y -> PropList p gen+patch_properties _ genname gen =+ properties gen "patch" genname+ [ ("inverse . inverse is id" , const True , Prop.invertSymmetry)+ ]++patch_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen),+ Patchy p, ShowPatchBasic p,+ RepoModel (ModelOf (PrimOf p)),+ RepoState (ModelOf (PrimOf p)) ~ ApplyState p)+ => p x y -> PropList (WithState (ModelOf (PrimOf p)) p) gen+patch_repo_properties _ genname gen =+ properties gen "patch/repo" genname+ [ ("invert rollback" , const True , Prop.invertRollback)+ ]++pair_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p,+ RepoModel (ModelOf p),+ RepoState (ModelOf p) ~ ApplyState p)+ => p x y -> PropList (WithState (ModelOf p) (p :> p)) gen+pair_repo_properties _ genname gen =+ properties gen "patch/repo" genname+ [ ("commute is effect preserving" , const True , Prop.effectPreserving commute )+ ]++merge_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen)+ , Patchy p, MyEq p, Merge p, ShowPatchBasic p+ , Show2 p, Check p)+ => p x y -> PropList (p :\/: p) gen+merge_properties _ genname gen =+ properties gen "merge" genname+ [ ("merge either way" , const True , Prop.mergeEitherWay )+ , ("merge either way valid" , const True , Prop.tMergeEitherWayValid)+ , ("nontrivial merge either way", nontrivialMerge, Prop.mergeEitherWay )+ , ("merge commute" , const True , Prop.mergeCommute )+ ]++qc_V1P1 :: [Test]+qc_V1P1 =+ [+ testProperty "show and read work right" (unseal Prop.propReadShow)+ ]+ ++ Prop.checkSubcommutes Prop.subcommutesInverse "patch and inverse both commute"+ ++ Prop.checkSubcommutes Prop.subcommutesNontrivialInverse "nontrivial commutes are correct"+ ++ Prop.checkSubcommutes Prop.subcommutesFailure "inverses fail"+ +++ [ testProperty "commuting by patch and its inverse is ok" Prop.propCommuteInverse+ -- , testProperty "conflict resolution is valid... " Prop.propResolveConflictsValid+ , testProperty "a patch followed by its inverse is identity"+ Prop.propPatchAndInverseIsIdentity+ , testProperty "'simple smart merge'" Prop.propSimpleSmartMergeGoodEnough+ , testProperty "commutes are equivalent" Prop.propCommuteEquivalency+ , testProperty "merges are valid" Prop.propMergeValid+ , testProperty "inverses being valid" Prop.propInverseValid+ , testProperty "other inverse being valid" Prop.propOtherInverseValid+ -- The patch generator isn't smart enough to generate correct test cases for+ -- the following: (which will be obsoleted soon, anyhow)+ -- , testProperty "the order dependence of unravel... " Prop.propUnravelOrderIndependent+ -- , testProperty "the unravelling of three merges... " Prop.propUnravelThreeMerge+ -- , testProperty "the unravelling of a merge of a sequence... " Prop.propUnravelSeqMerge+ , testProperty "the order of commutes" Prop.propCommuteEitherOrder+ , testProperty "commute either way" Prop.propCommuteEitherWay+ , testProperty "the double commute" Prop.propCommuteTwice+ , testProperty "merges commute and are well behaved"+ Prop.propMergeIsCommutableAndCorrect+ , testProperty "merges can be swapped" Prop.propMergeIsSwapable+ , testProperty "again that merges can be swapped (I'm paranoid) " Prop.propMergeIsSwapable++ ] -- the following properties are disabled, because they routinely lead to+ -- exponential cases, making the tests run for ever and ever; nevertheless,+ -- we would expect them to hold+ {- ++ merge_properties (undefined :: V1.Patch Prim wX wY) "tree" mergePairFromTree+ ++ merge_properties (undefined :: V1.Patch Prim wX wY) "twfp" mergePairFromTWFP+ ++ commute_properties (undefined :: V1.Patch Prim wX wY) "tree" commutePairFromTree+ ++ commute_properties (undefined :: V1.Patch Prim wX wY) "twfp" commutePairFromTWFP -}++-- tests (either QuickCheck or Unit) that should be run on any type of patch+general_patchTests :: (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType p -> [Test]+general_patchTests pt =+ [ testGroup "Rebase patches" $ Rebase.testSuite pt+ ]++-- | This is the big list of tests that will be run using testrunner.+testSuite :: [Test]+testSuite = [ testGroup "Darcs.Patch.Prim.V1" $ qc_prim (undefined :: V1.Prim wX wY)+ , testGroup "Darcs.Patch.V1 (using Prim.V1)" $+ unit_V1P1 ++ qc_V1P1 ++ general_patchTests (PatchType :: PatchType (V1.Patch V1.Prim))+ , testGroup "Darcs.Patch.V2 (using Prim.V1)" $+ unit_V2P1 ++ qc_V2 (undefined :: V1.Prim wX wY) ++ qc_V2P1 +++ general_patchTests (PatchType :: PatchType (RealPatch V1.Prim))+ , testGroup "Darcs.Patch.Prim.V3" $ qc_prim (undefined :: V3.Prim wX wY)+ , testGroup "Darcs.Patch.V2 (using Prim.V3)" $+ qc_V2 (undefined :: V3.Prim wX wY) +++ general_patchTests (PatchType :: PatchType (RealPatch V3.Prim))+ , Darcs.Test.Patch.Info.testSuite+ ]
+ harness/Darcs/Test/Patch/Arbitrary/Generic.hs view
@@ -0,0 +1,243 @@+{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-}+{-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses,+ FlexibleInstances, ViewPatterns #-}++module Darcs.Test.Patch.Arbitrary.Generic+ ( Tree(..), TreeWithFlattenPos(..), G2(..), ArbitraryPrim(..), NullPatch(..), RepoModel(..)+ , flattenOne, flattenTree, mapTree, sizeTree+ , commutePairFromTree, mergePairFromTree+ , commuteTripleFromTree, mergePairFromCommutePair+ , commutePairFromTWFP, mergePairFromTWFP, getPairs, getTriples+ , patchFromTree+ , canonizeTree+ , quickCheck+ ) where++import Control.Monad ( liftM )+import Test.QuickCheck+import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Util.QuickCheck ( bSized )+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Merge ( Merge(..) )+import Darcs.Patch.Patchy ( Invert(..), Commute(..) )+import Darcs.Patch.Prim ( PrimOf, PrimPatch, PrimPatchBase, FromPrim(..), PrimConstruct( anIdentity ) )+import Darcs.Patch.Prim.V1 ()+import Darcs.Patch.V2 ( RealPatch ) -- XXX this is more or less a hack+--import Darcs.ColorPrinter ( errorDoc )+--import Darcs.ColorPrinter ( traceDoc )+import Darcs.Patch.Witnesses.Show+--import Darcs.Util.Printer ( greenText, ($$) )++-- | Generate a patch to a certain state.+class ArbitraryStateIn s p where+ arbitraryStateIn :: s wX -> Gen (p wX)++data Tree p wX where+ NilTree :: Tree p wX+ SeqTree :: p wX wY -> Tree p wY -> Tree p wX+ ParTree :: Tree p wX -> Tree p wX -> Tree p wX++mapTree :: (forall wY wZ . p wY wZ -> q wY wZ) -> Tree p wX -> Tree q wX+mapTree _ NilTree = NilTree+mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t)+mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2)++instance Show2 p => Show (Tree p wX) where+ showsPrec _ NilTree = showString "NilTree"+ showsPrec d (SeqTree a t) = showParen (d > appPrec) $ showString "SeqTree " .+ showsPrec2 (appPrec + 1) a . showString " " .+ showsPrec (appPrec + 1) t+ showsPrec d (ParTree t1 t2) = showParen (d > appPrec) $ showString "ParTree " .+ showsPrec (appPrec + 1) t1 . showString " " .+ showsPrec (appPrec + 1) t2++instance Show2 p => Show1 (Tree p) where+ showDict1 = ShowDictClass++instance Show2 p => Show1 (TreeWithFlattenPos p) where+ showDict1 = ShowDictClass++sizeTree :: Tree p wX -> Int+sizeTree NilTree = 0+sizeTree (SeqTree _ t) = 1 + sizeTree t+sizeTree (ParTree t1 t2) = 1 + sizeTree t1 + sizeTree t2++-- newtype G1 l p wX = G1 { _unG1 :: l (p wX) }+newtype G2 l p wX wY = G2 { unG2 :: l (p wX wY) }++flattenTree :: (Merge p) => Tree p wZ -> Sealed (G2 [] (FL p) wZ)+flattenTree NilTree = seal $ G2 $ return NilFL+flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t+flattenTree (ParTree (flattenTree -> Sealed gpss1) (flattenTree -> Sealed gpss2))+ = seal $ G2 $+ do ps1 <- unG2 gpss1+ ps2 <- unG2 gpss2+ ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2)+ -- We can't prove that the existential type in the result+ -- of merge will be the same for each pair of+ -- ps1 and ps2.+ map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1']++instance ArbitraryState s p => ArbitraryStateIn s (Tree p) where+ -- Don't generate trees deeper than 6 with default QuickCheck size (0..99).+ -- Note if we don't put a non-zero lower bound the first generated trees will always have depth 0.+ arbitraryStateIn rm = bSized 3 0.035 9 $ \depth -> arbitraryTree rm depth++-- | Generate a tree of patches, bounded by the depth @maxDepth@.+arbitraryTree :: ArbitraryState s p => s wX -> Int -> Gen (Tree p wX)+arbitraryTree rm depth+ | depth == 0 = return NilTree+ -- Note a probability of N for NilTree would imply ~(100*N)% of empty trees.+ -- For the purpose of this module empty trees are useless, but even when+ -- NilTree case is omitted there is still a small percentage of empty trees+ -- due to the generation of null-patches (empty-hunks) and the use of canonizeTree.+ | otherwise = frequency [(1, do Sealed (WithEndState p rm') <- arbitraryState rm+ t <- arbitraryTree rm' (depth - 1)+ return (SeqTree p t))+ ,(3, do t1 <- arbitraryTree rm (depth - 1)+ t2 <- arbitraryTree rm (depth - 1)+ return (ParTree t1 t2))]+++class NullPatch p where+ nullPatch :: p wX wY -> EqCheck wX wY++class ( ArbitraryState (ModelOf prim) prim+ , NullPatch prim+ , PrimPatch prim+ , RepoModel (ModelOf prim)+ )+ => ArbitraryPrim prim+ where+ -- hooks to disable certain kinds of tests for certain kinds of patches+ runCoalesceTests :: prim wX wY -> Bool+ runCoalesceTests _ = True++ hasPrimConstruct :: prim wX wY -> Bool+ hasPrimConstruct _ = True+++-- canonize a tree, removing any dead branches+canonizeTree :: NullPatch p => Tree p wX -> Tree p wX+canonizeTree NilTree = NilTree+canonizeTree (ParTree t1 t2)+ | NilTree <- canonizeTree t1 = canonizeTree t2+ | NilTree <- canonizeTree t2 = canonizeTree t1+ | otherwise = ParTree (canonizeTree t1) (canonizeTree t2)+canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t+ | otherwise = SeqTree p (canonizeTree t)+++instance (RepoModel model, ArbitraryPrim prim, model ~ ModelOf prim,+ ArbitraryState model prim) => Arbitrary (Sealed (WithStartState model (Tree prim))) where+ arbitrary = do repo <- aSmallRepo+ Sealed (WithStartState rm tree) <-+ liftM (seal . WithStartState repo) (arbitraryStateIn repo)+ return $ Sealed $ WithStartState rm (canonizeTree tree)++flattenOne :: (FromPrim p, Merge p) => Tree (PrimOf p) wX -> Sealed (FL p wX)+flattenOne NilTree = seal NilFL+flattenOne (SeqTree p (flattenOne -> Sealed ps)) = seal (fromPrim p :>: ps)+flattenOne (ParTree (flattenOne -> Sealed ps1) (flattenOne -> Sealed ps2)) =+ --traceDoc (greenText "flattening two parallel series: ps1" $$ showPatch ps1 $$+ -- greenText "ps2" $$ showPatch ps2) $+ case merge (ps1 :\/: ps2) of+ ps2' :/\: _ -> seal (ps1 +>+ ps2')++data TreeWithFlattenPos p wX = TWFP Int (Tree p wX)++commutePairFromTWFP :: (FromPrim p, Merge p, PrimPatchBase p)+ => (forall wY wZ . (p :> p) wY wZ -> t)+ -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) wX -> t)+commutePairFromTWFP handlePair (WithStartState _ (TWFP n t))+ = unseal2 handlePair $+ let xs = unseal getPairs (flattenOne t)+ in if length xs > n && n >= 0 then xs!!n else seal2 (fromPrim anIdentity :> fromPrim anIdentity)++commutePairFromTree :: (FromPrim p, Merge p, PrimPatchBase p)+ => (forall wY wZ . (p :> p) wY wZ -> t)+ -> (WithStartState model (Tree (PrimOf p)) wX -> t)+commutePairFromTree handlePair (WithStartState _ t)+ = unseal2 handlePair $+ case flattenOne t of+ Sealed ps ->+ let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $+ getPairs ps+ in if null xs then seal2 (fromPrim anIdentity :> fromPrim anIdentity) else last xs++commuteTripleFromTree :: (FromPrim p, Merge p, PrimPatchBase p)+ => (forall wY wZ . (p :> p :> p) wY wZ -> t)+ -> (WithStartState model (Tree (PrimOf p)) wX -> t)+commuteTripleFromTree handle (WithStartState _ t)+ = unseal2 handle $+ case flattenOne t of+ Sealed ps ->+ let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $+ getTriples ps+ in if null xs+ then seal2 (fromPrim anIdentity :> fromPrim anIdentity :> fromPrim anIdentity)+ else last xs++mergePairFromCommutePair :: (Commute p, Invert p)+ => (forall wY wZ . (p :\/: p) wY wZ -> t)+ -> (forall wY wZ . (p :> p) wY wZ -> t)+mergePairFromCommutePair handlePair (a :> b)+ = case commute (a :> b) of+ Just (b' :> _) -> handlePair (a :\/: b')+ Nothing -> handlePair (b :\/: b)++-- impredicativity problems mean we can't use (.) in the definitions below++mergePairFromTWFP :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)+ => (forall wY wZ . (p :\/: p) wY wZ -> t)+ -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) wX -> t)+mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x)++mergePairFromTree :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)+ => (forall wY wZ . (p :\/: p) wY wZ -> t)+ -> (WithStartState model (Tree (PrimOf p)) wX -> t)+mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x)++patchFromCommutePair :: (Commute p, Invert p)+ => (forall wY wZ . p wY wZ -> t)+ -> (forall wY wZ . (p :> p) wY wZ -> t)+patchFromCommutePair handle (_ :> b) = handle b++patchFromTree :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)+ => (forall wY wZ . p wY wZ -> t)+ -> (WithStartState model (Tree (PrimOf p)) wX -> t)+patchFromTree x = commutePairFromTree (patchFromCommutePair x)+++instance Show2 p => Show (TreeWithFlattenPos p wX) where+ showsPrec d (TWFP n t) = showParen (d > appPrec) $ showString "TWFP " .+ showsPrec (appPrec + 1) n . showString " " .+ showsPrec1 (appPrec + 1) t++getPairs :: FL p wX wY -> [Sealed2 (p :> p)]+getPairs NilFL = []+getPairs (_:>:NilFL) = []+getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c)++getTriples :: FL p wX wY -> [Sealed2 (p :> p :> p)]+getTriples NilFL = []+getTriples (_:>:NilFL) = []+getTriples (_:>:_:>:NilFL) = []+getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d)++instance (ArbitraryPrim prim, RepoModel (ModelOf prim), model ~ ModelOf prim,+ ArbitraryState model prim)+ => Arbitrary (Sealed (WithStartState model (TreeWithFlattenPos prim))) where+ arbitrary = do Sealed (WithStartState rm t) <- arbitrary+ let num = unseal (length . getPairs) (flattenOneRP t)+ if num == 0 then return $ Sealed $ WithStartState rm $ TWFP 0 NilTree+ else do n <- choose (0, num - 1)+ return $ Sealed $ WithStartState rm $ TWFP n t+ where -- just used to get the length. In principle this should be independent of the patch type.+ flattenOneRP :: Tree prim wX -> Sealed (FL (RealPatch prim) wX)+ flattenOneRP = flattenOne+
+ harness/Darcs/Test/Patch/Arbitrary/PatchV1.hs view
@@ -0,0 +1,287 @@+-- Copyright (C) 2002-2003,2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}+++module Darcs.Test.Patch.Arbitrary.PatchV1 () where++import Prelude hiding ( pi )+import System.IO.Unsafe ( unsafePerformIO )+import Test.QuickCheck+import Control.Applicative+import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM )++import Darcs.Patch.Info ( PatchInfo, patchinfo )+import qualified Data.ByteString as B ( ByteString )+import qualified Data.ByteString.Char8 as BC ( pack )++import Darcs.Patch ( addfile, adddir, move,+ hunk, tokreplace, binary,+ changepref, invert, merge )+import Darcs.Patch.V1 ()+import qualified Darcs.Patch.V1.Core as V1 ( Patch(..) )+import Darcs.Patch.Prim.V1 ()+import Darcs.Patch.Prim.V1.Core ( Prim(..) )+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) )+import Darcs.Patch.Witnesses.Unsafe++-- This definitely feels a bit weird to be importing Properties here, and+-- probably means we want to move this elsewhere, but Darcs.Test.Patch.Check is+-- already taken with something apparently only semi-related+import Darcs.Test.Patch.Properties.Check( checkAPatch )++#include "impossible.h"++type Patch = V1.Patch Prim++class ArbitraryP p where+ arbitraryP :: Gen (Sealed (p wX))++{-+TODO: there is a lot of overlap in testing between between this module+and Darcs.Test.Patch.QuickCheck++This module tests Prim and V1 patches, and Darcs.Test.Patch.QuickCheck+tests Prim and V2 patches++This module's generator covers a wider set of patch types, but is less+likely to generate conflicts than Darcs.Test.Patch.QuickCheck.++Until this is cleaned up, we take some care that the Arbitrary instances+do not overlap and are only used for tests from the respective+modules.++(There are also tests in other modules that probably depend on the+Arbitrary instances in this module.)+-}++instance Arbitrary (Sealed (Prim wX)) where+ arbitrary = arbitraryP++instance Arbitrary (Sealed (FL Patch wX)) where+ arbitrary = arbitraryP++-- instance Arbitrary (Sealed2 (Prim :> Prim)) where+ -- arbitrary = unseal Sealed2 <$> arbitraryP++instance Arbitrary (Sealed2 (FL Patch)) where+ arbitrary = unseal Sealed2 <$> arbitraryP++instance Arbitrary (Sealed2 (FL Patch :\/: FL Patch)) where+ arbitrary = unseal Sealed2 <$> arbitraryP++instance Arbitrary (Sealed2 (FL Patch :> FL Patch)) where+ arbitrary = unseal Sealed2 <$> arbitraryP++instance Arbitrary (Sealed2 (FL Patch :> FL Patch :> FL Patch)) where+ arbitrary = unseal Sealed2 <$> arbitraryP+++instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :> p2) where+ arbitraryP = do Sealed p1 <- arbitraryP+ Sealed p2 <- arbitraryP+ return (Sealed (p1 :> p2))++instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :\/: p2) where+ arbitraryP = do Sealed p1 <- arbitraryP+ Sealed p2 <- arbitraryP+ return (Sealed (unsafeCoercePEnd p1 :\/: p2))++instance ArbitraryP (FL Patch) where+ arbitraryP = sized arbpatch++instance ArbitraryP Prim where+ arbitraryP = onepatchgen++hunkgen :: Gen (Sealed (Prim wX))+hunkgen = do+ i <- frequency [(1,choose (0,5)),(1,choose (0,35)),+ (2,return 0),(3,return 1),(2,return 2),(1,return 3)]+ j <- frequency [(1,choose (0,5)),(1,choose (0,35)),+ (2,return 0),(3,return 1),(2,return 2),(1,return 3)]+ if i == 0 && j == 0 then hunkgen+ else Sealed <$>+ liftM4 hunk filepathgen linenumgen+ (replicateM i filelinegen)+ (replicateM j filelinegen)++tokreplacegen :: Gen (Sealed (Prim wX))+tokreplacegen = do+ f <- filepathgen+ o <- tokengen+ n <- tokengen+ if o == n+ then return $ Sealed $ tokreplace f "A-Za-z" "old" "new"+ else return $ Sealed $ tokreplace f "A-Za-z_" o n++twofilegen :: (forall wY . FilePath -> FilePath -> Prim wX wY) -> Gen (Sealed (Prim wX))+twofilegen p = do+ n1 <- filepathgen+ n2 <- filepathgen+ if n1 /= n2 && checkAPatch (p n1 n2)+ then return $ Sealed $ p n1 n2+ else twofilegen p++chprefgen :: Gen (Sealed (Prim wX))+chprefgen = do+ f <- oneof [return "color", return "movie"]+ o <- tokengen+ n <- tokengen+ if o == n then return $ Sealed $ changepref f "old" "new"+ else return $ Sealed $ changepref f o n++simplepatchgen :: Gen (Sealed (Prim wX))+simplepatchgen = frequency [(1,liftM (Sealed . addfile) filepathgen),+ (1,liftM (Sealed . adddir) filepathgen),+ (1,liftM3 (\x y z -> Sealed (binary x y z)) filepathgen arbitrary arbitrary),+ (1,twofilegen move),+ (1,tokreplacegen),+ (1,chprefgen),+ (7,hunkgen)+ ]++onepatchgen :: Gen (Sealed (Prim wX))+onepatchgen = oneof [simplepatchgen, mapSeal (invert . unsafeCoerceP) `fmap` simplepatchgen]++norecursgen :: Int -> Gen (Sealed (FL Patch wX))+norecursgen 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen+norecursgen n = oneof [mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen,flatcompgen n]++arbpatch :: Int -> Gen (Sealed (FL Patch wX))+arbpatch 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen+arbpatch n = frequency [(3,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen),+ (2,flatcompgen n),+ (0,rawMergeGen n),+ (0,mergegen n),+ (1,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen)+ ]++-- | Generate an arbitrary list of at least one element+unempty :: Arbitrary a => Gen [a]+unempty = do+ a <- arbitrary+ as <- arbitrary+ return (a:as)++rawMergeGen :: Int -> Gen (Sealed (FL Patch wX))+rawMergeGen n = do Sealed p1 <- arbpatch len+ Sealed p2 <- arbpatch len+ if checkAPatch (invert p1:>:p2:>:NilFL) &&+ checkAPatch (invert p2:>:p1:>:NilFL)+ then case merge (p2 :\/: p1) of+ _ :/\: p2' -> return (Sealed (unsafeCoercePStart p2'))+ else rawMergeGen n+ where len = if n < 15 then n`div`3 else 3++mergegen :: Int -> Gen (Sealed (FL Patch wX))+mergegen n = do+ Sealed p1 <- norecursgen len+ Sealed p2 <- norecursgen len+ if checkAPatch (invert p1:>:p2:>:NilFL) &&+ checkAPatch (invert p2:>:p1:>:NilFL)+ then case merge (p2:\/:p1) of+ _ :/\: p2' ->+ if checkAPatch (p1+>+p2')+ then return $ Sealed $ p1+>+p2'+ else impossible+ else mergegen n+ where len = if n < 15 then n`div`3 else 3++arbpi :: Gen PatchInfo+arbpi = do n <- unempty+ a <- unempty+ l <- unempty+ d <- unempty+ return $ unsafePerformIO $ patchinfo n d a l++instance Arbitrary PatchInfo where+ arbitrary = arbpi++instance Arbitrary B.ByteString where+ arbitrary = liftM BC.pack arbitrary++flatlistgen :: Int -> Gen (Sealed (FL Patch wX))+flatlistgen 0 = return $ Sealed NilFL+flatlistgen n = do Sealed x <- onepatchgen+ Sealed xs <- flatlistgen (n-1)+ return (Sealed (V1.PP x :>: xs))++flatcompgen :: Int -> Gen (Sealed (FL Patch wX))+flatcompgen n = do+ Sealed ps <- flatlistgen n+ let myp = regularizePatches $ ps+ if checkAPatch myp+ then return $ Sealed myp+ else flatcompgen n++-- resize to size 25, that means we'll get line numbers no greater+-- than 1025 using QuickCheck 2.1+linenumgen :: Gen Int+linenumgen = frequency [(1,return 1), (1,return 2), (1,return 3),+ (3,liftM (\n->1+abs n) (resize 25 arbitrary)) ]++tokengen :: Gen String+tokengen = oneof [return "hello", return "world", return "this",+ return "is", return "a", return "silly",+ return "token", return "test"]++toklinegen :: Gen String+toklinegen = liftM unwords $ replicateM 3 tokengen++filelinegen :: Gen B.ByteString+filelinegen = liftM BC.pack $+ frequency [(1,map fromSafeChar `fmap` arbitrary),(5,toklinegen),+ (1,return ""), (1,return "{"), (1,return "}") ]++filepathgen :: Gen String+filepathgen = liftM fixpath badfpgen++fixpath :: String -> String+fixpath "" = "test"+fixpath p = fpth p++fpth :: String -> String+fpth ('/':'/':cs) = fpth ('/':cs)+fpth (c:cs) = c : fpth cs+fpth [] = []++newtype SafeChar = SS Char+instance Arbitrary SafeChar where+ arbitrary = oneof $ map (return . SS) (['a'..'z']++['A'..'Z']++['1'..'9']++"0")++fromSafeChar :: SafeChar -> Char+fromSafeChar (SS s) = s++badfpgen :: Gen String+badfpgen = frequency [(1,return "test"), (1,return "hello"), (1,return "world"),+ (1,map fromSafeChar `fmap` arbitrary),+ (1,liftM2 (\a b-> a++"/"++b) filepathgen filepathgen) ]++regularizePatches :: FL Patch wX wY -> FL Patch wX wY+regularizePatches patches = rpint (unsafeCoerceP NilFL) patches+ where -- this reverses the list, which seems odd and causes+ -- the witness unsafety+ rpint :: FL Patch wX wY -> FL Patch wA wB -> FL Patch wX wY+ rpint ok_ps NilFL = ok_ps+ rpint ok_ps (p:>:ps) =+ if checkAPatch (unsafeCoerceP p:>:ok_ps)+ then rpint (unsafeCoerceP p:>:ok_ps) ps+ else rpint ok_ps ps+
+ harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs view
@@ -0,0 +1,392 @@+{-# LANGUAGE CPP, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Darcs.Test.Patch.Arbitrary.PrimV1 where++import qualified Darcs.Test.Patch.Arbitrary.Generic as T+ ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP+ , mergePairFromTree, mergePairFromTWFP+ , patchFromTree )+import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.RepoModel++import Control.Monad ( liftM )+import Test.QuickCheck+import Darcs.Test.Patch.WithState+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Prim.V1 ()+import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk, TokReplace ), Prim( FP ), isIdentity )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.FileHunk( IsHunk( isHunk ), FileHunk(..) )++import Darcs.Test.Patch.V1Model+import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )++import Darcs.UI.Commands.Replace ( defaultToks )+import Darcs.Patch.Prim++import Control.Applicative ( (<$>) )+import qualified Data.ByteString.Char8 as BC+import Data.Maybe ( isJust )++#include "impossible.h"++patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t+patchFromTree = T.patchFromTree++mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t+mergePairFromTree = T.mergePairFromTree++mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos Prim) wX -> t+mergePairFromTWFP = T.mergePairFromTWFP++commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (TreeWithFlattenPos Prim) wX -> t+commutePairFromTWFP = T.commutePairFromTWFP++commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t+commutePairFromTree = T.commutePairFromTree++commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState V1Model (Tree Prim) wX -> t+commuteTripleFromTree = T.commuteTripleFromTree++nonEmptyHunk :: (IsHunk p) => p wX wY -> Bool+nonEmptyHunk p+ | Just (FileHunk _ _ [] []) <- isHunk p = False+ | otherwise = True++nonEmptyHunksPair :: (IsHunk p) => (p :> p) wX wY -> Bool+nonEmptyHunksPair (p1 :> p2) = nonEmptyHunk p1 && nonEmptyHunk p2++nonEmptyHunksTriple :: (IsHunk p) => (p :> p :> p) wX wY -> Bool+nonEmptyHunksTriple (p1 :> p2 :> p3) = nonEmptyHunk p1 && nonEmptyHunk p2 && nonEmptyHunk p3++nonEmptyHunksFLPair :: (IsHunk p) => (FL p :> FL p) wX wY -> Bool+nonEmptyHunksFLPair (ps :> qs) = allFL nonEmptyHunk ps && allFL nonEmptyHunk qs++type instance ModelOf Prim = V1Model+instance ArbitraryPrim Prim++instance NullPatch Prim where+ nullPatch (FP _ fp) = nullPatch fp+ nullPatch p | IsEq <- isIdentity p = IsEq+ nullPatch _ = NotEq++instance NullPatch FilePatchType where+ nullPatch (Hunk _ [] []) = unsafeCoerceP IsEq -- is this safe?+ nullPatch _ = NotEq++instance Arbitrary (Sealed2 (FL (WithState V1Model Prim))) where+ arbitrary = do repo <- ourSmallRepo+ liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo++-- instance Show1 (TreeWithFlattenPos Prim) where+-- showDict1 = ShowDictClass++-- WithState and propFail are handy for debugging arbitrary code+propFail :: Int -> Tree Prim wX -> Bool+propFail n xs = sizeTree xs < n++----------------------------------------------------------------------+-- * QuickCheck generators++----------------------------------------------------------------------+-- ** FilePatchType generators++aHunk :: forall wX wY . Content -> Gen (FilePatchType wX wY)+aHunk content+ = sized $ \n ->+ do pos <- choose (1, contentLen+1)+ let prefixLen = pos-1+ restLen = contentLen-prefixLen+ oldLen <- frequency+ [ (75, choose (0, min restLen n))+ -- produces small hunks common in real editing+ , (25, choose (0, min 10 restLen))+ ]+ -- newLen choice aims to cover all possibilities, that is,+ -- remove less/the same/more than added and empty the file.+ newLen <- frequency+ [ ( 54+ , choose (1,min 1 n)+ )+ , ( if oldLen /= 0 then 42 else 0+ , choose (1,min 1 oldLen)+ )+ , ( if oldLen /= 0 then 2 else 0+ , return oldLen+ )+ , ( if oldLen /= 0 then 2 else 0+ , return 0+ )+ ]+ new <- vectorOf newLen aLine+ let old = take oldLen $ drop prefixLen $ content+ return $ Hunk pos old new+ where+ contentLen = length content++aTokReplace :: forall wX wY . Content -> Gen (FilePatchType wX wY)+aTokReplace []+ = do w <- vectorOf 1 alpha+ w' <- vectorOf 1 alpha+ return $ TokReplace defaultToks w w'+aTokReplace content+ = do let fileWords = concatMap BC.words content+ wB <- elements fileWords+ w' <- alphaBS `notIn` fileWords+ return $ TokReplace defaultToks (BC.unpack wB) (BC.unpack w')+ where+ alphaBS = do x <- alpha; return $ BC.pack [x]++----------------------------------------------------------------------+-- ** Prim generators++aHunkP :: forall wX wY . (AnchoredPath,File) -> Gen (Prim wX wY)+aHunkP (path,file)+ = do Hunk pos old new <- aHunk content+ return $ hunk (ap2fp path) pos old new+ where+ content = fileContent file++aTokReplaceP :: forall wX wY . (AnchoredPath,File) -> Gen (Prim wX wY)+aTokReplaceP (path,file)+ = do TokReplace tokchars old new <- aTokReplace content+ return $ tokreplace (ap2fp path) tokchars old new+ where+ content = fileContent file++anAddFileP :: forall wX wY . (AnchoredPath,Dir) -> Gen (Prim wX wY)+anAddFileP (path,dir)+ = do newFilename <- aFilename `notIn` existing+ let newPath = path `appendPath` newFilename+ return $ addfile (ap2fp newPath)+ where+ existing = map fst $ filterFiles $ dirContent dir++aRmFileP :: forall wX wY . AnchoredPath -- ^ Path of an empty file+ -> Prim wX wY+aRmFileP path = rmfile (ap2fp path)++anAddDirP :: forall wX wY . (AnchoredPath,Dir) -> Gen (Prim wX wY)+anAddDirP (path,dir)+ = do newDirname <- aDirname `notIn` existing+ let newPath = path `appendPath` newDirname+ return $ adddir (ap2fp newPath)+ where+ existing = map fst $ filterDirs $ dirContent dir++aRmDirP :: forall wX wY . AnchoredPath -- ^ Path of an empty directory+ -> Prim wX wY+aRmDirP path = rmdir (ap2fp path)++aMoveP :: forall wX wY . Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (Prim wX wY)+aMoveP nameGen oldPath (dirPath,dir)+ = do newName <- nameGen `notIn` existing+ let newPath = dirPath `appendPath` newName+ return $ move (ap2fp oldPath) (ap2fp newPath)+ where+ existing = map fst $ dirContent dir++-- | Generates any type of 'Prim' patch, except binary and setpref patches.+aPrim :: forall wX wY . V1Model wX -> Gen (WithEndState V1Model (Prim wX) wY)+aPrim repo+ = do mbFile <- maybeOf repoFiles+ mbEmptyFile <- maybeOf $ filter (isEmpty . snd) repoFiles+ dir <- elements (rootDir:repoDirs)+ mbOldDir <- maybeOf repoDirs+ mbEmptyDir <- maybeOf $ filter (isEmpty . snd) repoDirs+ patch <- frequency+ [ ( if isJust mbFile then 12 else 0+ , aHunkP $ fromJust mbFile+ )+ , ( if isJust mbFile then 6 else 0+ , aTokReplaceP $ fromJust mbFile+ )+ , ( 2+ , anAddFileP dir+ )+ , ( if isJust mbEmptyFile then 12 else 0+ , return $ aRmFileP $ fst $ fromJust mbEmptyFile+ )+ , ( 2+ , anAddDirP dir+ )+ , ( if isJust mbEmptyDir then 10 else 0+ , return $ aRmDirP $ fst $ fromJust mbEmptyDir+ )+ , ( if isJust mbFile then 3 else 0+ , aMoveP aFilename (fst $ fromJust mbFile) dir+ )+ , let oldPath = fst $ fromJust mbOldDir in+ ( if isJust mbOldDir+ && not (oldPath `isPrefix` fst dir)+ then 4 else 0+ , aMoveP aDirname oldPath dir+ )+ ]+ let repo' = unFail $ repoApply repo patch+ return $ WithEndState patch repo'+ where+ repoItems = list repo+ repoFiles = filterFiles repoItems+ repoDirs = filterDirs repoItems+ rootDir = (anchoredRoot,root repo)++{- [COVERAGE OF aPrim]++ PLEASE,+ if you change something that may affect the coverage of aPrim then+ a) recalculate it, or if that is not possible;+ b) indicate the need to do it.++ Patch type+ ----------+ 42% hunk+ 22% tokreplace+ 14% move+ 6% rmdir+ 6% addfile+ 6% adddir+ 4% rmfile+-}++----------------------------------------------------------------------+-- *** Pairs of primitive patches++-- Try to generate commutable pairs of hunks+hunkPairP :: forall wX wY . (AnchoredPath,File) -> Gen ((Prim :> Prim) wX wY)+hunkPairP (path,file)+ = do h1@(Hunk l1 old1 new1) <- aHunk content+ (delta, content') <- selectChunk h1 content+ Hunk l2' old2 new2 <- aHunk content'+ let l2 = l2'+delta+ return (hunk fpPath l1 old1 new1 :> hunk fpPath l2 old2 new2)+ where+ content = fileContent file+ fpPath = ap2fp path+ selectChunk (Hunk l old new) content_+ = elements [prefix, suffix]+ where+ start = l - 1+ prefix = (0, take start content_)+ suffix = (start + length new, drop (start + length old) content_)+ selectChunk _ _ = impossible++aPrimPair :: forall wX wY . V1Model wX -> Gen (WithEndState V1Model ((Prim :> Prim) wX) wY)+aPrimPair repo+ = do mbFile <- maybeOf repoFiles+ frequency+ [ ( if isJust mbFile then 1 else 0+ , do p1 :> p2 <- hunkPairP $ fromJust mbFile+ let repo' = unFail $ repoApply repo p1+ repo'' = unFail $ repoApply repo' p2+ return $ WithEndState (p1 :> p2) repo''+ )+ , ( 1+ , do Sealed wesP <- arbitraryState repo+ return $ unsafeCoerceP1 wesP+ )+ ]+ where+ repoItems = list repo+ repoFiles = filterFiles repoItems++{- [COVERAGE OF aPrimPair]++ PLEASE,+ if you change something that may affect the coverage of aPrimPair then+ a) recalculate it, or if that is not possible;+ b) indicate the need to do it.++ Rate of ommutable pairs+ -----------------------+ 67% commutable++ Commutable coverage (for 1000 tests)+ -------------------+ 21% hunks-B+ 20% hunks-A+ 14% file:>dir+ 12% file:>move+ 8% trivial-FP+ 8% hunk:>tok+ 4% hunks-D+ 3% tok:>tok+ 2% hunks-C+ 1% move:>move+ 1% dir:>move+ 1% dir:>dir+ 0% emptyhunk:>file+-}++----------------------------------------------------------------------+-- Arbitrary instances++ourSmallRepo :: Gen (V1Model wX)+ourSmallRepo = aSmallRepo++instance ArbitraryState V1Model Prim where+ arbitraryState s = seal <$> aPrim s+++instance Arbitrary (Sealed2 Prim) where+ arbitrary = makeS2Gen ourSmallRepo++instance Arbitrary (Sealed2 (Prim :> Prim)) where+ arbitrary = do repo <- ourSmallRepo+ WithEndState pp _ <- aPrimPair repo+ return $ seal2 pp++instance Arbitrary (Sealed ((Prim :> Prim) wA)) where+ arbitrary = do repo <- ourSmallRepo+ WithEndState pp _ <- aPrimPair repo+ return $ seal pp++instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where+ arbitrary = makeS2Gen ourSmallRepo++instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where+ arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed2 (FL Prim)) where+ arbitrary = makeS2Gen ourSmallRepo++instance Arbitrary (Sealed ((FL Prim) wA)) where+ arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where+ arbitrary = makeS2Gen ourSmallRepo++instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where+ arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed2 (WithState V1Model Prim)) where+ arbitrary = makeWS2Gen ourSmallRepo++instance Arbitrary (Sealed (WithState V1Model Prim wA)) where+ arbitrary = makeWSGen ourSmallRepo++instance Arbitrary (Sealed (WithState V1Model (FL Prim) wA)) where+ arbitrary = makeWSGen ourSmallRepo++instance Arbitrary (Sealed2 (WithState V1Model (Prim :> Prim))) where+ arbitrary = do repo <- ourSmallRepo+ WithEndState pp repo' <- aPrimPair repo+ return $ seal2 $ WithState repo pp repo'++instance Arbitrary (Sealed (WithState V1Model (Prim :> Prim) a)) where+ arbitrary = do repo <- ourSmallRepo+ WithEndState pp repo' <- aPrimPair repo+ return $ seal $ WithState repo pp repo'+++instance Arbitrary (Sealed2 (WithState V1Model (FL Prim))) where+ arbitrary = makeWS2Gen ourSmallRepo++instance Arbitrary (Sealed2 (WithState V1Model (FL Prim :> FL Prim))) where+ arbitrary = makeWS2Gen ourSmallRepo++instance Arbitrary (Sealed (WithState V1Model (FL Prim :> FL Prim) a)) where+ arbitrary = makeWSGen ourSmallRepo
+ harness/Darcs/Test/Patch/Arbitrary/PrimV3.hs view
@@ -0,0 +1,259 @@+-- TODO: Remove these warning disabling flags...+{-# OPTIONS_GHC -w #-}+{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-}+module Darcs.Test.Patch.Arbitrary.PrimV3 where++import qualified Darcs.Test.Patch.Arbitrary.Generic as T+ ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP+ , mergePairFromTree, mergePairFromTWFP+ , patchFromTree )+import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.RepoModel++import Control.Monad ( liftM )+import Test.QuickCheck+import Darcs.Test.Patch.WithState+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Prim.V3 ()+import Darcs.Patch.Prim.V3.Core ( Prim(..), Location, Hunk(..), UUID(..) )+import Darcs.Patch.RepoPatch ( RepoPatch )++import Darcs.Test.Patch.V3Model+import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )++import Darcs.UI.Commands.Replace ( defaultToks )+import Darcs.Patch.Prim++import Control.Applicative ( (<$>) )+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString as BS+import Data.Maybe ( isJust )+import qualified Data.Map as M+import Storage.Hashed.Hash( Hash(..) )++#include "impossible.h"++patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . p wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t+patchFromTree = T.patchFromTree++mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t+mergePairFromTree = T.mergePairFromTree++mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :\/: p) wY wZ -> t) -> WithStartState V3Model (TreeWithFlattenPos Prim) wX -> t+mergePairFromTWFP = T.mergePairFromTWFP++commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V3Model (TreeWithFlattenPos Prim) wX -> t+commutePairFromTWFP = T.commutePairFromTWFP++commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p) wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t+commutePairFromTree = T.commutePairFromTree++commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (forall wY wZ . (p :> p :> p) wY wZ -> t) -> WithStartState V3Model (Tree Prim) wX -> t+commuteTripleFromTree = T.commuteTripleFromTree++type instance ModelOf Prim = V3Model+instance ArbitraryPrim Prim where+ runCoalesceTests _ = False+ hasPrimConstruct _ = False++hunkIdentity (Hunk _ old new) | old == new = unsafeCoerceP IsEq+hunkIdentity _ = NotEq++instance NullPatch Prim where+ nullPatch (BinaryHunk _ x) = hunkIdentity x+ nullPatch (TextHunk _ x) = hunkIdentity x+ nullPatch _ = NotEq++instance Arbitrary (Sealed2 (FL (WithState V3Model Prim))) where+ arbitrary = do repo <- ourSmallRepo+ liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo++-- instance Show1 (TreeWithFlattenPos Prim) where+-- showDict1 = ShowDictClass++-- WithState and propFail are handy for debugging arbitrary code+propFail :: Int -> Tree Prim wX -> Bool+propFail n xs = sizeTree xs < n++----------------------------------------------------------------------+-- * QuickCheck generators++aHunk :: forall wX wY . BS.ByteString -> Gen (Hunk wX wY)+aHunk content+ = sized $ \n ->+ do pos <- choose (0, BS.length content)+ let prefixLen = pos+ restLen = BS.length content - prefixLen+ oldLen <- frequency+ [ (75, choose (0, min restLen n))+ , (25, choose (0, min 10 restLen))+ ]+ let nonempty x = if oldLen /= 0 then x else 0+ newLen <- frequency+ [ ( 54, choose (1,min 1 n) )+ , ( nonempty 42, choose (1,min 1 oldLen) )+ , ( nonempty 2, return oldLen )+ , ( nonempty 2, return 0 )+ ]+ new <- BS.concat <$> vectorOf newLen aLine+ let old = BS.take oldLen $ BS.drop prefixLen $ content+ return $ Hunk pos old new++aTextHunk :: forall wX wY . (UUID, Object Fail) -> Gen (Prim wX wY)+aTextHunk (uuid, (Blob text _)) =+ do hunk <- aHunk (unFail text)+ return $ TextHunk uuid hunk++aManifest :: forall wX wY . UUID -> Location -> Object Fail -> Gen (Prim wX wY)+aManifest uuid loc (Directory dir) =+ do newFilename <- aFilename `notIn` (M.keys dir)+ return $ Manifest uuid loc++aDemanifest :: forall wX wY . UUID -> Location -> Gen (Prim wX wY)+aDemanifest uuid loc = return $ Demanifest uuid loc++-- | Generates any type of 'Prim' patch, except binary and setpref patches.+aPrim :: forall wX wY . V3Model wX -> Gen (WithEndState V3Model (Prim wX) wY)+aPrim repo+ = do mbFile <- maybeOf repoFiles+ mbDir <- maybeOf repoDirs+ mbExisting <- maybeOf $ repoObjects repo+ mbManifested <- maybeOf manifested+ fresh <- anUUID+ filename <- aFilename+ dir <- elements (rootDir:repoDirs)+ mbOtherDir <- maybeOf repoDirs+ let whenfile x = if isJust mbFile then x else 0+ whendir x = if isJust mbDir then x else 0+ whenexisting x = if isJust mbExisting then x else 0+ whenmanifested x = if isJust mbManifested then x else 0+ patch <- frequency+ [ ( whenfile 12, aTextHunk $ fromJust mbFile )+ , ( 2, aTextHunk (fresh, Blob (return "") NoHash) ) -- create an empty thing+ , ( whenexisting (whendir 2), -- manifest an existing object+ aManifest (fst $ fromJust mbExisting)+ (fst $ fromJust mbDir, filename)+ (snd $ fromJust mbDir))+ , ( whenmanifested 2, uncurry aDemanifest $ fromJust mbManifested )+ -- TODO: demanifest+ ]+ let repo' = unFail $ repoApply repo patch+ return $ WithEndState patch repo'+ where+ manifested = [ (id, (dirid, name)) | (dirid, Directory dir) <- repoDirs+ , (name, id) <- M.toList dir ]+ repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ]+ repoDirs = [ (id, Directory x) | (id, Directory x) <- repoObjects repo ]+ rootDir = (UUID "ROOT", root repo)++----------------------------------------------------------------------+-- *** Pairs of primitive patches++-- Try to generate commutable pairs of hunks+hunkPair :: forall wX wY . (UUID, Object Fail) -> Gen ((Prim :> Prim) wX wY)+hunkPair (uuid, (Blob file _)) =+ do h1@(Hunk l1 old1 new1) <- aHunk (unFail file)+ (delta, content') <- selectChunk h1 (unFail file)+ Hunk l2' old2 new2 <- aHunk content'+ let l2 = l2'+delta+ return (TextHunk uuid (Hunk l1 old1 new1) :> TextHunk uuid (Hunk l2 old2 new2))+ where+ selectChunk (Hunk l old new) content = elements [prefix, suffix]+ where start = l - 1+ prefix = (0, BS.take start content)+ suffix = (start + BS.length new, BS.drop (start + BS.length old) content)+ selectChunk _ _ = impossible++aPrimPair :: forall wX wY . V3Model wX -> Gen (WithEndState V3Model ((Prim :> Prim) wX) wY)+aPrimPair repo+ = do mbFile <- maybeOf repoFiles+ frequency+ [ ( if isJust mbFile then 1 else 0+ , do p1 :> p2 <- hunkPair $ fromJust mbFile+ let repo' = unFail $ repoApply repo p1+ repo'' = unFail $ repoApply repo' p2+ return $ WithEndState (p1 :> p2) repo''+ )+ , ( 1+ , do Sealed wesP <- arbitraryState repo+ return $ unsafeCoerceP1 wesP+ )+ ]+ where+ repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ]++----------------------------------------------------------------------+-- Arbitrary instances++ourSmallRepo :: Gen (V3Model wX)+ourSmallRepo = aSmallRepo++instance ArbitraryState V3Model Prim where+ arbitraryState s = seal <$> aPrim s+++instance Arbitrary (Sealed2 Prim) where+ arbitrary = makeS2Gen ourSmallRepo++instance Arbitrary (Sealed (Prim x)) where+ arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed2 (Prim :> Prim)) where+ arbitrary = do repo <- ourSmallRepo+ WithEndState pp _ <- aPrimPair repo+ return $ seal2 pp++instance Arbitrary (Sealed ((Prim :> Prim) wA)) where+ arbitrary = do repo <- ourSmallRepo+ WithEndState pp _ <- aPrimPair repo+ return $ seal pp++instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where+ arbitrary = makeS2Gen ourSmallRepo++instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where+ arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed2 (FL Prim)) where+ arbitrary = makeS2Gen ourSmallRepo++instance Arbitrary (Sealed ((FL Prim) wA)) where+ arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where+ arbitrary = makeS2Gen ourSmallRepo++instance Arbitrary (Sealed ((FL Prim :> FL Prim) wA)) where+ arbitrary = makeSGen ourSmallRepo++instance Arbitrary (Sealed2 (WithState V3Model Prim)) where+ arbitrary = makeWS2Gen ourSmallRepo++instance Arbitrary (Sealed (WithState V3Model Prim wA)) where+ arbitrary = makeWSGen ourSmallRepo++instance Arbitrary (Sealed (WithState V3Model (FL Prim) wA)) where+ arbitrary = makeWSGen ourSmallRepo++instance Arbitrary (Sealed2 (WithState V3Model (Prim :> Prim))) where+ arbitrary = do repo <- ourSmallRepo+ WithEndState pp repo' <- aPrimPair repo+ return $ seal2 $ WithState repo pp repo'++instance Arbitrary (Sealed (WithState V3Model (Prim :> Prim) a)) where+ arbitrary = do repo <- ourSmallRepo+ WithEndState pp repo' <- aPrimPair repo+ return $ seal $ WithState repo pp repo'+++instance Arbitrary (Sealed2 (WithState V3Model (FL Prim))) where+ arbitrary = makeWS2Gen ourSmallRepo++instance Arbitrary (Sealed2 (WithState V3Model (FL Prim :> FL Prim))) where+ arbitrary = makeWS2Gen ourSmallRepo++instance Arbitrary (Sealed (WithState V3Model (FL Prim :> FL Prim) a)) where+ arbitrary = makeWSGen ourSmallRepo
+ harness/Darcs/Test/Patch/Arbitrary/Real.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Arbitrary.Real where+import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.PrimV1 ()+import Darcs.Test.Patch.RepoModel++import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Merge ( Merge(..) )+import Darcs.Patch.Patchy ( Patchy, Commute(..) )+import Darcs.Patch.Prim ( PrimPatch, anIdentity )+import Darcs.Patch.V2 ( RealPatch )+import Darcs.Patch.V2.Real ( isDuplicate )++import Test.QuickCheck+import Darcs.Test.Patch.WithState+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Prim ( FromPrim(..) )+++nontrivialReals :: PrimPatch prim => (RealPatch prim :> RealPatch prim) wX wY -> Bool+nontrivialReals = nontrivialCommute++nontrivialCommute :: (Patchy p, MyEq p) => (p :> p) wX wY -> Bool+nontrivialCommute (x :> y) = case commute (x :> y) of+ Just (y' :> x') -> not (y' `unsafeCompare` y) ||+ not (x' `unsafeCompare` x)+ Nothing -> False++nontrivialMergeReals :: PrimPatch prim => (RealPatch prim :\/: RealPatch prim) wX wY -> Bool+nontrivialMergeReals = nontrivialMerge++nontrivialMerge :: (Patchy p, MyEq p, Merge p) => (p :\/: p) wX wY -> Bool+nontrivialMerge (x :\/: y) = case merge (x :\/: y) of+ y' :/\: x' -> not (y' `unsafeCompare` y) ||+ not (x' `unsafeCompare` x)++instance (RepoModel (ModelOf prim), ArbitraryPrim prim)+ => Arbitrary (Sealed2 (FL (RealPatch prim))) where+ arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim)))+ return $ unseal seal2 (flattenOne tree)++instance (RepoModel (ModelOf prim), ArbitraryPrim prim)+ => Arbitrary (Sealed2 (RealPatch prim)) where+ arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim)))+ case mapFL seal2 `unseal` flattenOne tree of+ [] -> return $ seal2 $ fromPrim anIdentity+ ps -> elements ps++notDuplicatestriple :: (RealPatch prim :> RealPatch prim :> RealPatch prim) wX wY -> Bool+notDuplicatestriple (a :> b :> c) = not (isDuplicate a || isDuplicate b || isDuplicate c)++nontrivialTriple :: PrimPatch prim => (RealPatch prim :> RealPatch prim :> RealPatch prim) wX wY -> Bool+nontrivialTriple (a :> b :> c) =+ case commute (a :> b) of+ Nothing -> False+ Just (b' :> a') ->+ case commute (a' :> c) of+ Nothing -> False+ Just (c'' :> a'') ->+ case commute (b :> c) of+ Nothing -> False+ Just (c' :> b'') -> (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) &&+ (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) &&+ (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a'))
+ harness/Darcs/Test/Patch/Check.hs view
@@ -0,0 +1,348 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+module Darcs.Test.Patch.Check ( PatchCheck(), doCheck, fileExists, dirExists,+ removeFile, removeDir, createFile, createDir,+ insertLine, deleteLine, isValid, doVerboseCheck,+ fileEmpty,+ checkMove, modifyFile, FileContents(..)+ ) where++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.Class ( get, put, modify )+-- 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 System.FilePath ( joinPath, splitDirectories )++#include "impossible.h"++-- | File contents are represented by a map from line numbers to line contents.+-- If for a certain line number, the line contents are Nothing, that means+-- that we are sure that that line exists, but we don't know its contents.+-- 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+ , 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.++-- | PatchCheck is a state monad with a simulated repository state+type PatchCheck = State KnownState++-- | The @FileContents@ structure for an empty file+emptyFilecontents :: FileContents+emptyFilecontents = FC M.empty 0++-- | Returns a given value if the repository state is inconsistent, and performs+-- a given action otherwise.+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 p (P [] [])++-- | Run a check, and print the final repository state+doVerboseCheck :: PatchCheck a -> a+doVerboseCheck p =+ case runState p (P [] []) of+ (b, pc) -> unsafePerformIO $ do print pc+ return b++-- | Returns true if the current repository state is not inconsistent+isValid :: PatchCheck Bool+isValid = handleInconsistent False (return True)++has :: Prop -> [Prop] -> Bool+has _ [] = False+has k (k':ks) = k == k' || has k ks++modifyFile :: String+ -> (Maybe FileContents -> Maybe FileContents)+ -> PatchCheck Bool+modifyFile f change = do+ _ <- fileExists f+ c <- fileContents f+ case change c of+ Nothing -> assertNot $ FileEx f -- shorthand for "FAIL"+ Just c' -> do setContents f c'+ isValid++insertLine :: String -> Int -> B.ByteString -> PatchCheck Bool+insertLine f n l = do+ c <- fileContents f+ case c of+ Nothing -> assertNot $ FileEx f -- in this case, the repo is inconsistent+ Just c' -> do+ let lines' = M.mapKeys (\k -> if k >= n then k+1 else k) (fcLines c')+ 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 f n l = do+ c <- fileContents f+ case c of+ Nothing -> assertNot $ FileEx f+ Just c' ->+ let flines = fcLines c'+ flines' = M.mapKeys (\k -> if k > n then k-1 else k)+ (M.delete n flines)+ maxlinenum' | n <= fcMaxline c' = fcMaxline c' - 1+ | otherwise = n - 1+ c'' = FC flines' maxlinenum'+ do_delete = do+ setContents f c''+ isValid+ in case M.lookup n flines of+ Nothing -> do_delete+ Just l' -> if l == l'+ then do_delete+ else assertNot $ FileEx f++setContents :: String -> FileContents -> PatchCheck ()+setContents f c = handleInconsistent () $ do+ P ks nots <- get+ let ks' = FileLines f c : filter (not . is_file_lines_for f) ks+ put (P ks' nots)+ where is_file_lines_for file prop = case prop of+ FileLines f' _ -> file == f'+ _ -> False++-- | 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+ P ks _ <- get+ return (fic ks)+ where fic (FileLines f' c:_) | f == f' = Just c+ fic (_:ks) = fic ks+ fic [] = Just emptyFilecontents++-- | Checks if a file is empty+fileEmpty :: String -- ^ Name of the file to check+ -> PatchCheck Bool+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+ -- Crude way to make it inconsistent and return false:+ else assertNot $ FileEx f+ return empty++movedirfilename :: String -> String -> String -> String+movedirfilename d d' f+ | (d ++ "/") `isPrefixOf` f = d' ++ drop (length d) f+ | f == d = d'+ | otherwise = f++-- | 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+ 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+ | f' `is_soe` a = DirEx $ movedirfilename f' f a+ sw (FileLines a c) | f `is_soe` a = FileLines (movedirfilename f f' a) c+ | f' `is_soe` a = FileLines (movedirfilename f' f a) c+ sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a+ | f' `is_soe` a = NotEx $ movedirfilename f' f a+ sw p = p+ 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+ P ks nots <- get+ if has p nots+ then do+ put Inconsistent+ return False+ else if has p ks+ then return True+ else do+ put (P (p:ks) nots)+ return True++-- | Like @assert@, but negatively: state that some property must not hold for+-- the current repo.+assertNot :: Prop -> PatchCheck Bool+assertNot p = handleInconsistent False $ do+ P ks nots <- get+ if has p ks+ then do+ put Inconsistent+ return False+ else if has p nots+ then return True+ else do+ put (P ks (p:nots))+ return True++-- | 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++-- | 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+ 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+ assert $ FileEx f+assertDirExists :: String -> PatchCheck Bool+assertDirExists d = do _ <- assertNot $ NotEx d+ _ <- assertNot $ FileEx d+ assert $ DirEx d+assertExists :: String -> PatchCheck Bool+assertExists f = assertNot $ NotEx f++assertNoSuch :: String -> PatchCheck Bool+assertNoSuch f = do _ <- assertNot $ FileEx f+ _ <- assertNot $ DirEx f+ assert $ NotEx f++createFile :: String -> PatchCheck Bool+createFile fn = do+ _ <- superdirsExist fn+ _ <- assertNoSuch fn+ _ <- changeToTrue (FileEx fn)+ changeToFalse (NotEx fn)++createDir :: String -> PatchCheck Bool+createDir fn = do+ _ <- substuffDontExist fn+ _ <- superdirsExist fn+ _ <- assertNoSuch fn+ _ <- changeToTrue (DirEx fn)+ changeToFalse (NotEx fn)++removeFile :: String -> PatchCheck Bool+removeFile fn = do+ _ <- superdirsExist fn+ _ <- assertFileExists fn+ _ <- fileEmpty fn+ _ <- changeToFalse (FileEx fn)+ changeToTrue (NotEx fn)++removeDir :: String -> PatchCheck Bool+removeDir fn = do+ _ <- substuffDontExist fn+ _ <- superdirsExist fn+ _ <- assertDirExists fn+ _ <- changeToFalse (DirEx fn)+ changeToTrue (NotEx fn)++checkMove :: String -> String -> PatchCheck Bool+checkMove f f' = do+ _ <- superdirsExist f+ _ <- superdirsExist f'+ _ <- assertExists f+ _ <- assertNoSuch f'+ doSwap f f'++substuffDontExist :: String -> PatchCheck Bool+substuffDontExist d = handleInconsistent False $ do+ P ks _ <- get+ if all noss ks+ then return True+ else do+ put Inconsistent+ return False+ where noss (FileEx f) = not (is_within_dir f)+ noss (DirEx f) = not (is_within_dir f)+ noss _ = True+ is_within_dir f = (d ++ "/") `isPrefixOf` f++-- 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+ where superdirs = map (("./"++) . joinPath)+ (init (tail (inits (tail (splitDirectories fn)))))++fileExists :: String -> PatchCheck Bool+fileExists fn = do+ _ <- superdirsExist fn+ assertFileExists fn++dirExists :: String -> PatchCheck Bool+dirExists fn = do+ _ <- superdirsExist fn+ assertDirExists fn
+ harness/Darcs/Test/Patch/Examples/Set1.hs view
@@ -0,0 +1,418 @@+-- Copyright (C) 2002-2005,2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}+{-# LANGUAGE CPP #-}++module Darcs.Test.Patch.Examples.Set1+ ( knownCommutes, knownCantCommutes, knownMerges+ , knownMergeEquivs, knownCanons, mergePairs2+ , validPatches, commutePairs, mergePairs+ , primitiveTestPatches, testPatches, testPatchesNamed+ , primitiveCommutePairs ) where++import System.IO.Unsafe ( unsafePerformIO )+import qualified Data.ByteString.Char8 as BC ( pack )+import qualified Data.ByteString as B ( empty )+import Darcs.Patch+ ( commute, invert, merge+ , Named, namepatch+ , readPatch, fromPrim+ , adddir, addfile, hunk, binary, rmdir, rmfile, tokreplace )+import Darcs.Patch.Prim ( PrimOf, FromPrim )+import Darcs.Patch.Prim.V1 ( Prim )+import qualified Darcs.Patch.V1 as V1 ( Patch )+import Darcs.Test.Patch.Properties.Check( checkAPatch )+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed ( unsafeUnseal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )++#include "impossible.h"++type Patch = V1.Patch Prim++-- The unit tester function is really just a glorified map for functions that+-- return lists, in which the lists get concatenated (where map would end up+-- with a list of lists).++quickmerge :: (FL Patch :\/: FL Patch) wX wY -> FL Patch wY wZ+quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of+ _ :/\: p1' -> unsafeCoercePEnd p1'++-- ----------------------------------------------------------------------+-- * Show/Read tests+-- ----------------------------------------------------------------------++-- | This test involves calling 'show' to print a string describing a patch,+-- and then using readPatch to read it back in, and making sure the patch we+-- read in is the same as the original. Useful for making sure that I don't+-- have any stupid IO bugs.++-- ----------------------------------------------------------------------+-- * Canonization tests+-- ----------------------------------------------------------------------++knownCanons :: [(FL Patch wX wY,FL Patch wX wY)]+knownCanons =+ [(quickhunk 1 "abcde" "ab" :>: NilFL, quickhunk 3 "cde" "" :>: NilFL),+ (quickhunk 1 "abcde" "bd" :>: NilFL,+ quickhunk 1 "a" "" :>:+ quickhunk 2 "c" "" :>:+ quickhunk 3 "e" "" :>: NilFL),+ (quickhunk 4 "a" "b" :>:+ quickhunk 1 "c" "d" :>: NilFL,+ quickhunk 1 "c" "d" :>:+ quickhunk 4 "a" "b" :>: NilFL),+ (quickhunk 1 "a" "" :>:+ quickhunk 1 "" "b" :>: NilFL,+ quickhunk 1 "a" "b" :>: NilFL),+ (quickhunk 1 "ab" "c" :>:+ quickhunk 1 "cd" "e" :>: NilFL,+ quickhunk 1 "abd" "e" :>: NilFL),+ (quickhunk 1 "abcde" "cde" :>: NilFL, quickhunk 1 "ab" "" :>: NilFL),+ (quickhunk 1 "abcde" "acde" :>: NilFL, quickhunk 2 "b" "" :>: NilFL)]++quickhunk :: (FromPrim p, PrimOf p ~ Prim) => Int -> String -> String -> p wX wY+quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o)+ (map (\c -> BC.pack [c]) n)++-- ----------------------------------------------------------------------+-- * Merge/unmgerge tests+-- ----------------------------------------------------------------------++-- | It should always be true that if two patches can be unmerged, then merging+-- the resulting patches should give them back again.+mergePairs :: [(FL Patch :\/: FL Patch) wX wY]+mergePairs =+ take 400 [(p1:\/:p2)|+ i <- [0..(length testPatches)-1],+ p1<-[testPatches!!i],+ p2<-drop i testPatches,+ checkAPatch (invert p2 :>: p1 :>: NilFL)]++-- ----------------------------------------------------------------------+-- * Commute/recommute tests+-- ----------------------------------------------------------------------++-- | Here we test to see if commuting patch A and patch B and then commuting+-- the result gives us patch A and patch B again. The set of patches (A,B)+-- is chosen from the set of all pairs of test patches by selecting those which+-- commute with one another.+commutePairs :: [(FL Patch :> FL Patch) wX wY]+commutePairs =+ take 200 [(p1:>p2)|+ p1<-testPatches,+ p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatches,+ commute (p1:>p2) /= Nothing]++primitiveCommutePairs :: [(FL Patch :> FL Patch) wX wY]+primitiveCommutePairs =+ [(p2:>p1)|+ p1<-primitiveTestPatches,+ p2<-primitiveTestPatches,+ commute (p2:>p1) /= Nothing,+ checkAPatch (p2:>:p1:>:NilFL)]++-- ----------------------------------------------------------------------+-- * Commute tests+-- ----------------------------------------------------------------------++-- | Here we provide a set of known interesting commutes.+knownCommutes :: [((FL Patch:<FL Patch) wX wY,(FL Patch:<FL Patch) wX wY)]+knownCommutes = [+ (testhunk 1 [] ["A"]:<+ testhunk 2 [] ["B"],+ testhunk 3 [] ["B"]:<+ testhunk 1 [] ["A"]),+ (fromPrim (tokreplace "test" "A-Za-z_" "old" "new"):<+ testhunk 2+ ["hello world all that is old is good old_"]+ ["I don't like old things"],+ testhunk 2+ ["hello world all that is new is good old_"]+ ["I don't like new things"]:<+ fromPrim (tokreplace "test" "A-Za-z_" "old" "new")),+ (testhunk 1 ["A"] ["B"]:<+ testhunk 2 ["C"] ["D"],+ testhunk 2 ["C"] ["D"]:<+ testhunk 1 ["A"] ["B"]),+ (fromPrim (rmfile "NwNSO"):<+ (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))),+ (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))):<+ fromPrim (rmfile "NwNSO")),++ (quickmerge (testhunk 3 ["o"] ["n"]:\/:+ testhunk 3 ["o"] ["v"]):<+ testhunk 1 [] ["a"],+ testhunk 1 [] ["a"]:<+ quickmerge (testhunk 2 ["o"] ["n"]:\/:+ testhunk 2 ["o"] ["v"])),++ (testhunk 1 ["A"] []:<+ testhunk 3 ["B"] [],+ testhunk 2 ["B"] []:<+ testhunk 1 ["A"] []),++ (testhunk 1 ["A"] ["B"]:<+ testhunk 2 ["B"] ["C"],+ testhunk 2 ["B"] ["C"]:<+ testhunk 1 ["A"] ["B"]),++ (testhunk 1 ["A"] ["B"]:<+ testhunk 3 ["B"] ["C"],+ testhunk 3 ["B"] ["C"]:<+ testhunk 1 ["A"] ["B"]),++ (testhunk 1 ["A"] ["B","C"]:<+ testhunk 2 ["B"] ["C","D"],+ testhunk 3 ["B"] ["C","D"]:<+ testhunk 1 ["A"] ["B","C"])]+ where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)++knownCantCommutes :: [(FL Patch:< FL Patch) wX wY]+knownCantCommutes = [+ (testhunk 2 ["o"] ["n"]:<+ testhunk 1 [] ["A"]),+ (testhunk 1 [] ["A"]:<+ testhunk 1 ["o"] ["n"]),+ (quickmerge (testhunk 2 ["o"] ["n"]:\/:+ testhunk 2 ["o"] ["v"]):<+ testhunk 1 [] ["a"]),+ (fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])):<+ fromPrim (addfile "test"))]+ where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)++-- ----------------------------------------------------------------------+-- * Merge tests+-- ----------------------------------------------------------------------++-- | Here we provide a set of known interesting merges.+knownMerges :: [((FL Patch:\/:FL Patch) wX wY,FL Patch wY wZ)]+knownMerges = [+ (testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"]:\/:+ testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"],+ testhunk 3 [BC.pack "c"] [BC.pack "d",BC.pack "e"]),+ (testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]:\/:+ testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"],+ testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]),+ (testhunk 3 [BC.pack "A"] []:\/:+ testhunk 1 [BC.pack "B"] [],+ testhunk 2 [BC.pack "A"] []),+ (fromPrim (rmdir "./test/world"):\/:+ fromPrim (hunk "./world" 3 [BC.pack "A"] []),+ fromPrim (rmdir "./test/world")),++ ((quickhunk 1 "a" "bc" :>:+ quickhunk 6 "d" "ef" :>: NilFL):\/:+ (quickhunk 3 "a" "bc" :>:+ quickhunk 8 "d" "ef" :>: NilFL),+ (quickhunk 1 "a" "bc" :>:+ quickhunk 7 "d" "ef" :>: NilFL)),++ (testhunk 1 [BC.pack "A"] [BC.pack "B"]:\/:+ testhunk 2 [BC.pack "B"] [BC.pack "C"],+ testhunk 1 [BC.pack "A"] [BC.pack "B"]),++ (testhunk 2 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:\/:+ testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"],+ testhunk 3 [BC.pack "A"] [BC.pack "B",BC.pack "C"])]+ where testhunk l o n = fromPrim $ hunk "test" l o n++knownMergeEquivs :: [((FL Patch :\/: FL Patch) wX wY, FL Patch wY wZ)]+knownMergeEquivs = [++ -- The following tests are going to be failed by the+ -- Conflictor code as a cleanup.++ --(addfile "test":\/:+ -- adddir "test",+ -- joinPatches (adddir "test" :>:+ -- addfile "test-conflict" :>: NilFL)),+ --(move "silly" "test":\/:+ -- adddir "test",+ -- joinPatches (adddir "test" :>:+ -- move "silly" "test-conflict" :>: NilFL)),+ --(addfile "test":\/:+ -- move "old" "test",+ -- joinPatches (addfile "test" :>:+ -- move "old" "test-conflict" :>: NilFL)),+ --(move "a" "test":\/:+ -- move "old" "test",+ -- joinPatches (move "a" "test" :>:+ -- move "old" "test-conflict" :>: NilFL)),+ (fromPrim (hunk "test" 1 [] [BC.pack "A"]) :\/:+ fromPrim (hunk "test" 1 [] [BC.pack "B"]),+ fromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])),+ (fromPrim (hunk "test" 1 [] [BC.pack "a"]):\/:+ fromPrim (hunk "test" 1 [BC.pack "b"] []),+ unsafeCoerceP NilFL),+ --hunk "test" 1 [] [BC.pack "v v v v v v v",+ -- BC.pack "*************",+ -- BC.pack "a",+ -- BC.pack "b",+ -- BC.pack "^ ^ ^ ^ ^ ^ ^"]),+ (quickhunk 4 "a" "" :\/:+ quickhunk 3 "a" "",+ quickhunk 3 "aa" ""),+ ((quickhunk 1 "a" "bc" :>:+ quickhunk 6 "d" "ef" :>: NilFL) :\/:+ (quickhunk 3 "a" "bc" :>:+ quickhunk 8 "d" "ef" :>: NilFL),+ quickhunk 3 "a" "bc" :>:+ quickhunk 8 "d" "ef" :>:+ quickhunk 1 "a" "bc" :>:+ quickhunk 7 "d" "ef" :>: NilFL),+ (quickmerge (quickhunk 2 "" "bd":\/:quickhunk 2 "" "a") :\/:+ quickmerge (quickhunk 2 "" "c":\/:quickhunk 2 "" "a"),+ quickhunk 2 "" "abdc")+ ]+++-- | It also is useful to verify that it doesn't matter which order we specify+-- the patches when we merge.+mergePairs2 :: [(FL Patch wX wY, FL Patch wX wZ)]+mergePairs2 = [(p1, p2) |+ p1<-primitiveTestPatches,+ p2<-primitiveTestPatches,+ checkAPatch (invert p1:>:p2:>:NilFL)+ ]++-- ----------------------------------------------------------------------+-- Patch test data+-- This is where we define the set of patches which we run our tests on. This+-- should be kept up to date with as many interesting permutations of patch+-- types as possible.+-- ----------------------------------------------------------------------++testPatches :: [FL Patch wX wY]+testPatchesNamed :: [Named Patch wX wY]+testPatchesAddfile :: [FL Patch wX wY]+testPatchesRmfile :: [FL Patch wX wY]+testPatchesHunk :: [FL Patch wX wY]+primitiveTestPatches :: [FL Patch wX wY]+testPatchesBinary :: [FL Patch wX wY]+testPatchesCompositeNocom :: [FL Patch wX wY]+testPatchesComposite :: [FL Patch wX wY]+testPatchesTwoCompositeHunks :: [FL Patch wX wY]+testPatchesCompositeHunks :: [FL Patch wX wY]+testPatchesCompositeFourHunks :: [FL Patch wX wY]+testPatchesMerged :: [FL Patch wX wY]+validPatches :: [FL Patch wX wY]++testPatchesNamed = [unsafePerformIO $+ namepatch "date is" "patch name" "David Roundy" []+ (fromPrim $ addfile "test"),+ unsafePerformIO $+ namepatch "Sat Oct 19 08:31:13 EDT 2002"+ "This is another patch" "David Roundy"+ ["This log file has","two lines in it"]+ (fromPrim $ rmfile "test")]+testPatchesAddfile = map fromPrim+ [addfile "test",adddir "test",addfile "test/test"]+testPatchesRmfile = map invert testPatchesAddfile+testPatchesHunk =+ [fromPrim (hunk file line old new) |+ file <- ["test"],+ line <- [1,2],+ old <- map (map BC.pack) partials,+ new <- map (map BC.pack) partials,+ old /= new+ ]+ where partials = [["A"],["B"],[],["B","B2"]]++primitiveTestPatches = testPatchesAddfile +++ testPatchesRmfile +++ testPatchesHunk +++ [unsafeUnseal.fromJust.readPatch $+ BC.pack "move ./test/test ./hello",+ unsafeUnseal.fromJust.readPatch $+ BC.pack "move ./test ./hello"] +++ testPatchesBinary++testPatchesBinary =+ [fromPrim $ binary "./hello"+ (BC.pack $ "agadshhdhdsa75745457574asdgg" +++ "a326424677373735753246463gadshhdhdsaasdgg" +++ "a326424677373735753246463gadshhdhdsaasdgg" +++ "a326424677373735753246463gadshhdhdsaasdgg")+ (BC.pack $ "adafjttkykrehhtrththrthrthre" +++ "a326424677373735753246463gadshhdhdsaasdgg" +++ "a326424677373735753246463gadshhdhdsaasdgg" +++ "a326424677373735753246463gadshhdhdsaagg"),+ fromPrim $ binary "./hello"+ B.empty+ (BC.pack "adafjttkykrere")]++testPatchesCompositeNocom =+ take 50 [p1+>+p2|+ p1<-primitiveTestPatches,+ p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) primitiveTestPatches,+ commute (p1:>p2) == Nothing]++testPatchesComposite =+ take 100 [p1+>+p2|+ p1<-primitiveTestPatches,+ p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) primitiveTestPatches,+ commute (p1:>p2) /= Nothing,+ commute (p1:>p2) /= Just (unsafeCoerceP p2:>unsafeCoerceP p1)]++testPatchesTwoCompositeHunks =+ take 100 [p1+>+p2|+ p1<-testPatchesHunk,+ p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk]++testPatchesCompositeHunks =+ take 100 [p1+>+p2+>+p3|+ p1<-testPatchesHunk,+ p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk,+ p3<-filter (\p->checkAPatch (p1:>:p2:>:p:>:NilFL)) testPatchesHunk]++testPatchesCompositeFourHunks =+ take 100 [p1+>+p2+>+p3+>+p4|+ p1<-testPatchesHunk,+ p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk,+ p3<-filter (\p->checkAPatch (p1:>:p2:>:p:>:NilFL)) testPatchesHunk,+ p4<-filter (\p->checkAPatch (p1:>:p2:>:p3:>:p:>:NilFL)) testPatchesHunk]++testPatchesMerged =+ take 200+ [p2+>+quickmerge (p1:\/:p2) |+ p1<-take 10 (drop 15 testPatchesCompositeHunks)++primitiveTestPatches+ ++take 10 (drop 15 testPatchesTwoCompositeHunks)+ ++ take 2 (drop 4 testPatchesCompositeFourHunks),+ p2<-take 10 testPatchesCompositeHunks++primitiveTestPatches+ ++take 10 testPatchesTwoCompositeHunks+ ++take 2 testPatchesCompositeFourHunks,+ checkAPatch (invert p1 :>: p2 :>: NilFL),+ commute (p2:>p1) /= Just (p1:>p2)+ ]++testPatches = primitiveTestPatches +++ testPatchesComposite +++ testPatchesCompositeNocom +++ testPatchesMerged++-- ----------------------------------------------------------------------+-- * Check patch test+-- ----------------------------------------------------------------------++validPatches = [(quickhunk 4 "a" "b" :>:+ quickhunk 1 "c" "d" :>: NilFL),+ (quickhunk 1 "a" "bc" :>:+ quickhunk 1 "b" "d" :>: NilFL),+ (quickhunk 1 "a" "b" :>:+ quickhunk 1 "b" "d" :>: NilFL)]++testPatches
+ harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs view
@@ -0,0 +1,491 @@+-- Copyright (C) 2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+++module Darcs.Test.Patch.Examples.Set2Unwitnessed+ ( primPermutables, primPatches+ , commutables, commutablesFL+ , realCommutables , realMergeables, realTriples+ , realNonduplicateTriples, realPatches, realPatchLoopExamples+ ) where++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.Patchy ( Invert(..) )+import Darcs.Patch.Prim ( PrimPatch )+import Darcs.Patch.Prim.V1 ( Prim )+import Darcs.Patch.V2 ( RealPatch )+import Darcs.Patch.V2.Real ( prim2real )+-- import Darcs.Test.Patch.Test () -- for instance Eq Patch+-- import Darcs.Test.Patch.Examples.Set2Unwitnessed+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import qualified Darcs.Test.Patch.Arbitrary.Real as W ( notDuplicatestriple )+--import Darcs.Util.Printer ( greenText )+--import Darcs.Util.Printer.Color ( traceDoc )+--import Darcs.Util.Printer.Color ( errorDoc )+import Darcs.Util.Printer.Color () -- for instance Show Doc+import Darcs.Test.Patch.WSub++import qualified Darcs.Patch.Witnesses.Ordered as W ( (:>), (:\/:) )+import qualified Data.ByteString as B ( ByteString )+import Darcs.Test.Patch.V1Model ( V1Model, Content+ , makeRepo, makeName, makeFile)+import Darcs.Test.Patch.WithState ( WithStartState(..) )+import Darcs.Patch.Prim.V1.Core ( Prim(FP), FilePatchType(Hunk) )+import Darcs.Util.Path ( FileName, fp2fn )+import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim )+import Darcs.Patch.Merge ( Merge )+import Darcs.Test.Patch.Arbitrary.Generic+ ( Tree(..)+ , TreeWithFlattenPos(..)+ , commutePairFromTree, commuteTripleFromTree+ , mergePairFromCommutePair, commutePairFromTWFP+ , canonizeTree+ )++-- import Debug.Trace+-- #include "impossible.h"++makeSimpleRepo :: String -> Content -> V1Model wX+makeSimpleRepo filename content = makeRepo [(makeName filename, makeFile content)]+++w_tripleExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:> p W.:> p)]+w_tripleExamples = [commuteTripleFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [])+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "g"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 2 [] [BC.pack "j"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "s"])) NilTree)))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "e"])) NilTree))+ ,commuteTripleFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [BC.pack "j"])+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "s"]))+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "j"] [])) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "j"] [])) NilTree)))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree))+ ]+++w_mergeExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:\/: p)]+w_mergeExamples = map (unseal2 (mergePairFromCommutePair seal2)) w_commuteExamples++w_commuteExamples :: (FromPrim p, Merge p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:> p)]+w_commuteExamples = [+ commutePairFromTWFP seal2 $+ WithStartState (makeSimpleRepo "file" [])+ (TWFP 3+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"])) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "b"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "f"] [])) NilTree)))))),+ commutePairFromTWFP seal2 $+ WithStartState+ (makeSimpleRepo "file" [BC.pack "f",BC.pack "s",BC.pack "d"])+ (TWFP 3+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "d"] [])) NilTree)+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] [])) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] []))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "s",BC.pack "d"] []))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree)))))),+{- commutePairFromTWFP seal2 $+ WithStartState+ (makeSimpleRepo "file" [BC.pack "f",BC.pack "u",+ BC.pack "s",BC.pack "d"])+ (TWFP 5+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 5 [] [BC.pack "x"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 4 [BC.pack "d"] [])) NilTree))+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f",BC.pack "u"] [])) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] []))+ (SeqTree (FP(fp2fn "./file") (Hunk 1 [BC.pack "u",BC.pack "s",BC.pack "d"] []))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "a"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "a"] [])) NilTree))))))),-}+ commutePairFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [BC.pack "n",BC.pack "t",BC.pack "h"])+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "n",BC.pack "t",BC.pack "h"] []))+ NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "h"] []))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "n"] []))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t"] [])) NilTree)))),+ commutePairFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [])+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "n"])) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "i"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "i"])) NilTree))),+ commutePairFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [])+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "c"]))+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "c"] [BC.pack "r"])) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "d"])) NilTree))))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree)),+ commutePairFromTWFP seal2 $+ WithStartState (makeSimpleRepo "file" [])+ (TWFP 1+ (ParTree+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "t"])) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "t"])) NilTree))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree))),+ commutePairFromTWFP seal2 $+ WithStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack " r",+ BC.pack "c",BC.pack "v"])+ (TWFP 4+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "c",BC.pack "v"] []))+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "r"] []))+ (SeqTree (FP (fp2fn "fi le") (Hunk 1 [BC.pack "f"] [])) NilTree))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f",BC.pack "r"] []))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "y"])) NilTree))))+ (SeqTree (FP (fp2fn "./file") (Hunk 4 [BC.pack "v"] [])) NilTree))),+ commutePairFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [])+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "z"])) NilTree)+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree)+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "r"])) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "d"])) NilTree))))+ , commutePairFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [BC.pack "t",BC.pack "r",BC.pack "h"])+ (ParTree+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t",BC.pack "r",BC.pack "h"] []))+ NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "o"])) NilTree))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t"] []))+ (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "h"] [])) NilTree)))+ , commutePairFromTWFP seal2 $+ WithStartState (makeSimpleRepo "file" []) $+ TWFP 2+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"])) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "y"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 2 [] [BC.pack "m"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree))))+ , commutePairFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [])+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "p"]))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "p"] []))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "c"])) NilTree)))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "z"])) NilTree))+ , commutePairFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [])+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j" ]))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree))+ , commutePairFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [])+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j" ]))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree)))+ , commutePairFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [BC.pack "x",BC.pack "c"])+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"]))+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "c"] [])) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "x"] []))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j"])) NilTree))))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "l"])) NilTree))+ , commutePairFromTree seal2 $+ WithStartState (makeSimpleRepo "file" [])+ (ParTree+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "s"))) NilTree)+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "k")))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 (packStringLetters "k") []))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "m")))+ (SeqTree (FP (fp2fn "./file") (Hunk 1 (packStringLetters "m") [])) NilTree)))))+ ]++packStringLetters :: String -> [B.ByteString]+packStringLetters = map (BC.pack . (:[]))++w_realPatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))]+w_realPatchLoopExamples =+ [Sealed (WithStartState (makeSimpleRepo fx_name [])+ $ canonizeTree+ (ParTree+ (SeqTree (FP fx (Hunk 1 [] (packStringLetters "pkotufogbvdabnmbzajvolwviqebieonxvcvuvigkfgybmqhzuaaurjspd")))+ (ParTree+ (SeqTree (FP fx (Hunk 47 (packStringLetters "qhzu") (packStringLetters "zafybdcokyjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmh")))+ (ParTree+ (ParTree+ NilTree+ (ParTree+ (ParTree+ (ParTree+ (SeqTree (FP fx (Hunk 15 (packStringLetters "mbzajvolwviqebieonxvcvuvigkfgyb") (packStringLetters "vujnxnhvybvpouyciaabszfmgssezlwwjgnethvrpnfrkubphzvdgymjjoacppqps")))+ (ParTree+ NilTree+ (ParTree+ (SeqTree (FP fx (Hunk 40 (packStringLetters "ssezlwwjgnethvrpnfrkubphzvdgymjjoacppqpsmzafybdcokyjskcgnvhkbz") (packStringLetters "wnesidpccwoiqiichxaaejdsyrhrusqljlcoro")))+ (ParTree+ (ParTree+ (SeqTree (FP fx (Hunk 12 (packStringLetters "abnvujnxnhvybvpouyciaabszfmgwnesidpccwoiqii") (packStringLetters "czfdhqkipdstfjycqaxwnbxrihrufdeyneqiiiafwzlmg"))) NilTree)+ NilTree)+ NilTree))+ (SeqTree (FP fx (Hunk 25 [] (packStringLetters "dihgmsotezucqdgxczvcivijootyvhlwymbiueufnvpwpeukmskqllalfe"))) NilTree))))+ (SeqTree (FP fx (Hunk 56 (packStringLetters "yjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmhaaurjsp") (packStringLetters "xldhrutyhcyaqeezwujiguawfyawjjqlirxshjddvq"))) NilTree))+ (SeqTree (FP fx (Hunk 20 [] (packStringLetters "ooygwiyogqrqnytixqtmvdxx")))+ (SeqTree (FP fx (Hunk 26 (packStringLetters "yogqrqnytixqtmvdxxvolwviqebieonxvcvuvigkfgybmzafybdcokyjskcgnvhkbz") (packStringLetters "akhsmlbkdxnvfoikmiatfbpzdrsyykkpoxvvddeaspzxe")))+ (SeqTree (FP fx (Hunk 39 [] (packStringLetters "ji")))+ (ParTree+ NilTree+ (ParTree+ NilTree+ (ParTree+ (ParTree+ NilTree+ (SeqTree (FP fx (Hunk 26 (packStringLetters "akhsmlbkdxnvfjioikmiatfbpzdrsyykkpoxvvddeaspzxepysaafnjjhcstgrczplxs") (packStringLetters "onjbhddskcj")))+ (SeqTree (FP fx (Hunk 39 [] (packStringLetters "fyscunxxxjjtyqpfxeznhtwvlphmp"))) NilTree)))+ (ParTree+ NilTree+ (SeqTree (FP fx (Hunk 44 [] (packStringLetters "xcchzwmzoezxkmkhcmesplnjpqriypshgiqklgdnbmmkldnydiy")))+ (ParTree+ NilTree+ (SeqTree (FP fx (Hunk 64 (packStringLetters "plnjpqriypshgiqklgdnbmmkldnydiymiatfbpzdrsyykkpoxvvddeaspzxepysaafn") (packStringLetters "anjlzfdqbjqbcplvqvkhwjtkigp"))) NilTree)))))))))))+ (ParTree+ NilTree+ NilTree)))+ NilTree))+ NilTree))+ (ParTree+ NilTree+ (SeqTree (FP fx (Hunk 1 [] (packStringLetters "ti")))+ (SeqTree (FP fx (Hunk 1 (packStringLetters "t") (packStringLetters "ybcop")))+ (SeqTree (FP fx (Hunk 2 [] (packStringLetters "dvlhgwqlpaeweerqrhnjtfolczbqbzoccnvdsyqiefqitrqneralf")))+ (SeqTree (FP fx (Hunk 15 [] (packStringLetters "yairbjphwtnaerccdlfewujvjvmjakbc")))+ (SeqTree (FP fx (Hunk 51 [] (packStringLetters "xayvfuwaiiogginufnhsrmktpmlbvxiakjwllddkiyofyfw")))+ (ParTree+ NilTree+ NilTree)))))))))]+ where+ fx_name :: String+ fx_name = "F"++ fx :: FileName+ fx = fp2fn "./F"+++mergeExamples :: [Sealed2 (RealPatch Prim :\/: RealPatch Prim)]+mergeExamples = map (mapSeal2 fromW) w_mergeExamples++realPatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))]+realPatchLoopExamples = w_realPatchLoopExamples++commuteExamples :: [Sealed2 (RealPatch Prim :> RealPatch Prim)]+commuteExamples = map (mapSeal2 fromW) w_commuteExamples++tripleExamples :: [Sealed2 (RealPatch Prim :> RealPatch Prim :> RealPatch Prim)]+tripleExamples = map (mapSeal2 fromW) w_tripleExamples++notDuplicatestriple :: (RealPatch Prim :> RealPatch Prim :> RealPatch Prim) wX wY -> Bool+notDuplicatestriple = W.notDuplicatestriple . toW++quickhunk :: PrimPatch prim => Int -> String -> String -> prim wX wY+quickhunk l o n = hunk "test" l (map (\c -> BC.pack [c]) o)+ (map (\c -> BC.pack [c]) n)++primPermutables :: [(Prim :> Prim :> Prim) wX wY]+primPermutables =+ [quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"]++mergeables :: [(Prim :\/: Prim) wX wY]+mergeables = [quickhunk 1 "a" "b" :\/: quickhunk 1 "a" "c",+ quickhunk 1 "a" "b" :\/: quickhunk 3 "z" "c",+ quickhunk 0 "" "a" :\/: quickhunk 1 "" "b",+ quickhunk 0 "a" "" :\/: quickhunk 1 "" "b",+ quickhunk 0 "a" "" :\/: quickhunk 1 "b" "",+ quickhunk 0 "" "a" :\/: quickhunk 1 "b" ""+ ]++mergeablesFL :: [(FL Prim :\/: FL Prim) wX wY]+mergeablesFL = map (\ (x:\/:y) -> (x :>: NilFL) :\/: (y :>: NilFL)) mergeables +++ [] -- [(quickhunk 1 "a" "b" :>: quickhunk 3 "z" "c" :>: NilFL)+ -- :\/: (quickhunk 1 "a" "z" :>: NilFL),+ -- (quickhunk 1 "a" "b" :>: quickhunk 1 "b" "c" :>: NilFL)+ -- :\/: (quickhunk 1 "a" "z" :>: NilFL)]++mergeable2commutable :: Invert p => (p :\/: p) wX wY -> (p :> p) wX wY+mergeable2commutable (x :\/: y) = unsafeCoerceP (invert x) :> y++commutablesFL :: [(FL Prim :> FL Prim) wX wY]+commutablesFL = map mergeable2commutable mergeablesFL+commutables :: [(Prim :> Prim) wX wY]+commutables = map mergeable2commutable mergeables++primPatches :: [Prim wX wY]+primPatches = concatMap mergeable2patches mergeables+ where mergeable2patches (x:\/:y) = [x,y]++realPatches :: [RealPatch Prim wX wY]+realPatches = concatMap commutable2patches realCommutables+ where commutable2patches (x:>y) = [x,y]++realTriples :: [(RealPatch Prim :> RealPatch Prim :> RealPatch Prim) wX wY]+realTriples = [ob' :> oa2 :> a2'',+ oa' :> oa2 :> a2'']+ ++ map unsafeUnseal2 tripleExamples+ ++ map unsafeUnseal2 (concatMap getTriples realFLs)+ where oa = prim2real $ quickhunk 1 "o" "aa"+ oa2 = oa+ a2 = prim2real $ quickhunk 2 "a34" "2xx"+ ob = prim2real $ quickhunk 1 "o" "bb"+ ob' :/\: oa' = merge (oa :\/: ob)+ a2' :/\: _ = merge (ob' :\/: a2)+ a2'' :/\: _ = merge (oa2 :\/: a2')++realNonduplicateTriples :: [(RealPatch Prim :> RealPatch Prim :> RealPatch Prim) wX wY]+realNonduplicateTriples = filter (notDuplicatestriple) realTriples++realFLs :: [FL (RealPatch Prim) wX wY]+realFLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL]+ where oa = prim2real $ quickhunk 1 "o" "a"+ ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL)++realCommutables :: [(RealPatch Prim :> RealPatch Prim) wX wY]+realCommutables = map unsafeUnseal2 commuteExamples+++ map mergeable2commutable realMergeables+++ [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs realFLs)+ where oa = prim2real $ quickhunk 1 "o" "a"+ ob = prim2real $ quickhunk 1 "o" "b"+ _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL)++realMergeables :: [(RealPatch Prim :\/: RealPatch Prim) wX wY]+realMergeables = map (\ (x :\/: y) -> prim2real x :\/: prim2real y) mergeables+ ++ realIglooMergeables+ ++ realQuickcheckMergeables+ ++ map unsafeUnseal2 mergeExamples+ ++ catMaybes (map pair2m (concatMap getPairs realFLs))+ ++ [(oa :\/: od),+ (oa :\/: a2'),+ (ob' :\/: od''),+ (oe :\/: od),+ (of' :\/: oe'),+ (ob' :\/: oe'),+ (oa :\/: oe'),+ (ob' :\/: oc'),+ (b2' :\/: oc'''),+ (ob' :\/: a2),+ (b2' :\/: og'''),+ (oc''' :\/: og'''),+ (oc'' :\/: og''),+ (ob'' :\/: og''),+ (ob'' :\/: oc''),+ (oc' :\/: od'')]+ where oa = prim2real $ quickhunk 1 "o" "aa"+ a2 = prim2real $ quickhunk 2 "a34" "2xx"+ og = prim2real $ quickhunk 3 "4" "g"+ ob = prim2real $ quickhunk 1 "o" "bb"+ b2 = prim2real $ quickhunk 2 "b" "2"+ oc = prim2real $ quickhunk 1 "o" "cc"+ od = prim2real $ quickhunk 7 "x" "d"+ oe = prim2real $ quickhunk 7 "x" "e"+ pf = prim2real $ quickhunk 7 "x" "f"+ od'' = prim2real $ quickhunk 8 "x" "d"+ ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL)+ a2' :/\: _ = merge (ob' :\/: a2)+ ob'' :/\: _ = merge (a2 :\/: ob')+ og' :/\: _ = merge (oa :\/: og)+ og'' :/\: _ = merge (a2 :\/: og')+ og''' :/\: _ = merge (ob' :\/: og')+ oc' :/\: _ = merge (oa :\/: oc)+ oc'' :/\: _ = merge (a2 :\/: oc)+ oc''' :/\: _ = merge (ob' :\/: oc')+ oe' :/\: _ = merge (od :\/: oe)+ of' :/\: _ = merge (od :\/: pf)+ pair2m :: Sealed2 (RealPatch Prim :> RealPatch Prim)+ -> Maybe ((RealPatch Prim :\/: RealPatch Prim) wX wY)+ pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)+ return $ unsafeCoerceP (xx :\/: y')++realIglooMergeables :: [(RealPatch Prim :\/: RealPatch Prim) wX wY]+realIglooMergeables = [(a :\/: b),+ (b :\/: c),+ (a :\/: c),+ (x :\/: a),+ (y :\/: b),+ (z :\/: c),+ (x' :\/: y'),+ (z' :\/: y'),+ (x' :\/: z'),+ (a :\/: a)]+ where a = prim2real $ quickhunk 1 "1" "A"+ b = prim2real $ quickhunk 2 "2" "B"+ c = prim2real $ quickhunk 3 "3" "C"+ x = prim2real $ quickhunk 1 "1BC" "xbc"+ y = prim2real $ quickhunk 1 "A2C" "ayc"+ z = prim2real $ quickhunk 1 "AB3" "abz"+ x' :/\: _ = merge (a :\/: x)+ y' :/\: _ = merge (b :\/: y)+ z' :/\: _ = merge (c :\/: z)++realQuickcheckMergeables :: [(RealPatch Prim :\/: RealPatch Prim) wX wY]+realQuickcheckMergeables = [-- invert k1 :\/: n1+ --, invert k2 :\/: n2+ hb :\/: k+ , b' :\/: b'+ , n' :\/: n'+ , b :\/: d+ , k' :\/: k'+ , k3 :\/: k3+ ] ++ catMaybes (map pair2m pairs)+ where hb = prim2real $ quickhunk 0 "" "hb"+ k = prim2real $ quickhunk 0 "" "k"+ n = prim2real $ quickhunk 0 "" "n"+ b = prim2real $ quickhunk 1 "b" ""+ d = prim2real $ quickhunk 2 "" "d"+ d':/\:_ = merge (b :\/: d)+ --k1 :>: n1 :>: NilFL :/\: _ = mergeFL (hb :\/: k :>: n :>: NilFL)+ --k2 :>: n2 :>: NilFL :/\: _ =+ -- merge (hb :>: b :>: NilFL :\/: k :>: n :>: NilFL)+ k' :>: n' :>: NilFL :/\: _ :>: b' :>: _ = merge (hb :>: b :>: d' :>: NilFL :\/: k :>: n :>: NilFL)+ pairs = getPairs (hb :>: b :>: d' :>: k' :>: n' :>: NilFL)+ pair2m :: Sealed2 (RealPatch Prim :> RealPatch Prim)+ -> Maybe ((RealPatch Prim :\/: RealPatch Prim) wX wY)+ pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)+ return $ unsafeCoerceP (xx :\/: y')++ i = prim2real $ quickhunk 0 "" "i"+ x = prim2real $ quickhunk 0 "" "x"+ xi = prim2real $ quickhunk 0 "xi" ""+ d3 :/\: _ = merge (xi :\/: d)+ _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL)+
+ harness/Darcs/Test/Patch/Info.hs view
@@ -0,0 +1,163 @@+-- Copyright (C) 2009 Reinier Lamers+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- | This module contains tests for the code in Darcs.Patch.Info. Most of them+-- are about the UTF-8-encoding of patch metadata.+module Darcs.Test.Patch.Info ( testSuite ) where++import Prelude hiding ( pi )+import Data.ByteString ( ByteString )+import qualified Data.ByteString as B ( split, pack )+import qualified Data.ByteString.Char8 as BC ( unpack )+import Data.List ( sort )+import Data.Maybe ( isNothing )+import Data.Text as T ( find, any )+import Data.Text.Encoding ( decodeUtf8With )+import Data.Text.Encoding.Error ( lenientDecode )+import System.IO.Unsafe ( unsafePerformIO )+import Test.QuickCheck ( Arbitrary(arbitrary), oneof, listOf, choose, shrink+ , Gen )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.Framework (Test, testGroup)+import Data.List ( isPrefixOf )++import Darcs.Patch.Info ( PatchInfo(..), patchinfo,+ piLog, piAuthor, piName )+import Darcs.Util.ByteString ( decodeLocale, packStringToUTF8, unpackPSFromUTF8 )++testSuite :: Test+testSuite = testGroup "Darcs.Patch.Info"+ [ metadataDecodingTest+ , metadataEncodingTest+ , packUnpackTest+ ]++-- | A newtype wrapping String so we can make our own random generator for it.+newtype UnicodeString = UnicodeString { asString :: String }+ deriving (Show, Eq, Ord)++-- | A newtype wrapping PatchInfo that has a random generator that generates+-- both UTF-8-encoded and non-encoded PatchInfo's.+newtype UTF8OrNotPatchInfo = UTF8OrNotPatchInfo PatchInfo deriving (Eq, Ord)++-- | A newtype wrapping PatchInfo, which has a random generator that generates+-- only UTF-8-encoded PatchInfo's.+newtype UTF8PatchInfo = UTF8PatchInfo PatchInfo deriving (Eq, Ord)++instance Arbitrary UnicodeString where+ -- 0x10ffff is the highest Unicode code point ; 0xd800 - 0xdfff are+ -- surrogates. '\xfffd' is excluded because it is used as a marker+ -- for UTF-8 test failure.+ arbitrary = UnicodeString `fmap` listOf (oneof [choose ('\0', '\xd799')+ ,choose ('\xe000', '\xfffc')+ ,choose ('\xfffe', '\x10ffff')])++instance Show UTF8PatchInfo where+ showsPrec _ = withUTF8PatchInfo rawPatchInfoShow+instance Show UTF8OrNotPatchInfo where+ showsPrec _ = withUTF8OrNotPatchInfo rawPatchInfoShow++-- | Shows a PatchInfo, outputting every byte and clearly marking what is what+rawPatchInfoShow :: PatchInfo -> String -> String+rawPatchInfoShow pi = ("PatchInfo: \n"++)+ . ("date: "++) . shows (_piDate pi) . ('\n':)+ . ("author: "++) . shows (_piAuthor pi) . ('\n':)+ . ("name: "++) . shows (_piName pi) . ('\n':)+ . ("log: "++) . shows (_piLog pi) . ('\n':)++instance Arbitrary UTF8PatchInfo where+ arbitrary = UTF8PatchInfo `fmap` arbitraryUTF8Patch+ shrink upi = flip withUTF8PatchInfo upi $ \pi -> do+ sn <- shrink (piName pi)+ sa <- shrink (piAuthor pi)+ sl <- shrink (filter (not . isPrefixOf "Ignore-this:") (piLog pi))+ return (UTF8PatchInfo+ (unsafePerformIO $ patchinfo sn+ (BC.unpack (_piDate pi)) sa sl))++instance Arbitrary UTF8OrNotPatchInfo where+ arbitrary = UTF8OrNotPatchInfo `fmap` oneof ([arbitraryUTF8Patch,+ arbitraryUnencodedPatch])++-- | Generate arbitrary patch metadata that uses the metadata creation function+-- 'patchinfo' from Darcs.Patch.Info.+arbitraryUTF8Patch :: Gen PatchInfo+arbitraryUTF8Patch =+ do n <- asString `fmap` arbitrary+ d <- arbitrary+ a <- asString `fmap` arbitrary+ l <- (lines . asString) `fmap` arbitrary+ return $ unsafePerformIO $ patchinfo n d a l++-- | Generate arbitrary patch metadata that has totally arbitrary byte strings+-- as its name, date, author and log.+arbitraryUnencodedPatch :: Gen PatchInfo+arbitraryUnencodedPatch = do+ n <- arbitraryByteString+ d <- arbitraryByteString+ a <- arbitraryByteString+ -- split 10 is the ByteString equivalent of 'lines'+ l <- B.split 10 `fmap` arbitraryByteString+ i <- arbitrary+ return (PatchInfo d n a l i)++arbitraryByteString :: Gen ByteString+arbitraryByteString = (B.pack . map fromIntegral)+ `fmap` listOf (choose (0, 255) :: Gen Int)++-- | Test that anything produced by the 'patchinfo' function is valid UTF-8+metadataEncodingTest :: Test+metadataEncodingTest = testProperty "Testing patch metadata encoding" $+ withUTF8PatchInfo $+ \patchInfo -> encodingOK (_piAuthor patchInfo)+ && encodingOK (_piName patchInfo)+ && all encodingOK (_piLog patchInfo)+ where encodingOK = isNothing . T.find (=='\xfffd') . decodeUtf8With lenientDecode++-- | Test that metadata in patches are decoded as UTF-8 or locale depending on+-- whether they're valid UTF-8.+metadataDecodingTest :: Test+metadataDecodingTest = testProperty "Testing patch metadata decoding" $+ withUTF8OrNotPatchInfo $+ \patchInfo -> utf8OrLocale (_piAuthor patchInfo) == piAuthor patchInfo+ && utf8OrLocale (_piName patchInfo) == piName patchInfo+ && map utf8OrLocale (_piLog patchInfo) `superset` piLog patchInfo+ where utf8OrLocale bs = if isValidUTF8 bs+ then unpackPSFromUTF8 bs+ else decodeLocale bs++isValidUTF8 :: ByteString -> Bool+isValidUTF8 = not . T.any (=='\xfffd') . decodeUtf8With lenientDecode++packUnpackTest :: Test+packUnpackTest = testProperty "Testing UTF-8 packing and unpacking" $+ \uString -> asString uString == (unpackPSFromUTF8 . packStringToUTF8) (asString uString)++superset :: (Eq a, Ord a) => [a] -> [a] -> Bool+superset a b = sorted_superset (sort a) (sort b)+ where sorted_superset (x:xs) (y:ys) | x == y = sorted_superset xs ys+ | x < y = sorted_superset xs (y:ys)+ | otherwise = False+ sorted_superset [] (_:_) = False+ sorted_superset _ [] = True++withUTF8PatchInfo :: (PatchInfo -> a) -> UTF8PatchInfo -> a+withUTF8PatchInfo f mpi = case mpi of+ UTF8PatchInfo pinf -> f pinf+withUTF8OrNotPatchInfo :: (PatchInfo -> a) -> UTF8OrNotPatchInfo -> a+withUTF8OrNotPatchInfo f mpi = case mpi of+ UTF8OrNotPatchInfo pinf -> f pinf
+ harness/Darcs/Test/Patch/Properties/Check.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE CPP #-}+module Darcs.Test.Patch.Properties.Check ( Check(..), checkAPatch ) where++import Control.Monad ( liftM )++import Darcs.Test.Patch.Check ( PatchCheck,+ checkMove, removeDir, createDir,+ isValid, insertLine, fileEmpty, fileExists,+ deleteLine, modifyFile, createFile, removeFile,+ doCheck, 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 Darcs.Patch ( invert,+ effect )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.V1 ()+import qualified Darcs.Patch.V1.Core as V1 ( Patch(..) )+import Darcs.Patch.V1.Core ( isMerger )+import Darcs.Patch.Prim.V1 ()+import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) )+import Darcs.Patch.Witnesses.Ordered++#include "impossible.h"++class Check p where+ checkPatch :: p wX wY -> PatchCheck Bool++instance Check p => Check (FL p) where+ checkPatch NilFL = isValid+ checkPatch (p :>: ps) = checkPatch p >> checkPatch ps++checkAPatch :: (Invert p, Check p) => p wX wY -> Bool+checkAPatch p = doCheck $ do _ <- checkPatch p+ checkPatch $ invert p++instance Check (V1.Patch Prim) where+ checkPatch p | isMerger p = do+ checkPatch $ effect p+ checkPatch (V1.Merger _ _ _ _) = impossible+ checkPatch (V1.Regrem _ _ _ _) = impossible+ checkPatch (V1.PP p) = checkPatch p++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+ mapM_ (deleteLine (fn2fp f) line) old+ mapM_ (insertLine (fn2fp f) line) (reverse new)+ isValid+ checkPatch (FP f (TokReplace t old new)) =+ modifyFile (fn2fp f) (tryTokPossibly t old new)+ -- 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+ mapM_ (deleteLine (fn2fp f) 1) (linesPS o)+ _ <- fileEmpty $ fn2fp f+ mapM_ (insertLine (fn2fp f) 1) (reverse $ linesPS n)+ isValid++ checkPatch (DP d AddDir) = createDir $ fn2fp d+ checkPatch (DP d RmDir) = removeDir $ fn2fp d++ checkPatch (Move f f') = checkMove (fn2fp f) (fn2fp f')+ checkPatch (ChangePref _ _ _) = return True++tryTokPossibly :: String -> String -> String+ -> (Maybe FileContents) -> (Maybe FileContents)+tryTokPossibly t o n = liftM $ \contents ->+ let lines' = M.mapMaybe (liftM B.concat+ . tryTokInternal t (BC.pack o) (BC.pack n))+ (fcLines contents)+ in contents { fcLines = lines' }++tryTokInternal :: String -> B.ByteString -> B.ByteString+ -> B.ByteString -> Maybe [B.ByteString]+tryTokInternal _ _ _ s | B.null s = Just []+tryTokInternal t o n s =+ case BC.break (regChars t) s of+ (before,s') ->+ case BC.break (not . regChars t) s' of+ (tok,after) ->+ case tryTokInternal t o n after of+ Nothing -> Nothing+ Just rest ->+ if tok == o+ then Just $ before : n : rest+ else if tok == n+ then Nothing+ else Just $ before : tok : rest
+ harness/Darcs/Test/Patch/Properties/Generic.hs view
@@ -0,0 +1,372 @@+-- Copyright (C) 2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-}+++module Darcs.Test.Patch.Properties.Generic+ ( invertSymmetry, inverseComposition, invertRollback,+ recommute, commuteInverses, effectPreserving,+ permutivity, partialPermutivity,+ patchAndInverseCommute, mergeEitherWay,+ show_read,+ mergeCommute, mergeConsistent, mergeArgumentsConsistent,+ coalesceEffectPreserving, coalesceCommute, propIsMergeable+ ) where++import Darcs.Test.Util.TestResult ( TestResult, succeeded, failed, rejected,+ (<&&>), fromMaybe )+import Darcs.Test.Patch.RepoModel ( RepoModel, RepoState, repoApply, eqModel, showModel+ , maybeFail )+import Darcs.Test.Patch.WithState ( WithState(..), WithStartState(..) )+import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenOne )++import Control.Monad ( msum )+import Darcs.Patch.Witnesses.Show ( Show2(..), show2 )+import Darcs.Patch.Patchy ( Patchy, showPatch, commute, invert )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Show ( ShowPatchBasic )+import Darcs.Patch.Prim.Class ( PrimPatch, PrimOf, FromPrim )+import Darcs.Patch ()+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Commute ( commuteFLorComplain )+import Darcs.Patch.Merge ( Merge(merge) )+import Darcs.Patch.Read ( readPatch )+import Darcs.Patch.Invert ( invertFL )+import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:/\:)(..), lengthFL, eqFL, reverseRL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal2, Sealed2 )+import Darcs.Util.Printer ( Doc, renderPS, redText, greenText, ($$), text, RenderMode(..) )+--import Darcs.ColorPrinter ( traceDoc )++propIsMergeable :: forall model p wX . (FromPrim p, Merge p, RepoModel model)+ => Sealed (WithStartState model (Tree (PrimOf p)))+ -> Maybe (Tree p wX)+propIsMergeable (Sealed (WithStartState _ t))+ = case flattenOne t of+ Sealed ps -> let _ = seal2 ps :: Sealed2 (FL p)+ in case lengthFL ps of+ _ -> Nothing++-- | invert symmetry inv(inv(p)) = p+invertSymmetry :: (Patchy p, MyEq p) => p wA wB -> TestResult+invertSymmetry p = case invert (invert p) =\/= p of+ IsEq -> succeeded+ NotEq -> failed $ redText "p /= inv(inv(p))"++inverseComposition :: (Patchy p, MyEq p) => (p :> p) wX wY -> TestResult+inverseComposition (a :> b) =+ case eqFL (reverseRL (invertFL (a:>:b:>:NilFL))) (invert b:>:invert a:>:NilFL) of+ IsEq -> succeeded+ NotEq -> failed $ redText "inv(a :>: b :>: NilFL) /= inv(b) :>: inv(a) :>: NilFL"++-- | invert rollback if b = A(a) then a = A'(b)+invertRollback :: (ApplyState p ~ RepoState model, Patchy p, ShowPatchBasic p, RepoModel model)+ => WithState model p wA wB -> TestResult+invertRollback (WithState a x b)+ = case maybeFail $ repoApply b (invert x) of+ Nothing -> failed $ redText "x' not applicable to b."+ Just a1 -> if a1 `eqModel` a+ then succeeded+ else failed $ redText "a1: " $$ text (showModel a1)+ $$ redText " ---- is not equals to a:" $$ text (showModel a)+ $$ redText "where a was" $$ text (showModel b)+ $$ redText "with (invert x) on top:" $$ showPatch (invert x)++-- | recommute AB ↔ B′A′ if and only if B′A′ ↔ AB+recommute :: (Patchy p, ShowPatchBasic p, MyEq p) => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY)))+ -> (p :> p) wA wB -> TestResult+recommute c (x :> y) =+ case c (x :> y) of+ Nothing -> rejected+ Just (y' :> x') ->+ case c (y' :> x') of+ Nothing -> failed (redText "failed" $$ showPatch y' $$ redText ":>" $$ showPatch x')+ Just (x'' :> y'') ->+ case y'' =/\= y of+ NotEq -> failed (redText "y'' =/\\= y failed, where x" $$ showPatch x $$+ redText ":> y" $$ showPatch y $$+ redText "y'" $$ showPatch y' $$+ redText ":> x'" $$ showPatch x' $$+ redText "x''" $$ showPatch x'' $$+ redText ":> y''" $$ showPatch y'')+ IsEq -> case x'' =/\= x of+ NotEq -> failed (redText "x'' /= x" $$ showPatch x'' $$ redText ":>" $$ showPatch y'')+ IsEq -> succeeded++-- | commuteInverses AB ↔ B′A′ if and only if B⁻¹A⁻¹ ↔ A′⁻¹B′⁻¹+commuteInverses :: (Patchy p, ShowPatchBasic p, MyEq p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+ -> (p :> p) wA wB -> TestResult+commuteInverses c (x :> y) =+ case c (x :> y) of+ Nothing -> rejected+ Just (y' :> x') ->+ case c (invert y :> invert x) of+ Nothing -> failed $ redText "second commute failed" $$+ redText "x" $$ showPatch x $$ redText "y" $$ showPatch y $$+ redText "y'" $$ showPatch y' $$ redText "x'" $$ showPatch x'+ Just (ix' :> iy') ->+ case invert ix' =/\= x' of+ NotEq -> failed $ redText "invert ix' /= x'" $$+ redText "x" $$ showPatch x $$+ redText "y" $$ showPatch y $$+ redText "y'" $$ showPatch y' $$+ redText "x'" $$ showPatch x' $$+ redText "ix'" $$ showPatch ix' $$+ redText "iy'" $$ showPatch iy' $$+ redText "invert ix'" $$ showPatch (invert ix') $$+ redText "invert iy'" $$ showPatch (invert iy')+ IsEq -> case y' =\/= invert iy' of+ NotEq -> failed $ redText "y' /= invert iy'" $$ showPatch iy' $$ showPatch y'+ IsEq -> succeeded++-- | effect preserving AB <--> B'A' then effect(AB) = effect(B'A')+effectPreserving :: (Patchy p, RepoModel model, ApplyState p ~ RepoState model) =>+ (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+ -> WithState model (p :> p) wA wB -> TestResult+effectPreserving c (WithState r (x :> y) r')+ = case c (x :> y) of+ Nothing -> rejected+ Just (y' :> x') ->+ case maybeFail $ repoApply r y' of+ Nothing -> failed $ redText "y' is not applicable to r."+ Just r_y' ->+ case maybeFail $ repoApply r_y' x' of+ Nothing -> failed $ redText "x' is not applicable to r_y'."+ Just r_y'x' -> if r_y'x' `eqModel` r'+ then succeeded+ else failed $ redText "r_y'x' is not equal to r'."++-- | patchAndInverseCommute If AB ↔ B′A′ then A⁻¹B′ ↔ BA′⁻¹+patchAndInverseCommute :: (Patchy p, ShowPatchBasic p, MyEq p) =>+ (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+ -> (p :> p) wA wB -> TestResult+patchAndInverseCommute c (x :> y) =+ case c (x :> y) of+ Nothing -> rejected+ Just (y' :> x') ->+ case c (invert x :> y') of+ Nothing -> failed (redText ""+ $$ redText "-------- original commute (x :> y):"+ $$ showPatch x $$ redText ":>" $$ showPatch y+ $$ redText "-------- result (y' :> x'):"+ $$ showPatch y' $$ redText ":>" $$ showPatch x'+ $$ redText "-------- bad commute (invert x :> y'):"+ $$ showPatch (invert x) $$ redText ":>" $$ showPatch y')+ Just (y'' :> ix') ->+ case y'' =\/= y of+ NotEq -> failed (redText "y'' /= y" $$+ redText "x" $$ showPatch x $$+ redText "y" $$ showPatch y $$+ redText "x'" $$ showPatch x' $$+ redText "y'" $$ showPatch y' $$+ redText "y''" $$ showPatch y'' $$+ redText ":> x'" $$ showPatch x')+ IsEq -> case x' =\/= invert ix' of+ NotEq -> failed (redText "x' /= invert ix'" $$+ redText "y''" $$ showPatch y'' $$+ redText ":> x'" $$ showPatch x' $$+ redText "invert x" $$ showPatch (invert x) $$+ redText ":> y" $$ showPatch y $$+ redText "y'" $$ showPatch y' $$+ redText "ix'" $$ showPatch ix')+ IsEq -> succeeded++permutivity :: (Patchy p, ShowPatchBasic p, MyEq p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+ -> (p :> p :> p) wA wB -> TestResult+permutivity c (x:>y:>z) =+ case c (x :> y) of+ Nothing -> rejected+ Just (y1 :> x1) ->+ case c (y :> z) of+ Nothing -> rejected+ Just (z2 :> y2) ->+ case c (x :> z2) of+ Nothing -> rejected+ Just (z3 :> x3) ->+ case c (x1 :> z) of+ Nothing -> failed $ redText "permutivity1"+ Just (z4 :> x4) ->+ --traceDoc (greenText "third commuted" $$+ -- greenText "about to commute" $$+ -- greenText "y1" $$ showPatch y1 $$+ -- greenText "z4" $$ showPatch z4) $+ case c (y1 :> z4) of+ Nothing -> failed $ redText "permutivity2"+ Just (z3_ :> y4)+ | IsEq <- z3_ =\/= z3 ->+ --traceDoc (greenText "passed z3") $ error "foobar test" $+ case c (y4 :> x4) of+ Nothing -> failed $ redText "permutivity5: input was" $$+ redText "x" $$ showPatch x $$+ redText "y" $$ showPatch y $$+ redText "z" $$ showPatch z $$+ redText "z3" $$ showPatch z3 $$+ redText "failed commute of" $$+ redText "y4" $$ showPatch y4 $$+ redText "x4" $$ showPatch x4 $$+ redText "whereas commute of x and y give" $$+ redText "y1" $$ showPatch y1 $$+ redText "x1" $$ showPatch x1+ Just (x3_ :> y2_)+ | NotEq <- x3_ =\/= x3 -> failed $ redText "permutivity6"+ | NotEq <- y2_ =/\= y2 -> failed $ redText "permutivity7"+ | otherwise -> succeeded+ | otherwise ->+ failed $ redText "permutivity failed" $$+ redText "z3" $$ showPatch z3 $$+ redText "z3_" $$ showPatch z3_++partialPermutivity :: (Patchy p, ShowPatchBasic p) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+ -> (p :> p :> p) wA wB -> TestResult+partialPermutivity c (xx:>yy:>zz) = pp (xx:>yy:>zz) <&&> pp (invert zz:>invert yy:>invert xx)+ where pp (x:>y:>z) =+ case c (y :> z) of+ Nothing -> rejected+ Just (z1 :> y1) ->+ case c (x :> z1) of+ Nothing -> rejected+ Just (_ :> x1) ->+ case c (x :> y) of+ Just _ -> rejected -- this is covered by full permutivity test above+ Nothing ->+ case c (x1 :> y1) of+ Nothing -> succeeded+ Just _ -> failed $ greenText "partialPermutivity error" $$+ greenText "x" $$ showPatch x $$+ greenText "y" $$ showPatch y $$+ greenText "z" $$ showPatch z++mergeArgumentsConsistent :: (Patchy p, ShowPatchBasic p) =>+ (forall wX wY . p wX wY -> Maybe Doc)+ -> (p :\/: p) wA wB -> TestResult+mergeArgumentsConsistent isConsistent (x :\/: y) =+ fromMaybe $+ msum [(\z -> redText "mergeArgumentsConsistent x" $$ showPatch x $$ z) `fmap` isConsistent x,+ (\z -> redText "mergeArgumentsConsistent y" $$ showPatch y $$ z) `fmap` isConsistent y]++mergeConsistent :: (Patchy p, ShowPatchBasic p, Merge p) =>+ (forall wX wY . p wX wY -> Maybe Doc)+ -> (p :\/: p) wA wB -> TestResult+mergeConsistent isConsistent (x :\/: y) =+ case merge (x :\/: y) of+ y' :/\: x' ->+ fromMaybe $+ msum [(\z -> redText "mergeConsistent x" $$ showPatch x $$ z) `fmap` isConsistent x,+ (\z -> redText "mergeConsistent y" $$ showPatch y $$ z) `fmap` isConsistent y,+ (\z -> redText "mergeConsistent x'" $$ showPatch x' $$ z $$+ redText "where x' comes from x" $$ showPatch x $$+ redText "and y" $$ showPatch y) `fmap` isConsistent x',+ (\z -> redText "mergeConsistent y'" $$ showPatch y' $$ z) `fmap` isConsistent y']++mergeEitherWay :: (Patchy p, MyEq p, Merge p) => (p :\/: p) wX wY -> TestResult+mergeEitherWay (x :\/: y) =+ case merge (x :\/: y) of+ y' :/\: x' -> case merge (y :\/: x) of+ x'' :/\: y'' | IsEq <- x'' =\/= x',+ IsEq <- y'' =\/= y' -> succeeded+ | otherwise -> failed $ redText "mergeEitherWay bug"++mergeCommute :: (Patchy p, MyEq p, ShowPatchBasic p, Merge p) => (p :\/: p) wX wY -> TestResult+mergeCommute (x :\/: y) =+ case merge (x :\/: y) of+ y' :/\: x' ->+ case commute (x :> y') of+ Nothing -> failed $ redText "mergeCommute 1" $$+ redText "x" $$ showPatch x $$+ redText "y" $$ showPatch y $$+ redText "x'" $$ showPatch x' $$+ redText "y'" $$ showPatch y'+ Just (y_ :> x'_)+ | IsEq <- y_ =\/= y,+ IsEq <- x'_ =\/= x' ->+ case commute (y :> x') of+ Nothing -> failed $ redText "mergeCommute 2 failed" $$+ redText "x" $$ showPatch x $$+ redText "y" $$ showPatch y $$+ redText "x'" $$ showPatch x' $$+ redText "y'" $$ showPatch y'+ Just (x_ :> y'_)+ | IsEq <- x_ =\/= x,+ IsEq <- y'_ =\/= y' -> succeeded+ | otherwise -> failed $ redText "mergeCommute 3" $$+ redText "x" $$ showPatch x $$+ redText "y" $$ showPatch y $$+ redText "x'" $$ showPatch x' $$+ redText "y'" $$ showPatch y' $$+ redText "x_" $$ showPatch x_ $$+ redText "y'_" $$ showPatch y'_+ | otherwise -> failed $ redText "mergeCommute 4" $$+ redText "x" $$ showPatch x $$+ redText "y" $$ showPatch y $$+ redText "x'" $$ showPatch x' $$+ redText "y'" $$ showPatch y' $$+ redText "x'_" $$ showPatch x'_ $$+ redText "y_" $$ showPatch y_+++-- | coalesce effect preserving+coalesceEffectPreserving+ :: (PrimPatch prim, RepoModel model, ApplyState prim ~ RepoState model )+ => (forall wX wY . (prim :> prim) wX wY -> Maybe (FL prim wX wY))+ -> WithState model (prim :> prim) wA wB -> TestResult+coalesceEffectPreserving j (WithState r (a :> b) r') =+ case j (a :> b) of+ Nothing -> rejected+ Just x -> case maybeFail $ repoApply r x of+ Nothing -> failed $ redText "x is not applicable to r."+ Just r_x -> if r_x `eqModel` r'+ then succeeded+ else failed $ redText "r_x /= r'"++coalesceCommute+ :: (PrimPatch prim) => (forall wX wY . (prim :> prim) wX wY -> Maybe (FL prim wX wY))+ -> (prim :> prim :> prim) wA wB -> TestResult+coalesceCommute j (a :> b :> c) =+ case j (b :> c) of+ Nothing -> rejected+ Just x ->+ case commuteFLorComplain (a :> b :>: c :>: NilFL) of+ Right (b' :>: c' :>: NilFL :> a') ->+ case commute (a:>:NilFL :> x) of+ Just (x' :> a'':>:NilFL) ->+ case a'' =/\= a' of+ NotEq -> failed $ greenText "coalesceCommute 3"+ IsEq -> case j (b' :> c') of+ Nothing -> failed $ greenText "coalesceCommute 4"+ Just x'' -> case x' =\/= x'' of+ NotEq -> failed $ greenText "coalesceCommute 5"+ IsEq -> succeeded+ _ -> failed $ greenText "coalesceCommute 1"+ _ -> rejected++show_read :: (Show2 p, MyEq p, ReadPatch p, ShowPatchBasic p, Patchy p) => p wA wB -> TestResult+show_read p = let ps = renderPS Standard (showPatch p)+ in case readPatch ps of+ Nothing -> failed (redText "unable to read " $$ showPatch p)+ Just (Sealed p' ) | IsEq <- p' =\/= p -> succeeded+ | otherwise -> failed $ redText "trouble reading patch p" $$+ showPatch p $$+ redText "reads as p'" $$+ showPatch p' $$+ redText "aka" $$+ greenText (show2 p) $$+ redText "and" $$+ greenText (show2 p')++-- vim: fileencoding=utf-8 :
+ harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs view
@@ -0,0 +1,95 @@+module Darcs.Test.Patch.Properties.GenericUnwitnessed where++import qualified Darcs.Test.Patch.Properties.Generic as W+ ( permutivity, partialPermutivity+ , mergeConsistent, mergeArgumentsConsistent, mergeEitherWay+ , mergeCommute, patchAndInverseCommute, coalesceCommute, commuteInverses+ , recommute+ , show_read )+import Darcs.Test.Patch.Arbitrary.Generic ( Tree )+import Darcs.Test.Patch.RepoModel( RepoModel, RepoState )+import Darcs.Test.Patch.WithState( WithStartState )++import qualified Darcs.Test.Patch.Properties.Real as W ( propConsistentTreeFlattenings )+import Darcs.Test.Patch.WSub+import Darcs.Test.Util.TestResult++import Darcs.Patch.Prim.V1 ( Prim )+import Darcs.Patch.Patchy ( showPatch )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Show ( ShowPatchBasic )+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Sealed( Sealed )+import Darcs.Patch.Merge ( Merge )+import Darcs.Patch ( Patchy )+import Darcs.Util.Printer ( Doc, redText, ($$) )+import qualified Storage.Hashed.Tree as HST ( Tree )+++permutivity :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p)+ => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+ -> (p :> p :> p) wA wB -> TestResult+permutivity f = W.permutivity (fmap toW . f . fromW) . toW++partialPermutivity :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p)+ => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+ -> (p :> p :> p) wA wB -> TestResult+partialPermutivity f = W.partialPermutivity (fmap toW . f . fromW) . toW++mergeEitherWay :: (Patchy wp, ShowPatchBasic wp, MyEq wp, Merge wp, WSub wp p) => (p :\/: p) wX wY -> TestResult+mergeEitherWay = W.mergeEitherWay . toW++commuteInverses :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p)+ => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+ -> (p :> p) wA wB -> TestResult+commuteInverses f = W.commuteInverses (fmap toW . f . fromW) . toW++recommute :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p)+ => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY)))+ -> (p :> p) wA wB -> TestResult+recommute f = W.recommute (fmap toW . f . fromW) . toW++mergeCommute :: (Patchy wp, ShowPatchBasic wp, MyEq wp, Merge wp, WSub wp p) => (p :\/: p) wX wY -> TestResult+mergeCommute = W.mergeCommute . toW++mergeConsistent :: (Patchy wp, Merge wp, ShowPatchBasic wp, WSub wp p) =>+ (forall wX wY . p wX wY -> Maybe Doc)+ -> (p :\/: p) wA wB -> TestResult+mergeConsistent f = W.mergeConsistent (f . fromW) . toW++mergeArgumentsConsistent :: (Patchy wp, ShowPatchBasic wp, WSub wp p) =>+ (forall wX wY . p wX wY -> Maybe Doc)+ -> (p :\/: p) wA wB -> TestResult+mergeArgumentsConsistent f = W.mergeArgumentsConsistent (f . fromW) . toW++show_read :: (Patchy p, ShowPatchBasic p, ReadPatch p, MyEq p, Show2 p) => p wX wY -> TestResult+show_read = W.show_read++patchAndInverseCommute :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p) =>+ (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+ -> (p :> p) wA wB -> TestResult+patchAndInverseCommute f = W.patchAndInverseCommute (fmap toW . f . fromW) . toW+++coalesceCommute :: (forall wX wY . (Prim :> Prim) wX wY -> Maybe (FL Prim wX wY))+ -> (Prim :> Prim :> Prim) wA wB -> TestResult+coalesceCommute f = W.coalesceCommute (fmap toW . f . fromW) . toW++consistentTreeFlattenings :: (RepoState model ~ HST.Tree, RepoModel model)+ => Sealed (WithStartState model (Tree Prim)) -> TestResult+consistentTreeFlattenings = (\x -> if W.propConsistentTreeFlattenings x+ then succeeded+ else failed $ redText "oops")++commuteFails :: (MyEq p, Patchy p, ShowPatchBasic p)+ => ((p :> p) wX wY -> Maybe ((p :> p) wX wY))+ -> (p :> p) wX wY+ -> TestResult+commuteFails c (x :> y) = case c (x :> y) of+ Nothing -> succeeded+ Just (y' :> x') ->+ failed $ redText "x" $$ showPatch x $$+ redText ":> y" $$ showPatch y $$+ redText "y'" $$ showPatch y' $$+ redText ":> x'" $$ showPatch x'
+ harness/Darcs/Test/Patch/Properties/Real.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}+module Darcs.Test.Patch.Properties.Real+ ( propConsistentTreeFlattenings ) where++import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenTree, G2(..), mapTree )+import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel ( RepoModel, repoApply, showModel, eqModel, RepoState+ , Fail, maybeFail )+import qualified Storage.Hashed.Tree as HST ( Tree )++import Darcs.Patch.Witnesses.Sealed( Sealed(..) )+import Darcs.Patch.V2.Real( prim2real )+import Darcs.Patch.Prim.V1 ( Prim )++#include "impossible.h"++assertEqualFst :: (RepoModel a, Show b, Show c) => (Fail (a x), b) -> (Fail (a x), c) -> Bool+assertEqualFst (x,bx) (y,by)+ | Just x' <- maybeFail x, Just y' <- maybeFail y, x' `eqModel` y' = True+ | Nothing <- maybeFail x, Nothing <- maybeFail y = True+ | otherwise = error ("Not really equal:\n" ++ showx ++ "\nand\n" ++ showy+ ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by)+ where showx | Just x' <- maybeFail x = showModel x'+ | otherwise = "Nothing"+ showy | Just y' <- maybeFail y = showModel y'+ | otherwise = "Nothing"++propConsistentTreeFlattenings :: (RepoState model ~ HST.Tree, RepoModel model)+ => Sealed (WithStartState model (Tree Prim)) -> Bool+propConsistentTreeFlattenings (Sealed (WithStartState start t))+ = fromJust $+ do Sealed (G2 flat) <- return $ flattenTree $ mapTree prim2real t+ rms <- return $ map (start `repoApply`) flat+ return $ and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat)+
+ harness/Darcs/Test/Patch/Properties/V1Set1.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Darcs.Test.Patch.Properties.V1Set1+ ( checkMerge, checkMergeEquiv, checkMergeSwap, checkCanon+ , checkCommute, checkCantCommute+ , tShowRead+ , tMergeEitherWayValid, tTestCheck ) where++import Darcs.Patch+ ( Patchy, commute, invert, merge, effect+ , readPatch, showPatch+ , fromPrim, canonize, sortCoalesceFL )+import Darcs.Patch.Prim.V1 ( Prim )+import Darcs.Patch.Merge ( Merge )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Show ( ShowPatchBasic )+import qualified Darcs.Patch.V1 as V1 ( Patch )+import Darcs.Test.Patch.Properties.Check ( checkAPatch, Check )+import Darcs.Util.Printer ( renderPS, RenderMode(..) )+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Patch.Witnesses.Unsafe( unsafeCoercePEnd )+import Darcs.Test.Util.TestResult+import qualified Darcs.Util.Diff as D (DiffAlgorithm(..))+import Darcs.Util.Printer ( text )+++type Patch = V1.Patch Prim+++quickmerge :: (Patchy p, Merge p) => (p :\/: p ) wX wY -> p wY wZ+quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of+ _ :/\: p1' -> unsafeCoercePEnd p1'++instance Show2 p => Show ((p :< p) wX wY) where+ show (x :< y) = show2 x ++ " :< " ++ show2 y+instance MyEq p => Eq ((p :/\: p) wX wY) where+ (x :/\: y) == (x' :/\: y') = isIsEq (x =\/= x') && isIsEq (y =\/= y')++-- ----------------------------------------------------------------------------+-- A number of "comparison" properties: these carry out some operation on+-- inputs (first value in the pair) and compare the results with a known+-- expected value (the second value in the pair).+--++checkMerge :: ((FL Patch:\/: FL Patch) wX wY, FL Patch wY wZ) -> TestResult+checkMerge (p1:\/:p2,p1') =+ case merge (p1:\/:p2) of+ _ :/\: p1a ->+ if isIsEq (p1a `eqFL` p1')+ then succeeded+ else failed $ text $ "Merge gave wrong value!\n"++show p1++show p2+ ++"I expected\n"++show p1'+ ++"but found instead\n"++show p1a++checkMergeEquiv :: ((FL Patch:\/:FL Patch) wX wY,FL Patch wY wZ) -> TestResult+checkMergeEquiv (p1:\/: p2, pe) =+ case quickmerge (p1:\/:p2) of+ p1' -> if checkAPatch (invert p1 :>: p2 :>: p1' :>: invert pe :>: NilFL)+ then succeeded+ else failed $ text $ "Oh no, merger isn't equivalent...\n"++show p1++"\n"++show p2+ ++"in other words\n" ++ show (p1 :\/: p2)+ ++"merges as\n" ++ show (merge $ p1 :\/: p2)+ ++"merges to\n" ++ show (quickmerge $ p1 :\/: p2)+ ++"which is equivalent to\n" ++ show (effect p1')+ ++ "should all work out to\n"+ ++ show pe++checkMergeSwap :: (FL Patch wX wY, FL Patch wX wZ) -> TestResult+checkMergeSwap (p1, p2) =+ case merge (p2:\/:p1) of+ _ :/\: p2' ->+ case merge (p1:\/:p2) of+ _ :/\: p1' ->+ case commute (p1:>p2') of+ Just (_:>p1'b) ->+ if not $ p1'b `eqFLUnsafe` p1'+ then failed $ text $ "Merge swapping problem with...\np1 "+++ show p1++"merged with\np2 "+++ show p2++"p1' is\np1' "+++ show p1'++"p1'b is\np1'b "+++ show p1'b+ else succeeded+ Nothing -> failed $ text $ "Merge commuting problem with...\np1 "+++ show p1++"merged with\np2 "+++ show p2++"gives\np2' "+++ show p2'++"which doesn't commute with p1.\n"++checkCanon :: forall wX wY . (FL Patch wX wY, FL Patch wX wY) -> TestResult+checkCanon (p1,p2) =+ if isIsEq $ eqFL p1_ p2+ then if isIsEq $ eqFL p1_p p2+ then succeeded+ else failed $ text $ "Canonization with Patience Diff failed:\n"++show p1++"canonized is\n"+ ++show (p1_p :: FL Patch wX wY)+ ++"which is not\n"++show p2+ else failed $ text $ "Canonization with Myers Diff failed:\n"++show p1++"canonized is\n"+ ++show (p1_ :: FL Patch wX wY)+ ++"which is not\n"++show p2+ where p1_ = mapFL_FL fromPrim $ concatFL $ mapFL_FL (canonize D.MyersDiff) $ sortCoalesceFL $ effect p1+ p1_p = mapFL_FL fromPrim $ concatFL $ mapFL_FL (canonize D.PatienceDiff) $ sortCoalesceFL $ effect p1++checkCommute :: ((FL Patch:< FL Patch) wX wY, (FL Patch:< FL Patch) wX wY) -> TestResult+checkCommute (p1:<p2,p2':<p1') =+ case commute (p2:>p1) of+ Just (p1a:>p2a) ->+ if (p2a:< p1a) == (p2':< p1')+ then succeeded+ else failed $ text $ "Commute gave wrong value!\n"++show p1++"\n"++show p2+ ++"should be\n"++show p2'++"\n"++show p1'+ ++"but is\n"++show p2a++"\n"++show p1a+ Nothing -> failed $ text $ "Commute failed!\n"++show p1++"\n"++show p2+ <&&>+ case commute (p1':>p2') of+ Just (p2a:>p1a) ->+ if (p1a:< p2a) == (p1:< p2)+ then succeeded+ else failed $ text $ "Commute gave wrong value!\n"++show p2a++"\n"++show p1a+ ++"should have been\n"++show p2'++"\n"++show p1'+ Nothing -> failed $ text $ "Commute failed!\n"++show p2'++"\n"++show p1'++checkCantCommute :: (FL Patch:< FL Patch) wX wY -> TestResult+checkCantCommute (p1:<p2) =+ case commute (p2:>p1) of+ Nothing -> succeeded+ _ -> failed $ text $ show p1 ++ "\n\n" ++ show p2 +++ "\nArgh, these guys shouldn't commute!\n"++-- ----------------------------------------------------------------------------+-- A few "test" properties, doing things with input patches and giving a OK/not+-- OK type of answer.++tShowRead :: (Show2 p, Patchy p, ReadPatch p, ShowPatchBasic p)+ => (forall wX wY wW wZ . p wX wY -> p wW wZ -> Bool) -> forall wX wY . p wX wY -> TestResult+tShowRead eq p =+ case readPatch $ renderPS Standard $ showPatch p of+ Just (Sealed p') -> if p' `eq` p then succeeded+ else failed $ text $ "Failed to read shown: "++(show2 p)++"\n"+ Nothing -> failed $ text $ "Failed to read at all: "++(show2 p)++"\n"++tMergeEitherWayValid :: forall wX wY p . (Check p, Show2 p, Merge p, Patchy p) => (p :\/: p) wX wY -> TestResult+tMergeEitherWayValid (p1 :\/: p2) =+ case p2 :>: quickmerge (p1:\/: p2) :>: NilFL of+ combo2 ->+ case p1 :>: quickmerge (p2:\/: p1) :>: NilFL of+ combo1 ->+ if not $ checkAPatch combo1+ then failed $ text $ "oh my combo1 invalid:\n"++show2 p1++"and...\n"++show2 p2++show combo1+ else+ if checkAPatch (invert combo1 :>: combo2 :>: NilFL)+ then succeeded+ else failed $ text $ "merge both ways invalid:\n"++show2 p1++"and...\n"++show2 p2+++ show combo1+++ show combo2++tTestCheck :: forall wX wY . FL Patch wX wY -> TestResult+tTestCheck p = if checkAPatch p+ then succeeded+ else failed $ text $ "Failed the check: "++show p++"\n"
+ harness/Darcs/Test/Patch/Properties/V1Set2.hs view
@@ -0,0 +1,316 @@+-- Copyright (C) 2002-2003,2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+++module Darcs.Test.Patch.Properties.V1Set2+ ( propCommuteInverse, propPatchAndInverseIsIdentity+ , propSimpleSmartMergeGoodEnough, propCommuteEquivalency+ , propMergeValid, propInverseValid, propOtherInverseValid+ , propCommuteEitherOrder+ , propCommuteEitherWay, propCommuteTwice+ , propMergeIsCommutableAndCorrect, propMergeIsSwapable++ , checkSubcommutes+ , subcommutesInverse, subcommutesNontrivialInverse, subcommutesFailure++ , propReadShow+ -- TODO: these are exported temporarily to mark them as used+ -- Figure out whether to enable or remove the tests.+ , propUnravelThreeMerge, propUnravelSeqMerge+ , propUnravelOrderIndependent, propResolveConflictsValid+ ) where++import Prelude hiding ( pi )+import Test.QuickCheck+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.Framework ( Test )+import Data.Maybe ( isJust )++import Darcs.Test.Patch.Properties.Check ( Check, checkAPatch )++import Darcs.Patch ( invert, commute, merge,+ readPatch, resolveConflicts,+ fromPrim, showPatch )+import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Invert ( Invert )+import qualified Darcs.Patch.V1 as V1 ( Patch )+import Darcs.Patch.V1.Commute ( unravel, merger )+import Darcs.Patch.Prim.V1 ()+import Darcs.Patch.Prim.V1.Core ( Prim(..) )+import Darcs.Patch.Prim.V1.Commute ( WrappedCommuteFunction(..), Perhaps(..),+ subcommutes )+import Darcs.Util.Printer ( renderPS, RenderMode(..) )+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), unsafeUnseal, unseal, mapSeal, Sealed2(..) )+import Darcs.Patch.Witnesses.Unsafe++#include "impossible.h"++type Patch = V1.Patch Prim+++-- | Groups a set of tests by giving them the same prefix in their description.+-- When this is called as @checkSubcommutes subcoms expl@, the prefix for a+-- test becomes @"Checking " ++ expl ++ " for subcommute "@.+checkSubcommutes :: Testable a => [(String, a)] -> String+ -> [Test]+checkSubcommutes subcoms expl = map check_subcommute subcoms+ where check_subcommute (name, test) =+ let testName = expl ++ " for subcommute " ++ name+ in testProperty testName test++propInverseValid :: Sealed2 (FL Patch) -> Bool+propInverseValid (Sealed2 p1) = checkAPatch (invert p1:>:p1:>:NilFL)+propOtherInverseValid :: Sealed2 (FL Patch) -> Bool+propOtherInverseValid (Sealed2 p1) = checkAPatch (p1:>:invert p1:>:NilFL)++propCommuteTwice :: Sealed2 (FL Patch :> FL Patch) -> Property+propCommuteTwice (Sealed2 (p1:>p2)) =+ (doesCommute p1 p2) ==> (Just (p1:>p2) == (commute (p1:>p2) >>= commute))+doesCommute :: (MyEq p, Invert p, Commute p, Check p) => p wX wY -> p wY wZ -> Bool+doesCommute p1 p2 =+ commute (p1:>p2) /= Nothing && checkAPatch (p1:>:p2:>:NilFL)+propCommuteEquivalency :: Sealed2 (FL Patch :> FL Patch) -> Property+propCommuteEquivalency (Sealed2 (p1:>p2)) =+ (doesCommute p1 p2) ==>+ case commute (p1:>p2) of+ Just (p2':>p1') -> checkAPatch (p1:>:p2:>:invert p1':>:invert p2':>:NilFL)+ _ -> impossible++propCommuteEitherWay :: Sealed2 (FL Patch :> FL Patch) -> Property+propCommuteEitherWay (Sealed2 (p1:>p2)) =+ doesCommute p1 p2 ==> doesCommute (invert p2) (invert p1)++propCommuteEitherOrder :: Sealed2 (FL Patch :> FL Patch :> FL Patch) -> Property+propCommuteEitherOrder (Sealed2 (p1:>p2:>p3)) =+ checkAPatch (p1:>:p2:>:p3:>:NilFL) &&+ doesCommute p1 (p2+>+p3) &&+ doesCommute p2 p3 ==>+ case commute (p1:>p2) of+ Nothing -> False+ Just (p2':>p1') ->+ case commute (p1':>p3) of+ Nothing -> False+ Just (p3':>_) ->+ case commute (p2':>p3') of+ Nothing -> False+ Just (p3'' :> _) ->+ case commute (p2:>p3) of+ Nothing -> False+ Just (p3'a:>_) ->+ case commute (p1:>p3'a) of+ Just (p3''a:>_) -> isIsEq (p3''a =\/= p3'')+ Nothing -> False++propPatchAndInverseIsIdentity :: Sealed2 (FL Patch :> FL Patch) -> Property+propPatchAndInverseIsIdentity (Sealed2 (p1:>p2)) =+ checkAPatch (p1:>:p2:>:NilFL) && (commute (p1:>p2) /= Nothing) ==>+ case commute (p1:>p2) of+ Just (p2':>_) -> case commute (invert p1:>p2') of+ Nothing -> True -- This is a subtle distinction.+ Just (p2'':>_) -> isIsEq (p2'' =\/= p2)+ Nothing -> impossible++propMergeIsCommutableAndCorrect :: Sealed2 (FL Patch :\/: FL Patch) -> Property+propMergeIsCommutableAndCorrect (Sealed2 (p1:\/:p2)) =+ checkAPatch (invert p1:>:p2:>:NilFL) ==>+ case merge (p2:\/:p1) of+ p1' :/\: p2' ->+ case commute (p1:>p2') of+ Nothing -> False+ Just (p2'':>p1'') -> isIsEq (p2'' =\/= p2) && isIsEq (p1' =/\= p1'')+propMergeIsSwapable :: Sealed2 (FL Patch :\/: FL Patch) -> Property+propMergeIsSwapable (Sealed2 (p1:\/:p2)) =+ checkAPatch (invert p1:>:p2:>:NilFL) ==>+ case merge (p2:\/:p1) of+ p1' :/\: p2' ->+ case merge (p1:\/:p2) of+ p2''' :/\: p1''' -> isIsEq (p1' =\/= p1''') && isIsEq (p2' =\/= p2''')++propMergeValid :: Sealed2 (FL Patch :\/: FL Patch) -> Property+propMergeValid (Sealed2 (p1:\/:p2)) =+ checkAPatch (invert p1:>:p2:>:NilFL) ==>+ case merge (p2:\/:p1) of+ _ :/\: p2' ->+ checkAPatch (invert p1:>:p2:>:invert p2:>:p1:>:p2':>:NilFL)++propSimpleSmartMergeGoodEnough :: Sealed2 (FL Patch :\/: FL Patch) -> Property+propSimpleSmartMergeGoodEnough (Sealed2 (p1:\/:p2)) =+ checkAPatch (invert p1:>:p2:>:NilFL) ==>+ case simpleSmartMerge (p1 :\/: p2) of+ Nothing -> True+ Just (Sealed p1'a)+ -> isJust ((do+ p1o :> _ <- commute (p2 :> p1'a)+ IsEq <- return $ p1o =\/= p1+ Sealed p2'a <- simpleSmartMerge (p2 :\/: p1)+ p2b :> p1'b <- commute (p1 :> p2'a)+ IsEq <- return $ p2 =\/= p2b+ IsEq <- return $ p1'a =\/= p1'b+ return ()) :: Maybe ())++simpleSmartMerge :: (Commute p, Invert p) => (p :\/: p) wX wY -> Maybe (Sealed (p wY))+simpleSmartMerge (p1 :\/: p2) =+ case commute (invert p2 :> p1) of+ Just (p1':>_) -> Just (Sealed p1')+ Nothing -> Nothing++-- | The conflict resolution code (glump) begins by "unravelling" the merger+-- into a set of sequences of patches. Each sequence of patches corresponds+-- to one non-conflicted patch that got merged together with the others. The+-- result of the unravelling of a series of merges must obviously be+-- independent of the order in which those merges are performed. This+-- unravelling code (which uses the unwind code mentioned above) uses probably+-- the second most complicated algorithm. Fortunately, if we can successfully+-- unravel the merger, almost any function of the unravelled merger satisfies+-- the two constraints mentioned above that the conflict resolution code must+-- satisfy.+propUnravelThreeMerge :: Patch wX wY -> Patch wX wZ -> Patch wX wW -> Property+propUnravelThreeMerge p1 p2 p3 =+ checkAPatch (invert p1:>:p2:>:invert p2:>:p3:>:NilFL) ==>+ (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal (merger "0.0" p2 p3)) (unsafeUnseal (merger "0.0" p2 p1))) ==+ (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal (merger "0.0" p1 p3)) (unsafeUnseal (merger "0.0" p1 p2)))++propUnravelSeqMerge :: Patch wX wY -> Patch wX wZ -> Patch wZ wW -> Property+propUnravelSeqMerge p1 p2 p3 =+ checkAPatch (invert p1:>:p2:>:p3:>:NilFL) ==>+ (unravel $ unsafeUnseal $ merger "0.0" p3 $ unsafeUnseal $ merger "0.0" p2 p1) ==+ (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal $ merger "0.0" p2 p1) p3)++propUnravelOrderIndependent :: Patch wX wY -> Patch wX wZ -> Property+propUnravelOrderIndependent p1 p2 =+ checkAPatch (invert p1:>:p2:>:NilFL) ==>+ (unravel $ unsafeCoercePStart $ unsafeUnseal $ merger "0.0" p2 p1) == (unravel $ unsafeUnseal $ merger "0.0" p1 p2)++propResolveConflictsValid :: Patch wX wY -> Patch wX wZ -> Property+propResolveConflictsValid p1 p2 =+ case merge (p1:\/:p2) of+ _ :/\: p1' ->+ let p = p2:>:p1':>:NilFL in+ checkAPatch (invert p1:>:p2:>:NilFL) ==>+ and $ map (\l -> (\ml -> checkAPatch (p+>+ml)) `unseal` mergeList l)+ $ resolveConflicts p++mergeList :: [Sealed (FL Prim wX)] -> Sealed (FL Patch wX)+mergeList patches = mapFL_FL fromPrim `mapSeal` doml NilFL patches+ where doml :: FL Prim wX wY -> [Sealed (FL Prim wX)] -> Sealed (FL Prim wX)+ doml mp (Sealed p:ps) =+ case commute (invert p :> mp) of+ Just (mp' :> _) -> doml (p +>+ mp') ps+ Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions.+ doml mp [] = Sealed mp++propReadShow :: FL Patch wX wY -> Bool+propReadShow p = case readPatch $ renderPS Standard $ showPatch p of+ Just (Sealed p') -> isIsEq (p' =\/= p)+ Nothing -> False++-- |In order for merges to work right with commuted patches, inverting a patch+-- past a patch and its inverse had golly well better give you the same patch+-- back again.+propCommuteInverse :: Sealed2 (FL Patch :> FL Patch) -> Property+propCommuteInverse (Sealed2 (p1 :> p2)) =+ doesCommute p1 p2 ==> case commute (p1 :> p2) of+ Nothing -> impossible+ Just (_ :> p1') ->+ case commute (p1' :> invert p2) of+ Nothing -> False+ Just (_ :> p1'') -> isIsEq (p1'' =/\= p1)++type CommuteProperty = Sealed2 (Prim :> Prim) -> Property++subcommutesInverse :: [(String, CommuteProperty)]+subcommutesInverse = zip names (map prop_subcommute cs)+ where (names, cs) = unzip subcommutes+ prop_subcommute c (Sealed2 (p1:>p2)) =+ does c p1 p2 ==>+ case runWrappedCommuteFunction c (p2:< p1) of+ Succeeded (p1':<p2') ->+ case runWrappedCommuteFunction c (invert p2:< p1') of+ Succeeded (p1'':<ip2x') -> isIsEq (p1'' =/\= p1) &&+ case runWrappedCommuteFunction c (invert p1:< invert p2) of+ Succeeded (ip2':< ip1') ->+ case runWrappedCommuteFunction c (p2':< invert p1) of+ Succeeded (ip1o':< p2o) -> isJust ((do+ IsEq <- return $ invert ip1' =/\= p1'+ IsEq <- return $ invert ip2' =/\= p2'+ IsEq <- return $ ip1o' =/\= ip1'+ IsEq <- return $ p2o =\/= p2+ IsEq <- return $ p1'' =/\= p1+ IsEq <- return $ ip2x' =\/= ip2'+ return ()) :: Maybe ())+ _ -> False+ _ -> False+ _ -> False+ _ -> False++subcommutesNontrivialInverse :: [(String, CommuteProperty)]+subcommutesNontrivialInverse = zip names (map prop_subcommute cs)+ where -- speedyCommute will never be "nontrivial"+ (names, cs) = unzip . filter ((/= "speedyCommute") . fst) $ subcommutes+ prop_subcommute c (Sealed2 (p1 :> p2)) =+ nontrivial c p1 p2 ==>+ case runWrappedCommuteFunction c (p2:< p1) of+ Succeeded (p1':<p2') ->+ case runWrappedCommuteFunction c (invert p2:< p1') of+ Succeeded (p1'':<ip2x') -> isIsEq (p1'' =/\= p1) &&+ case runWrappedCommuteFunction c (invert p1:< invert p2) of+ Succeeded (ip2':< ip1') ->+ case runWrappedCommuteFunction c (p2':< invert p1) of+ Succeeded (ip1o':< p2o) -> isJust ((do+ IsEq <- return $ invert ip1' =/\= p1'+ IsEq <- return $ invert ip2' =/\= p2'+ IsEq <- return $ ip1o' =/\= ip1'+ IsEq <- return $ p2o =\/= p2+ IsEq <- return $ p1'' =/\= p1+ IsEq <- return $ ip2x' =\/= ip2'+ return ()) :: Maybe ())+ _ -> False+ _ -> False+ _ -> False+ _ -> False++subcommutesFailure :: [(String, CommuteProperty)]+subcommutesFailure = zip names (map prop cs)+ where -- speedyCommute will never fail (it just returns "Unknown")+ (names, cs) = unzip . filter ((/= "speedyCommute") . fst) $ subcommutes+ prop c (Sealed2 (p1 :> p2)) =+ doesFail c p1 p2 ==>+ case runWrappedCommuteFunction c (invert p1 :< invert p2) of+ Failed -> True+ _ -> False++doesFail :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool+doesFail c p1 p2 =+ fails (runWrappedCommuteFunction c (p2:<p1)) && checkAPatch (p1 :>: p2 :>: NilFL)+ where fails Failed = True+ fails _ = False++does :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool+does c p1 p2 =+ succeeds (runWrappedCommuteFunction c (p2:<p1)) && checkAPatch (p1 :>: p2 :>: NilFL)+ where succeeds (Succeeded _) = True+ succeeds _ = False++nontrivial :: WrappedCommuteFunction -> Prim wX wY -> Prim wY wZ -> Bool+nontrivial c p1 p2 =+ succeeds (runWrappedCommuteFunction c (p2:<p1)) && checkAPatch (p1 :>: p2 :>: NilFL)+ where succeeds (Succeeded (p1' :< p2')) = not (p1' `unsafeCompare` p1 && p2' `unsafeCompare` p2)+ succeeds _ = False
+ harness/Darcs/Test/Patch/Rebase.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE EmptyDataDecls #-}+module Darcs.Test.Patch.Rebase ( testSuite ) where++import Control.Monad ( unless )++import Test.Framework ( Test )+import Test.Framework.Providers.HUnit ( testCase )+import Test.HUnit ( assertFailure )++import Darcs.Patch+import Darcs.Patch.Conflict+import Darcs.Patch.Rebase+import Darcs.Patch.Rebase.Viewing+import Darcs.Patch.Type+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Show++import Darcs.Test.Patch.Arbitrary.Generic++testSuite :: forall p . (RepoPatch p, ArbitraryPrim (PrimOf p), Show2 (PrimOf p)) => PatchType p -> [Test]+testSuite pt =+ if hasPrimConstruct (undefined :: PrimOf p WX WX)+ then+ [ duplicateConflictedEffect pt+ ]+ else+ [+ ]++data WX++duplicateConflictedEffect :: forall p . (RepoPatch p, Show2 (PrimOf p)) => PatchType p -> Test+duplicateConflictedEffect _ =+ testCase "duplicate in rebase fixup has a conflicted effect" $+ unless (all (/= Okay) cStatuses) $+ assertFailure ("unexpected conflicted effect: " ++ show cEffect)+ where+ corePrim = addfile "./file"+ rebase :: RebaseChange p WX WX+ rebase = RCFwd (PrimFixup (invert corePrim) :>: NilFL) (fromPrim corePrim :>: NilFL)+ cEffect = conflictedEffect rebase+ cStatuses = map (\(IsC status _) -> status) cEffect
+ harness/Darcs/Test/Patch/RepoModel.hs view
@@ -0,0 +1,23 @@+module Darcs.Test.Patch.RepoModel where+import Darcs.Patch.Apply ( Apply, ApplyState )+import Test.QuickCheck ( Gen )++type Fail = Either String++unFail :: Either [Char] t -> t+unFail (Right x) = x+unFail (Left err) = error $ "unFail failed: " ++ err++maybeFail :: Either t a -> Maybe a+maybeFail (Right x) = Just x+maybeFail _ = Nothing++class RepoModel model where+ type RepoState model :: (* -> *) -> *+ showModel :: model x -> String+ eqModel :: model x -> model x -> Bool+ aSmallRepo :: Gen (model x)+ repoApply :: (Apply p, ApplyState p ~ RepoState model) => model x -> p x y -> Fail (model y)++type family ModelOf (patch :: * -> * -> *) :: * -> *+
+ harness/Darcs/Test/Patch/Utils.hs view
@@ -0,0 +1,24 @@+module Darcs.Test.Patch.Utils+ ( testConditional, testStringList )+ where++import Test.Framework ( Test, TestName )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.HUnit ( assertFailure )+import Test.QuickCheck ( Arbitrary, Testable, (==>) )++-- | Turns a condition and a test function into a conditional quickcheck+-- property that can be run by test-framework.+testConditional+ :: (Arbitrary a, Show a, Testable prop) => TestName -- ^ Test name+ -> (a -> Bool) -- ^ Condition+ -> (a -> prop) -- ^ Test function+ -> Test+testConditional name cond t = testProperty name t'+ where t' x = cond x ==> t x++-- | Utility function to run old tests that return a list of error messages,+-- with the empty list meaning success.+testStringList :: String -> [String] -> Test+testStringList name test = testCase name $ mapM_ assertFailure test
+ harness/Darcs/Test/Patch/V1Model.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE CPP #-}+++-- | Repository model+module Darcs.Test.Patch.V1Model+ ( module Storage.Hashed.AnchoredPath+ , V1Model, repoTree+ , RepoItem, File, Dir, Content+ , makeRepo, emptyRepo+ , makeFile, emptyFile+ , emptyDir+ , nullRepo+ , isFile, isDir+ , fileContent, dirContent+ , isEmpty+ , root+ , filterFiles, filterDirs+ , find+ , list+ , ap2fp+ , aFilename, aDirname+ , aLine, aContent+ , aFile, aDir+ , aRepo+ ) where+++import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized )+import Darcs.Test.Patch.RepoModel++import Darcs.Patch.Apply( applyToTree )+import Darcs.Patch.Witnesses.Sealed ( Sealed, seal )+import Darcs.Patch.Witnesses.Show++import Storage.Hashed.AnchoredPath+import Storage.Hashed.Tree( Tree, TreeItem )+import Storage.Hashed.Darcs ( darcsUpdateHashes )+import qualified Storage.Hashed.Tree as T++import Control.Applicative ( (<$>) )+import Control.Arrow ( second )+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import Data.List ( intercalate )+import qualified Data.Map as M+import Test.QuickCheck+ ( Arbitrary(..)+ , Gen, choose, vectorOf, frequency )++#include "impossible.h"+++----------------------------------------------------------------------+-- * Model definition++-- | A repository is an abstraction build in top of a 'Tree'.+-- NB: Repository preferences are not supported yet.+newtype V1Model wX = V1Model {+ repoTree :: Tree Fail+ }++-- | Repository items may be text files or directories.+-- NB: Binary files are not supported yet.+newtype RepoItem = RepoItem {+ treeItem :: TreeItem Fail+ }++type File = RepoItem+type Dir = RepoItem++type Content = [B.ByteString]++----------------------------------------+-- Instances++instance Show (V1Model wX) where+ show repo = "V1Model{ "+ ++ intercalate " " (map showEntry $ list repo)+ ++ " }"+ where+ showPath = show . flatten+ showContent content = "[" ++ intercalate " " (map show content) ++ "]"+ showEntry (path,item)+ | isDir item = showPath path+ | isFile item = showPath path ++ showContent (fileContent item)+ showEntry _ = impossible++instance Show1 V1Model where+ showDict1 = ShowDictClass++----------------------------------------+-- Utils++bs2lbs :: B.ByteString -> BL.ByteString+bs2lbs bs = BL.fromChunks [bs]++lbs2bs :: BL.ByteString -> B.ByteString+lbs2bs = B.concat . BL.toChunks++content2lbs :: Content -> BL.ByteString+content2lbs = BLC.unlines . map bs2lbs++lbs2content :: BL.ByteString -> Content+lbs2content = map lbs2bs . BLC.lines++----------------------------------------------------------------------+-- ** Path conversion++ap2fp :: AnchoredPath -> FilePath+ap2fp = anchorPath ""++----------------------------------------------------------------------+-- * Constructors++makeRepo :: [(Name, RepoItem)] -> V1Model wX+makeRepo = V1Model . T.makeTree . map (second treeItem)++emptyRepo :: V1Model wX+emptyRepo = V1Model T.emptyTree++makeFile :: Content -> File+makeFile = RepoItem . T.File . T.makeBlob . content2lbs++emptyFile :: File+emptyFile = RepoItem $ T.File T.emptyBlob++emptyDir :: Dir+emptyDir = RepoItem $ T.SubTree T.emptyTree++----------------------------------------------------------------------+-- * Queries++nullRepo :: V1Model wX -> Bool+nullRepo = M.null . T.items . repoTree++isFile :: RepoItem -> Bool+isFile (RepoItem (T.File _)) = True+isFile _other = False++isDir :: RepoItem -> Bool+isDir (RepoItem (T.SubTree _)) = True+isDir _other = False++fileContent :: File -> Content+fileContent (RepoItem (T.File blob))+ = lbs2content $ unFail $ T.readBlob blob+fileContent _other+ = error "fileContent: Not a file."++dirContent :: Dir -> [(Name, RepoItem)]+dirContent (RepoItem (T.SubTree subtree))+ = map (second RepoItem) $ M.toList $ T.items subtree+dirContent _other+ = error "dirContent: Not a directory."++-- | @isEmpty file@ <=> file content is empty+-- @isEmpty dir@ <=> dir has no child+isEmpty :: RepoItem -> Bool+isEmpty item+ | isFile item = null $ fileContent item+ | isDir item = null $ dirContent item+ | otherwise = undefined++-- | The root directory of a repository.+root :: V1Model wX -> Dir+root = RepoItem . T.SubTree . repoTree++find :: V1Model wX -> AnchoredPath -> Maybe RepoItem+find (V1Model tree) path = RepoItem <$> T.find tree path++-- | List repository items.+-- NB: It does not include the root directory.+list :: V1Model wX -> [(AnchoredPath, RepoItem)]+list (V1Model tree) = map (second RepoItem) $ T.list tree++----------------------------------------------------------------------+-- ** Filtering++filterFiles :: [(n, RepoItem)] -> [(n, File)]+filterFiles = filter (isFile . snd)++filterDirs :: [(n, RepoItem)] -> [(n, Dir)]+filterDirs = filter (isDir . snd)++----------------------------------------------------------------------+-- * Comparing repositories++diffRepos :: V1Model wX -> V1Model wY -> (V1Model wU, V1Model wV)+diffRepos repo1 repo2 =+ let (diff1,diff2) = unFail $ T.diffTrees hashedTree1 hashedTree2+ in (V1Model diff1, V1Model diff2)+ where+ hashedTree1, hashedTree2 :: Tree Fail+ hashedTree1 = unFail $ darcsUpdateHashes $ repoTree repo1+ hashedTree2 = unFail $ darcsUpdateHashes $ repoTree repo2+++----------------------------------------------------------------------+-- * Patch application++----------------------------------------------------------------------+-- * QuickCheck generators++-- Testing code assumes that aFilename and aDirname generators+-- will always be able to generate a unique name given a list of+-- existing names. This should be OK as long as the number of possible+-- file/dirnames is much bigger than the number of files/dirs per repository.++-- 'Arbitrary' 'V1Model' instance is based on the 'aSmallRepo' generator.+++-- | Files are distinguish by ending their names with ".txt".+aFilename :: Gen Name+aFilename = do len <- choose (1,maxLength)+ name <- vectorOf len alpha+ return $ makeName (name ++ ".txt")+ where+ maxLength = 3++aDirname :: Gen Name+aDirname = do len <- choose (1,maxLength)+ name <- vectorOf len alpha+ return $ makeName name+ where+ maxLength = 3++aWord :: Gen B.ByteString+aWord = do c <- alpha+ return $ BC.pack[c]++aLine :: Gen B.ByteString+aLine = do wordsNo <- choose (1,2)+ ws <- vectorOf wordsNo aWord+ return $ BC.unwords ws++aContent :: Gen Content+aContent = bSized 0 0.5 80 $ \k ->+ do n <- choose (0,k)+ vectorOf n aLine++aFile :: Gen File+aFile = makeFile <$> aContent++-- | See 'aRepo', the same applies for 'aDir'.+aDir :: Int -- ^ Maximum number of files+ -> Int -- ^ Maximum number of directories+ -> Gen Dir+aDir filesL dirL = root <$> aRepo filesL dirL++-- | @aRepo filesNo dirsNo@ produces repositories with *at most*+-- @filesNo@ files and @dirsNo@ directories.+-- The structure of the repository is aleatory.+aRepo :: Int -- ^ Maximum number of files+ -> Int -- ^ Maximum number of directories+ -> Gen (V1Model wX)+aRepo maxFiles maxDirs+ = do let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0+ filesNo <- choose (minFiles,maxFiles)+ let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0+ dirsNo <- choose (minDirs,maxDirs)+ -- NB: Thanks to laziness we don't need to care about division by zero+ -- since if dirsNo == 0 then neither filesPerDirL nor subdirsPerDirL will+ -- be evaluated.+ let filesPerDirL = (maxFiles-filesNo) `div` dirsNo+ subdirsPerDirL = (maxDirs-dirsNo) `div` dirsNo+ files <- vectorOf filesNo aFile+ filenames <- uniques filesNo aFilename+ dirs <- vectorOf dirsNo (aDir filesPerDirL subdirsPerDirL)+ dirnames <- uniques dirsNo aDirname+ return $ makeRepo (filenames `zip` files ++ dirnames `zip` dirs)++-- | Generate small repositories.+-- Small repositories help generating (potentially) conflicting patches.+instance RepoModel V1Model where+ type RepoState V1Model = Tree+ showModel m = show m+ aSmallRepo = do filesNo <- frequency [(3, return 1), (1, return 2)]+ dirsNo <- frequency [(3, return 1), (1, return 0)]+ aRepo filesNo dirsNo+ repoApply (V1Model tree) patch = V1Model <$> applyToTree patch tree+ eqModel repo1 repo2 = let (diff1,diff2) = diffRepos repo1 repo2+ in nullRepo diff1 && nullRepo diff2+++instance Arbitrary (Sealed V1Model) where+ arbitrary = seal <$> aSmallRepo
+ harness/Darcs/Test/Patch/V3Model.hs view
@@ -0,0 +1,215 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports -fno-warn-orphans #-}+{-# LANGUAGE CPP, OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-}+++-- | Repository model+module Darcs.Test.Patch.V3Model+ ( module Storage.Hashed.AnchoredPath+ , V3Model+ , Object(..)+ , repoApply+ , emptyFile+ , emptyDir+ , nullRepo+ , isEmpty+ , root, repoObjects+ , aFilename, aDirname+ , aLine, aContent+ , aFile, aDir+ , aRepo+ , anUUID+ ) where+++import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized )+import Darcs.Test.Patch.RepoModel++import Darcs.Patch.Apply( Apply(..), applyToState )+import Darcs.Patch.ApplyMonad( ApplyMonad(..) )+import Darcs.Patch.Prim.V3.Core( UUID(..), Hunk(..), Prim(..), Object(..) )+import Darcs.Patch.Prim.V3.Apply( ObjectMap(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed, seal )+import Darcs.Patch.Witnesses.Show++import Storage.Hashed.AnchoredPath+import Storage.Hashed.Tree( Tree, TreeItem )+import Storage.Hashed.Darcs ( darcsUpdateHashes )+import Storage.Hashed.Hash( Hash(..) )+import qualified Storage.Hashed.Tree as T++import Control.Applicative ( (<$>) )+import Control.Arrow ( second )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import Data.List ( intercalate, sort )+import qualified Data.Map as M+import Test.QuickCheck+ ( Arbitrary(..)+ , Gen, choose, vectorOf, frequency, oneof )++#include "impossible.h"+++----------------------------------------------------------------------+-- * Model definition++newtype V3Model wX = V3Model { repoMap :: ObjectMap Fail }++----------------------------------------+-- Instances++instance Show (Object Fail) where+ show (Directory l) = show l+ show (Blob c _) = show c++deriving instance Eq (Object Fail)++instance Show (V3Model x) where+ show = showModel++instance Show1 V3Model where+ showDict1 = ShowDictClass++----------------------------------------------------------------------+-- * Constructors++objectMap :: (Monad m) => M.Map UUID (Object m) -> ObjectMap m+objectMap map = ObjectMap { getObject = get, putObject = put, listObjects = list }+ where list = return $ M.keys map+ put k o = return $ objectMap (M.insert k o map)+ get k = return $ M.lookup k map++emptyRepo :: V3Model wX+emptyRepo = V3Model (objectMap M.empty)++emptyFile :: (Monad m) => Object m+emptyFile = Blob (return BS.empty) NoHash++emptyDir :: Object m+emptyDir = Directory M.empty++----------------------------------------------------------------------+-- * Queries++nullRepo :: V3Model wX -> Bool+nullRepo = null . repoObjects++-- | @isEmpty file@ <=> file content is empty+-- @isEmpty dir@ <=> dir has no child+isEmpty :: Object Fail -> Bool+isEmpty (Directory d) = M.null d+isEmpty (Blob f _) = BS.null $ unFail f++-- | The root directory of a repository.+root :: V3Model wX -> Object Fail+root (V3Model repo) = fromJust $ unFail $ getObject repo (UUID "ROOT")++repoObjects :: V3Model wX -> [(UUID, Object Fail)]+repoObjects (V3Model repo) = [ (id, obj id) |+ id <- unFail $ listObjects repo, not $ isEmpty $ obj id ]+ where obj id = fromJust $ unFail $ getObject repo id++----------------------------------------------------------------------+-- * Comparing repositories++----------------------------------------------------------------------+-- * QuickCheck generators++-- Testing code assumes that aFilename and aDirname generators +-- will always be able to generate a unique name given a list of+-- existing names. This should be OK as long as the number of possible+-- file/dirnames is much bigger than the number of files/dirs per repository.++-- 'Arbitrary' 'V3Model' instance is based on the 'aSmallRepo' generator.+++-- | Files are distinguish by ending their names with ".txt".+aFilename :: Gen BS.ByteString+aFilename = do len <- choose (1,maxLength)+ name <- vectorOf len alpha+ return $ BC.pack $ name ++ ".txt"+ where+ maxLength = 3++aDirname :: Gen BS.ByteString+aDirname = do len <- choose (1,maxLength)+ BC.pack <$> vectorOf len alpha+ where+ maxLength = 3++aWord :: Gen BS.ByteString+aWord = do c <- alpha+ return $ BC.pack[c]++aLine :: Gen BS.ByteString+aLine = do wordsNo <- choose (1,2)+ ws <- vectorOf wordsNo aWord+ return $ BC.unwords ws++aContent :: Gen BS.ByteString+aContent = bSized 0 0.5 80 $ \k ->+ do n <- choose (0,k)+ BC.intercalate "\n" <$> vectorOf n aLine++aFile :: (Monad m) => Gen (Object m)+aFile = aContent >>= \c -> return $ Blob (return c) NoHash++aDir :: (Monad m) => [UUID] -> [UUID] -> Gen [(UUID, Object m)]+aDir [] _ = return []+aDir (dirid:dirids) fileids =+ do dirsplit <- choose (1, length dirids)+ filesplit <- choose (1, length fileids)+ let ids = take filesplit fileids+ rem = drop filesplit fileids+ files <- vectorOf filesplit aFile+ names <- vectorOf filesplit aFilename+ dirnames <- vectorOf dirsplit aDirname+ dirs <- subdirs (take dirsplit dirids)+ (drop dirsplit dirids)+ (drop filesplit fileids)+ return $ (dirid, Directory $ M.fromList $ names `zip` ids ++ dirnames `zip` dirids)+ : (fileids `zip` files) ++ dirs+ where subdirs [] _ _ = return []+ subdirs tomake dirs files = do+ dirsplit <- choose (1, length dirs)+ filesplit <- choose (1, length files)+ dir <- aDir (head tomake : take dirsplit dirs) (take filesplit files)+ rem <- subdirs (tail tomake) (drop dirsplit dirs) (drop filesplit files)+ return $ dir ++ rem+++anUUID :: Gen UUID+anUUID = UUID . BC.pack <$> vectorOf 32 (oneof $ map return "0123456789")++-- | @aRepo filesNo dirsNo@ produces repositories with *at most* +-- @filesNo@ files and @dirsNo@ directories. +-- The structure of the repository is aleatory.+aRepo :: Int -- ^ Maximum number of files+ -> Int -- ^ Maximum number of directories+ -> Gen (V3Model wX)+aRepo maxFiles maxDirs+ = do let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0+ filesNo <- choose (minFiles,maxFiles)+ let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0+ dirsNo <- choose (minDirs,maxDirs)+ dirids <- (UUID "ROOT":) <$> uniques dirsNo anUUID+ fileids <- uniques filesNo anUUID+ objectmap <- aDir dirids fileids+ return $ V3Model $ objectMap $ M.fromList objectmap++-- | Generate small repositories.+-- Small repositories help generating (potentially) conflicting patches.+instance RepoModel V3Model where+ type RepoState V3Model = ObjectMap+ aSmallRepo = do filesNo <- frequency [(3, return 1), (1, return 2)]+ dirsNo <- frequency [(3, return 1), (1, return 0)]+ aRepo filesNo dirsNo+ repoApply (V3Model state) patch = V3Model <$> applyToState patch state+ showModel model = "V3Model{\n" ++ unlines (map entry $ repoObjects model) ++ "}"+ where entry (id, obj) = show id ++ " -> " ++ show obj+ eqModel r1 r2 = repoObjects r1 == repoObjects r2++instance Arbitrary (Sealed V3Model) where+ arbitrary = seal <$> aSmallRepo
+ harness/Darcs/Test/Patch/WSub.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}+module Darcs.Test.Patch.WSub where++{-+The Examples.Set2Unwitnessed module builds a lot of test cases by pattern matching+on the results of merge/commute in where clauses. This would+be very painful to switch to using witnesses properly, because+we'd have to make them use case in series.++So instead we give up on witnesses for this module, but instead+of preprocessor hacks which make incompatible code with the rest+of darcs, we build a fresh set of witnesses constructors (FL etc)+which aren't actually GADTs or existentials. So the pattern matching+works as before, but we need to translate back and forth a lot.++We call the normal darcs constructors the 'W' variants.+-}++import qualified Darcs.Test.Patch.Arbitrary.Generic as W+ ( getPairs, getTriples )++import qualified Darcs.Patch as W ( commute )+import qualified Darcs.Patch.Merge as W ( merge, mergeFL )+import qualified Darcs.Patch.Prim as W ( coalesce )++import qualified Darcs.Patch.Witnesses.Ordered as W+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart, unsafeCoercePEnd )++import Darcs.Patch.Merge ( Merge )+import Darcs.Patch.Prim.V1 ( Prim )+import Darcs.Patch.V2 ( RealPatch )+import Darcs.Patch.Patchy ( Commute, Invert(..) )+++infixr 5 :>:+infixr 5 +>++infixr 1 :>+infix 1 :/\:+infix 1 :\/:++data FL p wX wY where+ NilFL :: FL p wX wY+ (:>:) :: p wX wY -> FL p wX wY -> FL p wX wY++(+>+) :: FL p wX wY -> FL p wX wY -> FL p wX wY+NilFL +>+ ps = ps+(p :>: ps) +>+ qs = p :>: (ps +>+ qs)++data (p :> q) wX wY where+ (:>) :: p wX wY -> q wX wY -> (p :> q) wX wY++data (p :\/: q) wX wY where+ (:\/:) :: p wX wY -> q wX wY -> (p :\/: q) wX wY++data (p :/\: q) wX wY where+ (:/\:) :: p wX wY -> q wX wY -> (p :/\: q) wX wY++class WSub wp p | p -> wp, wp -> p where+ fromW :: wp wX wY -> p wX wY+ toW :: p wX wY -> wp wX wY++instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:\/: wp2) (p1 :\/: p2) where+ fromW (x W.:\/: y) = unsafeCoerceP (fromW x) :\/: unsafeCoerceP (fromW y)+ toW (x :\/: y) = unsafeCoerceP (toW x) W.:\/: unsafeCoerceP (toW y)++instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:/\: wp2) (p1 :/\: p2) where+ fromW (x W.:/\: y) = unsafeCoerceP (fromW x) :/\: unsafeCoerceP (fromW y)+ toW (x :/\: y) = unsafeCoerceP (toW x) W.:/\: unsafeCoerceP (toW y)++instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:> wp2) (p1 :> p2) where+ fromW (x W.:> y) = unsafeCoercePEnd (fromW x) :> unsafeCoercePStart (fromW y)+ toW (x :> y) = unsafeCoercePEnd (toW x) W.:> unsafeCoercePStart (toW y)++instance WSub wp p => WSub (W.FL wp) (FL p) where+ fromW W.NilFL = unsafeCoerceP NilFL+ fromW (x W.:>: xs) = unsafeCoercePEnd (fromW x) :>: unsafeCoercePStart (fromW xs)++ toW NilFL = unsafeCoerceP W.NilFL+ toW (x :>: xs) = unsafeCoercePEnd (toW x) W.:>: unsafeCoercePStart (toW xs)++instance WSub prim prim => WSub (RealPatch prim) (RealPatch prim) where+ fromW = id+ toW = id++instance WSub Prim Prim where+ fromW = id+ toW = id++instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show ((p :> q) wX wY) where+ show = show . toW++instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :> q) where+ showDict2 = ShowDictClass++instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show ((p :\/: q) wX wY) where+ show = show . toW++instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :\/: q) where+ showDict2 = ShowDictClass++instance (WSub wp p, Show2 wp) => Show (FL p wX wY) where+ show = show . toW++instance (WSub wp p, Show2 wp) => Show2 (FL p) where+ showDict2 = ShowDictClass++instance (WSub wp p, Commute wp, MyEq wp) => MyEq (FL p) where+ unsafeCompare x y = unsafeCompare (toW x) (toW y)++instance (WSub wp p, Commute wp, Invert wp) => Invert (FL p) where+ invert = fromW . invert . toW++instance (WSub wp p, Commute wp) => Commute (FL p) where+ commute (xs W.:> ys) = do ys' W.:> xs' <- W.commute (toW xs W.:> toW ys)+ return (fromW ys' W.:> fromW xs')++mergeFL :: (WSub wp p, Merge wp) => (p :\/: FL p) wX wY -> (FL p :/\: p) wX wY+mergeFL = fromW . W.mergeFL . toW++merge :: (WSub wp p, Merge wp) => (p :\/: p) wX wY -> (p :/\: p) wX wY+merge = fromW . W.merge . toW++commute :: (WSub wp p, Commute wp) => (p :> p) wX wY -> Maybe ((p :> p) wX wY)+commute = fmap fromW . W.commute . toW++getPairs :: FL (RealPatch Prim) wX wY -> [Sealed2 (RealPatch Prim :> RealPatch Prim)]+getPairs = map (mapSeal2 fromW) . W.getPairs . toW++getTriples :: FL (RealPatch Prim) wX wY -> [Sealed2 (RealPatch Prim :> RealPatch Prim :> RealPatch Prim)]+getTriples = map (mapSeal2 fromW) . W.getTriples . toW++coalesce :: (Prim :> Prim) wX wY -> Maybe (FL Prim wX wY)+coalesce = fmap fromW . W.coalesce . toW+
+ harness/Darcs/Test/Patch/WithState.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE CPP, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}+++module Darcs.Test.Patch.WithState+ where+++import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show+import Test.QuickCheck ( Gen, sized, choose )++++----------------------------------------------------------------------+-- * WithState++data WithState s p wX wY = WithState {+ wsStartState :: s wX+ , wsPatch :: p wX wY+ , wsEndState :: s wY+ }+ deriving Eq++instance (Show1 s, Show2 p) => Show (WithState s p wX wY) where+ showsPrec d (WithState s p s')+ = showParen (d > appPrec) $ showString "WithState "+ . showsPrec1 (appPrec+1) s+ . showString " "+ . showsPrec2 (appPrec+1) p+ . showString " "+ . showsPrec1 (appPrec+1) s'++instance (Show1 s, Show2 p) => Show2 (WithState s p) where+ showDict2 = ShowDictClass++data WithStartState s p wX = WithStartState {+ wssStartState :: s wX+ , wssPatch :: p wX+ }+ deriving Eq++instance (Show1 s, Show1 p) => Show (WithStartState s p wX) where+ showsPrec d (WithStartState s p) = showParen (d > appPrec) $ showString "WithStartState " .+ showsPrec1 (appPrec + 1) s . showString " " .+ showsPrec1 (appPrec + 1) p++instance (Show1 s, Show1 p) => Show1 (WithStartState s p) where+ showDict1 = ShowDictClass++-- | A combination of a patch and its final state. The state, in this module, is+-- typically represented by a 'RepoModel' value. The @px@ type is typically a+-- patch type applied to its pre-state, e.g. @Prim x@.+data WithEndState s px wY = WithEndState {+ wesPatch :: px wY+ , wesEndState :: s wY+ }+ deriving Eq++instance (Show1 s, Show1 p) => Show (WithEndState s p wX) where+ showsPrec d (WithEndState p s) = showParen (d > appPrec) $ showString "WithEndState " .+ showsPrec1 (appPrec + 1) p . showString " " .+ showsPrec1 (appPrec + 1) s+++instance (Show1 s, Show1 p) => Show1 (WithEndState s p) where+ showDict1 = ShowDictClass+++----------------------------------------------------------------------+-- * ArbitraryState generators++-- | A type class to generate arbitrary values, threading a state through the+-- arbitrary calls. So this can be used to generate a patch that comes after+-- another patch. The post-state of the generated patch is hidden by the+-- 'Sealed'.+class ArbitraryState s p where+ arbitraryState :: s wX -> Gen (Sealed (WithEndState s (p wX)))+ -- does a coarbitrary make sense?+++instance ArbitraryState s p => ArbitraryState s (WithState s p) where+ arbitraryState s = do Sealed (WithEndState x s') <- arbitraryState s+ return $ seal $ WithEndState (WithState s x s') s'+++instance ArbitraryState s p => ArbitraryState s (p :> p) where+ arbitraryState s = do Sealed (WithEndState p1 s') <- arbitraryState s+ Sealed (WithEndState p2 s'') <- arbitraryState s'+ return $ seal $ WithEndState (p1 :> p2) s'' ++instance ArbitraryState s p => ArbitraryState s (p :> p :> p) where+ arbitraryState s0 = do Sealed (WithEndState p1 s1) <- arbitraryState s0+ Sealed (WithEndState p2 s2) <- arbitraryState s1+ Sealed (WithEndState p3 s3) <- arbitraryState s2+ return $ seal $ WithEndState (p1 :> p2 :> p3) s3++arbitraryFL :: ArbitraryState s p => forall wX . Int -> s wX -> Gen (Sealed (WithEndState s (FL p wX)))+arbitraryFL 0 s = return $ seal $ WithEndState NilFL s+arbitraryFL n s = do Sealed (WithEndState x s') <- arbitraryState s+ Sealed (WithEndState xs s'') <- arbitraryFL (n-1) s'+ return $ seal $ WithEndState (x :>: xs) s''++instance ArbitraryState s p => ArbitraryState s (FL p) where+ arbitraryState s = sized $ \n -> do k <- choose (0, min 2 (n `div` 5))+ arbitraryFL k s+++makeS2Gen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed2 p)+makeS2Gen stGen = do s <- stGen+ Sealed (WithEndState p _) <- arbitraryState s+ return $ seal2 p++makeSGen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed (p wX))+makeSGen stGen = do s <- stGen+ Sealed (WithEndState p _) <- arbitraryState s+ return $ seal p++makeWS2Gen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed2 (WithState s p))+makeWS2Gen stGen = do s <- stGen+ Sealed (WithEndState wsP _) <- arbitraryState s+ return $ seal2 wsP++makeWSGen :: ArbitraryState s p => Gen (s wX) -> Gen (Sealed (WithState s p wX))+makeWSGen stGen = do s <- stGen+ Sealed (WithEndState wsP _) <- arbitraryState s+ return $ seal wsP++instance (Show2 p, Show1 s) => Show1 ((WithState s p) wA) where+ showDict1 = ShowDictClass+
+ harness/Darcs/Test/Util/QuickCheck.hs view
@@ -0,0 +1,58 @@++module Darcs.Test.Util.QuickCheck+ ( upper+ , lower+ , alpha+ , notIn+ , uniques+ , maybeOf+ , bSized+ )+ where+++import Control.Applicative+import Test.QuickCheck.Gen++++-- | An uppercase alphabetic character.+upper :: Gen Char+upper = choose ('A','Z')++-- | A lowercase alphabetic character.+lower :: Gen Char+lower = choose ('a','z')++-- | An alphabetic character.+alpha :: Gen Char+alpha = oneof [upper, lower]++-- | @gen `notIn` xs@ generate a @x@ that is not in @xs@.+notIn :: Eq a => Gen a -> [a] -> Gen a+gen `notIn` xs = gen `suchThat` (`notElem` xs)++-- | @uniques k gen@ generates a list of @k@ unique values.+uniques :: Eq a => Int -> Gen a -> Gen [a]+uniques k gen = go k []+ where+ go 0 xs = return xs+ go n xs = do x <- gen `notIn` xs+ go (n-1) (x:xs)++-- | Try to arbitrarily pick some element of the list.+maybeOf :: [a] -> Gen (Maybe a)+maybeOf [] = return Nothing+maybeOf xs = Just <$> elements xs+++-- | A bounded sized combinator.+bSized :: Int -- ^ Lower bound+ -> Double -- ^ Increment+ -> Int -- ^ Upper bound+ -> (Int -> Gen a) -> Gen a+bSized low inc upp mkGen = sized $ mkGen . resize'+ where+ resize' :: Int -> Int+ resize' n = let x = fromIntegral n+ in min upp (floor(inc*x) + low)
+ harness/Darcs/Test/Util/TestResult.hs view
@@ -0,0 +1,63 @@++module Darcs.Test.Util.TestResult+ ( TestResult+ , succeeded+ , failed+ , rejected+ , (<&&>)+ , fromMaybe+ , isOk+ , isFailed+ )+ where+++import Darcs.Util.Printer ( Doc, renderString, RenderMode(..) )++import qualified Test.QuickCheck.Property as Q++++data TestResult = TestSucceeded+ | TestFailed Doc+ | TestRejected -- ^ Rejects test case+++succeeded :: TestResult+succeeded = TestSucceeded++failed :: Doc -- ^ Error message+ -> TestResult+failed = TestFailed++rejected :: TestResult+rejected = TestRejected++-- | @t <&&> s@ fails <=> t or s fails+-- @t <&&> s@ succeeds <=> none fails and some succeeds+-- @t <&&> s@ is rejected <=> both are rejected+(<&&>) :: TestResult -> TestResult -> TestResult+t@(TestFailed _) <&&> _s = t+_t <&&> s@(TestFailed _) = s+TestRejected <&&> s = s+t <&&> TestRejected = t+TestSucceeded <&&> TestSucceeded = TestSucceeded++-- | 'Nothing' is considered success whilst 'Just' is considered failure.+fromMaybe :: Maybe Doc -> TestResult+fromMaybe Nothing = succeeded+fromMaybe (Just errMsg) = failed errMsg++isFailed :: TestResult -> Bool+isFailed (TestFailed _) = True+isFailed _other = False++-- | A test is considered OK if it does not fail.+isOk :: TestResult -> Bool+isOk = not . isFailed++ -- 'Testable' instance is defined by converting 'TestResult' to 'QuickCheck.Property.Result'+instance Q.Testable TestResult where+ property TestSucceeded = Q.property Q.succeeded+ property (TestFailed errorMsg) = Q.property (Q.failed{Q.reason = renderString Encode errorMsg})+ property TestRejected = Q.property Q.rejected
+ harness/test.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE CPP, MultiParamTypeClasses, DeriveDataTypeable, ViewPatterns, OverloadedStrings, ExtendedDefaultRules #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module Main ( main ) where++#ifdef DISABLE_TESTING+main :: IO ()+main = fail $ "test infrastructure not built,"+ ++ " please pass --enable-tests to configure, then rebuild"+#else++import qualified Darcs.Test.Misc+import qualified Darcs.Test.Patch+import qualified Darcs.Test.Email++import Control.Monad ( filterM )+import Control.Exception ( SomeException )+import qualified Control.Monad.Trans+import Data.Text ( Text, pack, unpack )+import Data.Char ( toLower )+import Data.List ( isPrefixOf, isSuffixOf, sort )+import Data.List.Split ( splitOn )+import qualified Data.ByteString.Char8 as B+import Data.Maybe ( fromMaybe )+import GHC.IO.Encoding ( textEncodingName )+import System.Console.CmdArgs hiding ( args )+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, localeEncoding )+import Test.Framework.Providers.API+import Test.Framework+import Shelly hiding ( liftIO, run, FilePath, path )+import qualified Shelly++doUnit :: IO [Test]+doUnit = return unitTests++-- | This is the big list of tests that will be run using testrunner.+unitTests :: [Test]+unitTests =+ [ Darcs.Test.Email.testSuite+ , Darcs.Test.Misc.testSuite+ ] ++ Darcs.Test.Patch.testSuite++-- ----------------------------------------------------------------------+-- shell tests+-- ----------------------------------------------------------------------++data Format = Darcs1 | Darcs2 deriving (Show, Eq, Typeable, Data)+data DiffAlgorithm = MyersDiff | PatienceDiff deriving (Show, Eq, Typeable, Data)+data Running = Running deriving Show+data Result = Success | Skipped | Failed String++instance Show Result where+ show Success = "Success"+ show Skipped = "Skipped"+ show (Failed f) = unlines (map ("| " ++) $ lines f)++instance TestResultlike Running Result where+ testSucceeded Success = True+ testSucceeded Skipped = True+ testSucceeded _ = False++data ShellTest = ShellTest { format :: Format+ , testfile :: FilePath+ , testdir :: Maybe FilePath -- ^ only if you want to set it explicitly+ , _darcspath :: FilePath+ , _diffalgorithm :: DiffAlgorithm+ }+ deriving Typeable++runtest' :: ShellTest -> Text -> Sh Result+runtest' (ShellTest fmt _ _ dp da) srcdir =+ do wd <- toTextIgnore <$> pwd+ setenv "HOME" wd+ setenv "TESTDATA" (toTextIgnore (srcdir </> "tests" </> "data"))+ setenv "TESTBIN" (toTextIgnore (srcdir </> "tests" </> "bin"))+ setenv "DARCS_TESTING_PREFS_DIR" $ toTextIgnore $ wd </> ".darcs"+ setenv "EMAIL" "tester"+ setenv "DARCS_DONT_COLOR" "1"+ setenv "DARCS_DONT_ESCAPE_ANYTHING" "1"+ p <- get_env_text "PATH"+ setenv "PATH" (pack (takeDirectory dp ++ pathVarSeparator ++ unpack p))+ setenv "DARCS" $ pack dp+ setenv "GHC_VERSION" $ pack $ show (__GLASGOW_HASKELL__ :: Int)+ mkdir ".darcs"+ writefile ".darcs/defaults" defaults+ _ <- Shelly.run "bash" [ "test" ]+ return Success+ `catch_sh` \(_::SomeException)+ -> do code <- lastExitCode+ case code of+ 200 -> return Skipped+ _ -> Failed <$> unpack <$> lastStderr+ where defaults = pack $ unlines (["ALL " ++ fmtstr, "send no-edit-description", "ALL ignore-times"] ++ dcs)+ fmtstr = case fmt of+ Darcs2 -> "darcs-2"+ Darcs1 -> "darcs-1"+ dcs = [dc ++ " " ++ daf | dc <- ["revert","unrevert", "whatsnew",+ "record", "unpull", "obliterate",+ "amend-record", "mark-conflicts",+ "rebase", "pull", "repair",+ "rollback", "apply",+ "rebase pull", "rebase suspend",+ "rebase unsuspend", "rebase obliterate"] ]+ daf = case da of+ PatienceDiff -> "patience"+ MyersDiff -> "myers"++#ifdef WIN32+ pathVarSeparator = ";"+#else+ pathVarSeparator = ":"+#endif++-- TODO: add a 'all' option (implement using an Enum instance)?+readOptionList :: (String -> a) -> (String -> [a])+readOptionList readElem str = map readElem (splitOn "," str)++readDiffAlgorithm :: String -> DiffAlgorithm+readDiffAlgorithm (map toLower -> "myers") = MyersDiff+readDiffAlgorithm (map toLower -> "patience") = PatienceDiff+readDiffAlgorithm _ = error "Valid diff algorithms: myers, patience"++readRepoFormat :: String -> Format+readRepoFormat (map toLower -> "darcs-1") = Darcs1+readRepoFormat (map toLower -> "darcs-2") = Darcs2+readRepoFormat _ = error "Valid repo formats: darcs-1, darcs-2"++runtest :: ShellTest -> Sh Result+runtest t =+ withTmp $ \dir -> do+ cp "tests/lib" dir+ cp ("tests" </> testfile t) (dir </> "test")+ srcdir <- pwd+ silently $ sub $ cd dir >> runtest' t (toTextIgnore srcdir)+ where+ withTmp =+ case testdir t of+ Just dir -> \job -> do+ let d = (dir </> show (format t) </> takeBaseName (testfile t))+ mkdir_p d+ job d+ Nothing -> withTmpDir++instance Testlike Running Result ShellTest where+ testTypeName _ = "Shell"+ runTest _ test = runImprovingIO $ do yieldImprovement Running+ liftIO (shelly $ runtest test)++shellTest :: FilePath -> Format -> Maybe FilePath -> String -> DiffAlgorithm -> Test+shellTest dp fmt tdir file da = Test (file ++ " (" ++ show fmt ++ ")" ++ " (" ++ show da ++ ")") $ ShellTest fmt file tdir dp da++hasPrefix :: B.ByteString -> B.ByteString -> Maybe B.ByteString+hasPrefix prefix =+ let len = B.length prefix in+ \str -> if B.take len str == prefix then Just (B.drop len str) else Nothing++toString :: Shelly.FilePath -> String+toString = unpack . toTextIgnore++-- use of a pragma in a test script overrides the user's selection for that particular test,+-- based on the assumption that the test author knows best+parsePragmas :: FilePath -> FilePath -> IO (FilePath, (Maybe [DiffAlgorithm], Maybe [Format]))+parsePragmas path file = do+ contents <- B.lines <$> B.readFile (toString $ path </> file)+ let parseLine+ (_diffAlgorithms, repoFormats)+ (hasPrefix (B.pack "#pragma diff-algorithm ") -> Just (readOptionList readDiffAlgorithm . B.unpack -> newDiffAlgorithms))+ = (Just newDiffAlgorithms, repoFormats)+ parseLine+ (diffAlgorithms, _repoFormats)+ (hasPrefix (B.pack "#pragma repo-format ") -> Just (readOptionList readRepoFormat . B.unpack -> newRepoFormats))+ = (diffAlgorithms, Just newRepoFormats)+ parseLine _ (hasPrefix (B.pack "#pragma ") -> Just pragma) = error $ "Unknown pragma " ++ B.unpack pragma ++ " in " ++ (toString $ path </> file)+ parseLine x _ = x+ pragmas = foldl parseLine (Nothing, Nothing) contents+ return (file, pragmas)++findShell :: FilePath -> Maybe FilePath -> Bool -> [DiffAlgorithm] -> [Format] -> Sh [Test]+findShell dp tdir isFailing diffAlgorithmsDefault repoFormatsDefault =+ do allFiles <- map (drop (length ("tests/"::String)) . toString) <$> ls (fromText "tests")+ let files = sort $ filter relevant $ filter (".sh" `isSuffixOf`) allFiles+ annotatedFiles <- Control.Monad.Trans.liftIO $ mapM (parsePragmas "tests") files+ return [ shellTest dp fmt tdir file da+ | (file, (diffAlgorithmsPragma, repoFormatsPragma)) <- annotatedFiles+ , fmt <- fromMaybe repoFormatsDefault repoFormatsPragma+ , da <- fromMaybe diffAlgorithmsDefault diffAlgorithmsPragma ]+ where relevant = (if isFailing then id else not) . ("failing-" `isPrefixOf`)++findNetwork :: FilePath -> Maybe FilePath -> [DiffAlgorithm] -> [Format] -> Sh [Test]+findNetwork dp tdir diffAlgorithmsDefault repoFormatsDefault =+ do files <- sort <$> filter (".sh" `isSuffixOf`) <$> map (drop (length ("tests/network/"::String)) . toString) <$> ls "tests/network"+ annotatedFiles <- Control.Monad.Trans.liftIO $ mapM (parsePragmas "tests/network") files+ return [ shellTest dp fmt tdir (toString $ "network" </> file) da+ | (file, (diffAlgorithmsPragma, repoFormatsPragma)) <- annotatedFiles+ , fmt <- fromMaybe repoFormatsDefault repoFormatsPragma+ , da <- fromMaybe diffAlgorithmsDefault diffAlgorithmsPragma ]++-- ----------------------------------------------------------------------+-- harness+-- ----------------------------------------------------------------------++data Config = Config { failing :: Bool+ , shell :: Bool+ , network :: Bool+ , unit :: Bool+ , diffAlgorithm :: [DiffAlgorithm]+ , repoFormat :: [Format]+ , darcs :: String+ , tests :: [String]+ , testDir :: Maybe FilePath+ , plain :: Bool+ , hideSuccesses :: Bool+ , threads :: Int }+ deriving (Data, Typeable, Eq)+++defaultConfig :: Annotate Ann+defaultConfig+ = record Config{}+ [ failing := False += help "Run the failing (shell) tests."+ , shell := True += help "Run the passing, non-network shell tests."+ , network := False += help "Run the network shell tests."+ , unit := True += help "Run the unit tests."+ , diffAlgorithm := [PatienceDiff] += help "Diff algorithm(s) to test (myers, patience)."+ , repoFormat := [Darcs2] += help "Repo formats to test (darcs-1, darcs-2)."+ , darcs := "" += help "Darcs binary path." += typ "PATH"+ , tests := [] += name "t" += help "Pattern to limit the tests to run." += typ "PATTERN"+ , testDir := Nothing += help "Directory to run tests in" += typ "PATH"+ , plain := False += help "Use plain-text output."+ , hideSuccesses := False += help "Hide successes."+ , threads := 1 += name "j" ]++run :: Config -> IO ()+run conf = do+ let args = [ "-j", show $ threads conf ]+ ++ concat [ ["-t", x ] | x <- tests conf ]+ ++ [ "--plain" | True <- [plain conf] ]+ ++ [ "--hide-successes" | True <- [hideSuccesses conf] ]+ ++ [ "--maximum-unsuitable-generated-tests", "700" ]+ case testDir conf of+ Nothing -> return ()+ Just d -> do e <- shelly (test_e (fromText $ pack 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 (map toString 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+ unless (isAbsolute $ darcsBin) $+ fail ("Argument to --darcs should be an absolute path")+ unless (exeSuffix `isSuffixOf` darcsBin) $+ putStrLn $ "Warning: --darcs flag does not end with " ++ exeSuffix ++ " - some tests may fail (case does matter)"++ putStrLn $ "Locale encoding is " ++ textEncodingName localeEncoding++ ftests <- shelly $ if failing conf then findShell darcsBin (testDir conf) True (diffAlgorithm conf) (repoFormat conf) else return []+ stests <- shelly $ if shell conf then findShell darcsBin (testDir conf) False (diffAlgorithm conf) (repoFormat conf) else return []+ utests <- if unit conf then doUnit else return []+ ntests <- shelly $ if network conf then findNetwork darcsBin (testDir conf) (diffAlgorithm conf) (repoFormat conf) else return []+ defaultMainWithArgs (ftests ++ stests ++ utests ++ ntests) args+ where+ exeSuffix :: String+#ifdef WIN32+ exeSuffix = ".exe"+#else+ exeSuffix = ""+#endif++main :: IO ()+main = do hSetBinaryMode stdout True+ hSetBuffering stdout NoBuffering+ hSetBinaryMode stderr True+ hSetBinaryMode stdin True+ clp <- cmdArgs_ defaultConfig+ run clp++#endif
+ hashed-storage/Bundled/Posix.hsc view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP, RankNTypes #-}++module Bundled.Posix( getFdStatus, getSymbolicLinkStatus, getFileStatus+ , getFileStatusBS+ , fileExists+ , modificationTime, fileSize, FileStatus+ , EpochTime, isDirectory, isRegularFile ) where++import qualified Data.ByteString.Char8 as BS+#if mingw32_HOST_OS+#else+import Data.ByteString.Unsafe( unsafeUseAsCString )+#endif+import Foreign.Marshal.Alloc ( allocaBytes )+import Foreign.C.Error ( throwErrno, getErrno, eNOENT )+import Foreign.C.Types ( CTime, CInt )+import Foreign.Ptr ( Ptr )++import System.Posix.Internals+ ( CStat, c_fstat, sizeof_stat+ , st_mode, st_size, st_mtime, s_isdir, s_isreg )+#if mingw32_HOST_OS+import System.Posix.Internals ( c_stat, CFilePath )+#endif++import System.Posix.Types ( Fd(..), CMode, EpochTime )++#if mingw32_HOST_OS+import Foreign.C.String( withCWString, CWString )+#else+import Foreign.C.String ( withCString, CString )+#endif++#if mingw32_HOST_OS+import Data.Int ( Int64 )++type FileOffset = Int64+lstat :: CFilePath -> Ptr CStat -> IO CInt+lstat = c_stat+#else+import System.Posix.Types ( FileOffset )+import System.Posix.Internals( lstat )+#endif++#if mingw32_HOST_OS+bsToPath :: forall a. BS.ByteString -> (CWString -> IO a) -> IO a+bsToPath s f = withCWString (BS.unpack s) f+strToPath :: forall a. String -> (CWString -> IO a) -> IO a+strToPath = withCWString+#else+bsToPath :: forall a. BS.ByteString -> (CString -> IO a) -> IO a+bsToPath = unsafeUseAsCString+strToPath :: forall a. String -> (CString -> IO a) -> IO a+strToPath = withCString+#endif++data FileStatus = FileStatus {+ fst_exists :: !Bool,+ fst_mode :: !CMode,+ fst_mtime :: !CTime,+ fst_size :: !FileOffset+ }++getFdStatus :: Fd -> IO FileStatus+getFdStatus (Fd fd) = do+ do_stat (c_fstat fd)++do_stat :: (Ptr CStat -> IO CInt) -> IO FileStatus+do_stat stat_func = do+ allocaBytes sizeof_stat $! \p -> do+ ret <- stat_func p+ if (ret == -1) then do err <- getErrno+ if (err == eNOENT)+ then return $! (FileStatus False 0 0 0)+ else throwErrno "do_stat"+ else do mode <- st_mode p+ mtime <- st_mtime p+ size <- st_size p+ return $! FileStatus True mode mtime size+{-# INLINE do_stat #-}++isDirectory :: FileStatus -> Bool+isDirectory = s_isdir . fst_mode++isRegularFile :: FileStatus -> Bool+isRegularFile = s_isreg . fst_mode++modificationTime :: FileStatus -> EpochTime+modificationTime = fst_mtime++fileSize :: FileStatus -> FileOffset+fileSize = fst_size++fileExists :: FileStatus -> Bool+fileExists = fst_exists++#include <sys/stat.h>++-- lstat is broken on win32 with at least GHC 6.10.3+getSymbolicLinkStatus :: FilePath -> IO FileStatus+##if mingw32_HOST_OS+getSymbolicLinkStatus = getFileStatus+##else+getSymbolicLinkStatus fp =+ do_stat (\p -> (fp `strToPath` (`lstat` p)))+##endif++getFileStatus :: FilePath -> IO FileStatus+getFileStatus fp =+ do_stat (\p -> (fp `strToPath` (`lstat` p)))++-- | Requires NULL-terminated bytestring -> unsafe! Use with care.+getFileStatusBS :: BS.ByteString -> IO FileStatus+getFileStatusBS fp =+ do_stat (\p -> (fp `bsToPath` (`lstat` p)))+{-# INLINE getFileStatusBS #-}
+ hashed-storage/LICENSE view
@@ -0,0 +1,26 @@+Copyright Petr Rockai, Jose Neder 2009-2013++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions 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 COPYRIGHT HOLDERS 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 COPYRIGHT+OWNER OR 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.
+ hashed-storage/Storage/Hashed.hs view
@@ -0,0 +1,51 @@+module Storage.Hashed+ ( -- * Obtaining Trees.+ --+ -- | Please note that Trees obtained this way will contain Stub+ -- items. These need to be executed (they are IO actions) in order to be+ -- accessed. Use 'expand' to do this. However, many operations are+ -- perfectly fine to be used on a stubbed Tree (and it is often more+ -- efficient to do everything that can be done before expanding a Tree).+ readPlainTree, readDarcsHashed++ -- * Blob access.+ , readBlob++ -- * Writing trees.+ , writePlainTree, writeDarcsHashed++ -- * Unsafe functions for the curious explorer.+ --+ -- | These are more useful for playing within ghci than for real, serious+ -- programs. They generally trade safety for conciseness. Please use+ -- responsibly. Don't kill innocent kittens.+ , floatPath, printPath ) where++import Storage.Hashed.AnchoredPath+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BL+import Storage.Hashed.Tree ( Tree, TreeItem(..), listImmediate, find, readBlob )++-- For re-exports.+import Storage.Hashed.Darcs( readDarcsHashed, writeDarcsHashed )+import Storage.Hashed.Plain( readPlainTree, writePlainTree )++------------------------+-- For explorers+--++-- | Take a relative FilePath within a Tree and print the contents of the+-- object there. Useful for exploration, less so for serious programming.+printPath :: Tree IO -> FilePath -> IO ()+printPath t p = print' $ find t (floatPath p)+ where print' Nothing = putStrLn $ "ERROR: No object at " ++ p+ print' (Just (File b)) = do+ putStrLn $ "== Contents of file " ++ p ++ ":"+ BL.unpack `fmap` readBlob b >>= putStr+ print' (Just (SubTree t')) = do+ putStrLn $ "== Listing Tree " ++ p ++ " (immediates only):"+ putStr $ unlines $ map BS.unpack $ listNames t'+ print' (Just (Stub _ _)) =+ putStrLn $ "== (not listing stub at " ++ p ++ ")"+ listNames t' = [ n | (Name n, _) <- listImmediate t' ]+
+ hashed-storage/Storage/Hashed/AnchoredPath.hs view
@@ -0,0 +1,110 @@+-- | This module implements relative paths within a Tree. All paths are+-- anchored at a certain root (this is usually the Tree root). They are+-- represented by a list of Names (these are just strict bytestrings).+module Storage.Hashed.AnchoredPath+ ( Name(..), AnchoredPath(..), anchoredRoot, appendPath, anchorPath+ , isPrefix, parent, parents, catPaths, flatten, makeName, appendToName+ -- * Unsafe functions.+ , floatBS, floatPath, replacePrefixPath ) where++import qualified Data.ByteString.Char8 as BS+import Data.List( isPrefixOf, inits )+import System.FilePath( (</>), splitDirectories, normalise, dropTrailingPathSeparator )++-------------------------------+-- AnchoredPath utilities+--++newtype Name = Name BS.ByteString deriving (Eq, Show, Ord)++-- | This is a type of "sane" file paths. These are always canonic in the sense+-- that there are no stray slashes, no ".." components and similar. They are+-- usually used to refer to a location within a Tree, but a relative filesystem+-- path works just as well. These are either constructed from individual name+-- components (using "appendPath", "catPaths" and "makeName"), or converted+-- from a FilePath ("floatPath" -- but take care when doing that) or .+newtype AnchoredPath = AnchoredPath [Name] deriving (Eq, Show, Ord)++-- | Check whether a path is a prefix of another path.+isPrefix :: AnchoredPath -> AnchoredPath -> Bool+(AnchoredPath a) `isPrefix` (AnchoredPath b) = a `isPrefixOf` b++-- | Append an element to the end of a path.+appendPath :: AnchoredPath -> Name -> AnchoredPath+appendPath (AnchoredPath p) n =+ case n of+ (Name s) | s == BS.empty -> AnchoredPath p+ | s == BS.pack "." -> AnchoredPath p+ | otherwise -> AnchoredPath $ p ++ [n]++-- | Catenate two paths together. Not very safe, but sometimes useful+-- (e.g. when you are representing paths relative to a different point than a+-- Tree root).+catPaths :: AnchoredPath -> AnchoredPath -> AnchoredPath+catPaths (AnchoredPath p) (AnchoredPath n) = AnchoredPath $ p ++ n++-- | Get parent (path) of a given path. foo/bar/baz -> foo/bar+parent :: AnchoredPath -> AnchoredPath+parent (AnchoredPath x) = AnchoredPath (init x)++-- | List all parents of a given path. foo/bar/baz -> [foo, foo/bar]+parents :: AnchoredPath -> [AnchoredPath]+parents (AnchoredPath x) = map AnchoredPath . init . inits $ x++-- | Take a "root" directory and an anchored path and produce a full+-- 'FilePath'. Moreover, you can use @anchorPath \"\"@ to get a relative+-- 'FilePath'.+anchorPath :: FilePath -> AnchoredPath -> FilePath+anchorPath dir p = dir </> BS.unpack (flatten p)+{-# INLINE anchorPath #-}++-- | Unsafe. Only ever use on bytestrings that came from flatten on a+-- pre-existing AnchoredPath.+floatBS :: BS.ByteString -> AnchoredPath+floatBS = AnchoredPath . map Name . takeWhile (not . BS.null) . BS.split '/'++flatten :: AnchoredPath -> BS.ByteString+flatten (AnchoredPath []) = BS.singleton '.'+flatten (AnchoredPath p) = BS.intercalate (BS.singleton '/')+ [ n | (Name n) <- p ]++makeName :: String -> Name+makeName ".." = error ".. is not a valid AnchoredPath component name"+makeName n | '/' `elem` n = error "/ may not occur in a valid AnchoredPath component name"+ | otherwise = Name $ BS.pack n++-- | Take a relative FilePath and turn it into an AnchoredPath. The operation+-- is (relatively) unsafe. Basically, by using floatPath, you are testifying+-- that the argument is a path relative to some common root -- i.e. the root of+-- the associated "Tree" object. Also, there are certain invariants about+-- AnchoredPath that this function tries hard to preserve, but probably cannot+-- guarantee (i.e. this is a best-effort thing). You should sanitize any+-- FilePaths before you declare them "good" by converting into AnchoredPath+-- (using this function).+floatPath :: FilePath -> AnchoredPath+floatPath = make . splitDirectories . normalise . dropTrailingPathSeparator+ where make ["."] = AnchoredPath []+ make x = AnchoredPath $ map (Name . BS.pack) x+++anchoredRoot :: AnchoredPath+anchoredRoot = AnchoredPath []++-- | Take a prefix path, the changed prefix path, and a path to change.+-- Assumes the prefix path is a valid prefix. If prefix is wrong return+-- AnchoredPath [].+replacePrefixPath :: AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath+replacePrefixPath (AnchoredPath []) b c = catPaths b c+replacePrefixPath (AnchoredPath (r:p)) b (AnchoredPath (r':p'))+ | r == r' = replacePrefixPath (AnchoredPath p) b (AnchoredPath p')+ | otherwise = AnchoredPath []+replacePrefixPath _ _ _ = AnchoredPath []++-- | Append a ByteString to the last Name of an AnchoredPath.+appendToName :: AnchoredPath -> String -> AnchoredPath+appendToName (AnchoredPath p) s = AnchoredPath (init p++[Name finalname])+ where suffix = BS.pack s+ finalname | suffix `elem` (BS.tails lastname) = lastname+ | otherwise = BS.append lastname suffix+ lastname = case last p of+ Name name -> name
+ hashed-storage/Storage/Hashed/Darcs.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}++-- | A few darcs-specific utility functions. These are used for reading and+-- writing darcs and darcs-compatible hashed trees.+module Storage.Hashed.Darcs where++import Prelude hiding ( lookup, catch )+import System.FilePath ( (</>) )++import System.Directory( doesFileExist )+import Codec.Compression.GZip( decompress, compress )+import Control.Applicative( (<$>) )+import Control.Exception( catch, IOException )++import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as BS++import Data.List( sortBy )+import Data.Char( chr, ord, isSpace )+import Data.Maybe( fromJust, isJust )+import Control.Monad.State.Strict++import Storage.Hashed.Tree hiding ( lookup )+import Storage.Hashed.AnchoredPath+import Storage.Hashed.Utils+import Storage.Hashed.Hash+import Storage.Hashed.Packed+import Storage.Hashed.Monad++---------------------------------------------------------------------+-- Utilities for coping with the darcs directory format.+--++-- | 'darcsDecodeWhite' interprets the Darcs-specific \"encoded\" filenames+-- produced by 'darcsEncodeWhite'+--+-- > darcsDecodeWhite "hello\32\there" == "hello there"+-- > darcsDecodeWhite "hello\92\there" == "hello\there"+-- > darcsDecodeWhite "hello\there" == error "malformed filename"+darcsDecodeWhite :: String -> FilePath+darcsDecodeWhite ('\\':cs) =+ case break (=='\\') cs of+ (theord, '\\':rest) ->+ chr (read theord) : darcsDecodeWhite rest+ _ -> error "malformed filename"+darcsDecodeWhite (c:cs) = c: darcsDecodeWhite cs+darcsDecodeWhite "" = ""++-- | 'darcsEncodeWhite' translates whitespace in filenames to a darcs-specific+-- format (backslash followed by numerical representation according to 'ord').+-- Note that backslashes are also escaped since they are used in the encoding.+--+-- > darcsEncodeWhite "hello there" == "hello\32\there"+-- > darcsEncodeWhite "hello\there" == "hello\92\there"+darcsEncodeWhite :: FilePath -> String+darcsEncodeWhite (c:cs) | isSpace c || c == '\\' =+ '\\' : (show $ ord c) ++ "\\" ++ darcsEncodeWhite cs+darcsEncodeWhite (c:cs) = c : darcsEncodeWhite cs+darcsEncodeWhite [] = []++darcsEncodeWhiteBS :: BS8.ByteString -> BS8.ByteString+darcsEncodeWhiteBS = BS8.pack . darcsEncodeWhite . BS8.unpack++decodeDarcsHash :: BS8.ByteString -> Hash+decodeDarcsHash bs = case BS8.split '-' bs of+ [s, h] | BS8.length s == 10 -> decodeBase16 h+ _ -> decodeBase16 bs++decodeDarcsSize :: BS8.ByteString -> Maybe Int+decodeDarcsSize bs = case BS8.split '-' bs of+ [s, _] | BS8.length s == 10 ->+ case reads (BS8.unpack s) of+ [(x, _)] -> Just x+ _ -> Nothing+ _ -> Nothing++darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment+darcsLocation dir (s,h) = case hash of+ "" -> error "darcsLocation: invalid hash"+ _ -> (dir </> prefix s ++ hash, Nothing)+ where prefix Nothing = ""+ prefix (Just s') = formatSize s' ++ "-"+ formatSize s' = let n = show s' in replicate (10 - length n) '0' ++ n+ hash = BS8.unpack (encodeBase16 h)++----------------------------------------------+-- Darcs directory format.+--++darcsFormatDir :: Tree m -> Maybe BL8.ByteString+darcsFormatDir t = BL8.fromChunks <$> concat <$>+ mapM string (sortBy cmp $ listImmediate t)+ where cmp (Name a, _) (Name b, _) = compare a b+ string (Name name, item) =+ do header <- case item of+ File _ -> Just $ BS8.pack "file:\n"+ _ -> Just $ BS8.pack "directory:\n"+ hash <- case itemHash item of+ NoHash -> Nothing+ x -> Just $ encodeBase16 x+ return $ [ header+ , darcsEncodeWhiteBS name+ , BS8.singleton '\n'+ , hash, BS8.singleton '\n' ]++darcsParseDir :: BL8.ByteString -> [(ItemType, Name, Maybe Int, Hash)]+darcsParseDir content = parse (BL8.split '\n' content)+ where+ parse (t:n:h':r) = (header t,+ Name $ BS8.pack $ darcsDecodeWhite (BL8.unpack n),+ decodeDarcsSize hash,+ decodeDarcsHash hash) : parse r+ where hash = BS8.concat $ BL8.toChunks h'+ parse _ = []+ header x+ | x == BL8.pack "file:" = BlobType+ | x == BL8.pack "directory:" = TreeType+ | otherwise = error $ "Error parsing darcs hashed dir: " ++ BL8.unpack x++----------------------------------------+-- Utilities.+--++-- | Compute a darcs-compatible hash value for a tree-like structure.+darcsTreeHash :: Tree m -> Hash+darcsTreeHash t = case darcsFormatDir t of+ Nothing -> NoHash+ Just x -> sha256 x++-- The following two are mostly for experimental use in Packed.++darcsUpdateDirHashes :: Tree m -> Tree m+darcsUpdateDirHashes = updateSubtrees update+ where update t = t { treeHash = darcsTreeHash t }++darcsUpdateHashes :: (Monad m, Functor m) => Tree m -> m (Tree m)+darcsUpdateHashes = updateTree update+ where update (SubTree t) = return . SubTree $ t { treeHash = darcsTreeHash t }+ update (File blob@(Blob con _)) =+ do hash <- sha256 <$> readBlob blob+ return $ File (Blob con hash)+ update stub = return stub++darcsHash :: (Monad m, Functor m) => TreeItem m -> m Hash+darcsHash (SubTree t) = return $ darcsTreeHash t+darcsHash (File blob) = sha256 <$> readBlob blob+darcsHash _ = return NoHash++darcsAddMissingHashes :: (Monad m, Functor m) => Tree m -> m (Tree m)+darcsAddMissingHashes = addMissingHashes darcsHash++-------------------------------------------+-- Reading darcs pristine data+--++-- | Read and parse a darcs-style hashed directory listing from a given @dir@+-- and with a given @hash@.+readDarcsHashedDir :: FilePath -> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]+readDarcsHashedDir dir h = do+ exist <- doesFileExist $ fst (darcsLocation dir h)+ unless exist $ fail $ "error opening " ++ fst (darcsLocation dir h)+ compressed <- readSegment $ darcsLocation dir h+ let content = decompress compressed+ return $ if BL8.null compressed+ then []+ else darcsParseDir content++-- | Read in a darcs-style hashed tree. This is mainly useful for reading+-- \"pristine.hashed\". You need to provide the root hash you are interested in+-- (found in _darcs/hashed_inventory).+readDarcsHashed' :: Bool -> FilePath -> (Maybe Int, Hash) -> IO (Tree IO)+readDarcsHashed' _ _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash"+readDarcsHashed' sizefail dir root@(_, hash) = do+ items' <- readDarcsHashedDir dir root+ subs <- sequence [+ do when (sizefail && isJust s) $+ fail ("Unexpectedly encountered size-prefixed hash in " ++ dir)+ case tp of+ BlobType -> return (d, File $+ Blob (readBlob' (s, h)) h)+ TreeType ->+ do let t = readDarcsHashed dir (s, h)+ return (d, Stub t h)+ | (tp, d, s, h) <- items' ]+ return $ makeTreeWithHash subs hash+ where readBlob' = fmap decompress . readSegment . darcsLocation dir++readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO)+readDarcsHashed = readDarcsHashed' False++readDarcsHashedNosize :: FilePath -> Hash -> IO (Tree IO)+readDarcsHashedNosize dir hash = readDarcsHashed' True dir (Nothing, hash)++----------------------------------------------------+-- Writing darcs-style hashed trees.+--++-- | Write a Tree into a darcs-style hashed directory.+writeDarcsHashed :: Tree IO -> FilePath -> IO Hash+writeDarcsHashed tree' dir =+ do t <- darcsUpdateDirHashes <$> expand tree'+ sequence_ [ dump =<< readBlob b | (_, File b) <- list t ]+ let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ]+ _ <- mapM dump $ map fromJust dirs+ return $ darcsTreeHash t+ where dump bits =+ do let name = dir </> BS8.unpack (encodeBase16 $ sha256 bits)+ exist <- doesFileExist name+ unless exist $ BL.writeFile name (compress bits)++-- | Create a hashed file from a 'FilePath' and content. In case the file exists+-- it is kept untouched and is assumed to have the right content. XXX Corrupt+-- files should be probably renamed out of the way automatically or something+-- (probably when they are being read though).+fsCreateHashedFile :: FilePath -> BL8.ByteString -> TreeIO ()+fsCreateHashedFile fn content =+ liftIO $ do+ exist <- doesFileExist fn+ unless exist $ BL.writeFile fn content++-- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed+-- to be fully available from the @directory@, and any changes will be written+-- out to same. Please note that actual filesystem files are never removed.+hashedTreeIO :: TreeIO a -- ^ action+ -> Tree IO -- ^ initial+ -> FilePath -- ^ directory+ -> IO (a, Tree IO)+hashedTreeIO action t dir =+ do runTreeMonad action $ initialState t darcsHash updateItem+ where updateItem _ (File b) = File <$> updateFile b+ updateItem _ (SubTree s) = SubTree <$> updateSub s+ updateItem _ x = return x++ updateFile b@(Blob _ !h) = do+ content <- liftIO $ readBlob b+ let fn = dir </> BS8.unpack (encodeBase16 h)+ nblob = Blob (decompress <$> rblob) h+ rblob = BL.fromChunks <$> return <$> BS.readFile fn+ newcontent = compress content+ fsCreateHashedFile fn newcontent+ return nblob+ updateSub s = do+ let !hash = treeHash s+ Just dirdata = darcsFormatDir s+ fn = dir </> BS8.unpack (encodeBase16 hash)+ fsCreateHashedFile fn (compress dirdata)+ return s++--------------------------------------------------------------+-- Reading and writing packed pristine. EXPERIMENTAL.+----++-- | Read a Tree in the darcs hashed format from an object storage. This is+-- basically the same as readDarcsHashed from Storage.Hashed, but uses an+-- object storage instead of traditional darcs filesystem layout. Requires the+-- tree root hash as a starting point.+readPackedDarcsPristine :: OS -> Hash -> IO (Tree IO)+readPackedDarcsPristine os root =+ do items' <- darcsParseDir <$> grab root+ subs <- sequence [+ case tp of+ BlobType -> return (d, File $ file h)+ TreeType -> let t = readPackedDarcsPristine os h+ in return (d, Stub t h)+ | (tp, d, _, h) <- items' ]+ return $ makeTreeWithHash subs root+ where file h = Blob (grab h) h+ grab hash = do maybeseg <- lookup os hash+ case maybeseg of+ Nothing -> fail $ "hash " ++ BS8.unpack (encodeBase16 hash) ++ " not available"+ Just seg -> readSegment seg++-- | Write a Tree into an object storage, using the darcs-style directory+-- formatting (and therefore darcs-style hashes). Gives back the object storage+-- and the root hash of the stored Tree. NB. The function expects that the Tree+-- comes equipped with darcs-style hashes already!+writePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash)+writePackedDarcsPristine tree' os =+ do t <- darcsUpdateDirHashes <$> expand tree'+ files <- sequence [ readBlob b | (_, File b) <- list t ]+ let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ]+ os' <- hatch os $ files ++ (map fromJust dirs)+ return (os', darcsTreeHash t)++storePackedDarcsPristine :: Tree IO -> OS -> IO (OS, Hash)+storePackedDarcsPristine tree' os =+ do (os', root) <- writePackedDarcsPristine tree' os+ return $ (os' { roots = root : roots os'+ -- FIXME we probably don't want to override the references+ -- thing completely here...+ , references = darcsPristineRefs }, root)++darcsPristineRefs :: FileSegment -> IO [Hash]+darcsPristineRefs fs = do+ con <- (darcsParseDir <$> readSegment fs) `catch` \(_ :: IOException) -> return []+ return $! [ hash | (_, _, _, hash) <- con, valid hash ]+ where valid NoHash = False+ valid _ = True++darcsCheckExpand :: Tree IO+ -> IO (Either [(FilePath, Hash, Maybe Hash)] (Tree IO))+darcsCheckExpand t = do+ problemsOrTree <- checkExpand darcsHash t+ case problemsOrTree of+ Left problems -> return . Left $ map render problems+ Right tree' -> return . Right $ tree'+ where+ render (path, h, h') = (anchorPath "." path, h, h')
+ hashed-storage/Storage/Hashed/Diff.hs view
@@ -0,0 +1,136 @@+module Storage.Hashed.Diff where++import Prelude hiding ( lookup, filter )+import qualified Data.ByteString.Lazy.Char8 as BL+import Storage.Hashed.Tree+import Storage.Hashed.AnchoredPath+import Data.List.LCS+import Data.List ( groupBy )++unidiff :: Tree IO -> Tree IO -> IO BL.ByteString+unidiff l r =+ do (from, to) <- diffTrees l r+ diffs <- sequence $ zipCommonFiles diff from to+ return $ BL.concat diffs+ where diff p a b = do x <- readBlob a+ y <- readBlob b+ return $ diff' p x y+ diff' p x y =+ case unifiedDiff x y of+ x' | BL.null x' -> BL.empty+ | otherwise ->+ (BL.pack $ "--- " ++ anchorPath "old" p ++ "\n" +++ "+++ " ++ anchorPath "new" p ++ "\n")+ `BL.append` x'++type Line = BL.ByteString+data WeaveLine = Common Line+ | Remove Line+ | Add Line+ | Replace Line Line+ | Skip Int deriving Show++-- | A weave -- two files woven together, with common and differing regions+-- marked up. Cf. 'WeaveLine'.+type Weave = [WeaveLine]++-- | Sort of a sub-weave.+type Hunk = [WeaveLine]++-- | Produce unified diff (in a string form, ie. formatted) from a pair of+-- bytestrings.+unifiedDiff :: BL.ByteString -> BL.ByteString -> BL.ByteString+unifiedDiff a b = printUnified $ concat unifiedHunks+ where unifiedHunks = reduceContext 3 $ map unifyHunk $ hunks $ weave a b++-- | Weave two bytestrings. Intermediate data structure for the actual unidiff+-- implementation. No skips are produced.+weave :: BL.ByteString -> BL.ByteString -> Weave+weave a' b' = weave' left common right+ where left = init' (BL.split '\n' a') -- drop trailing newline+ right = init' (BL.split '\n' b') -- drop trailing newline+ init' [] = []+ init' x = init x+ common = lcs left right+ weave' [] [] [] = []+ weave' [] c [] = error $ "oops: Left & Right empty, Common: " ++ show c+ weave' [] [] (b:bs) = Add b : weave' [] [] bs+ weave' (a:as) [] [] = Remove a : weave' as [] []+ weave' (a:as) [] (b:bs) = Replace a b : weave' as [] bs+ weave' (a:as) (c:cs) (b:bs)+ | a == c && b == c = Common a : weave' as cs bs+ | a == c && b /= c = Add b : weave' (a:as) (c:cs) bs+ | a /= c && b == c = Remove a : weave' as (c:cs) (b:bs)+ | a /= c && b /= c = Replace a b : weave' as (c:cs) bs+ | otherwise = error "oops!"+ weave' a c b = error $ "oops: \nLeft: " ++ show a ++ "\nCommon: " ++ show c ++ "\nRight: " ++ show b++-- | Break up a 'Weave' into 'Hunk's.+hunks :: Weave -> [Hunk]+hunks = groupBy grp+ where grp (Common _) (Common _) = True+ grp (Common _) _ = False+ grp _ (Common _) = False+ grp _ _ = True++-- | Reformat a 'Hunk' into a format suitable for unified diff. Replaces are+-- turned into add/remove pairs, all removals in a hunk go before all+-- adds. 'Hunk's of 'Common' lines are left intact. Produces input suitable for+-- 'reduceContext'.+unifyHunk :: Hunk -> Hunk+unifyHunk h = case h of+ (Common _:_) -> h+ _ -> reorder $ concatMap breakup h+ where reorder h' = [ Remove a | Remove a <- h' ] ++ [ Add a | Add a <- h' ]+ breakup (Replace f t) = [Remove f, Add t]+ breakup x = [x]++-- | Break up a 'Weave' into unified 'Hunk's, leaving @n@ lines of context around+-- every hunk. Consecutive 'Common' lines not used as context are replaced with+-- 'Skip's.+reduceContext :: Int -> [Hunk] -> [Hunk]+reduceContext n hs =+ case hs of+ [] -> []+ [Common _:_] -> []+ [x] -> [x]+ [h,t] -> [reduce 0 n h, reduce n 0 t]+ (h:rest) -> reduce 0 n h :+ map (reduce n n) (init rest) +++ [reduce n 0 $ last rest]+ where+ reduce s e h@(Common _:_)+ | length h <= s + e = h+ | otherwise = take s h +++ [Skip $ length h - e - s ] +++ drop (length h - e) h+ reduce _ _ h = h++-- | Format a 'Weave' for printing.+deweave :: Weave -> BL.ByteString+deweave = BL.unlines . map disp+ where disp (Common l) = BL.cons ' ' l+ disp (Remove l) = BL.cons '-' l+ disp (Add l) = BL.cons '+' l+ disp (Replace _ t) = BL.cons '!' t+ disp (Skip n) = BL.pack $ "-- skip " ++ show n ++ " lines --"++-- | Print a \"hunked\" weave in form of an unified diff. 'Hunk' boundaries are+-- marked up as 'Skip' lines. Cf. 'reduceContext'.+printUnified :: Weave -> BL.ByteString+printUnified hunked = printHunks 1 1 $ groupBy splits hunked+ where splits (Skip _) _ = False+ splits _ (Skip _) = False+ splits _ _ = True+ printHunks _ _ [] = BL.empty+ printHunks l r ([Skip n]:rest) =+ printHunks (n+l) (n+r) rest+ printHunks l r (h:rest) =+ (BL.pack $ "@@ -" ++ show l ++ "," +++ show (removals h) ++ " +" ++ show r +++ "," ++ show (adds h) ++ " @@\n")+ `BL.append` deweave h `BL.append`+ printHunks (l + removals h) (r + adds h) rest+ commons h = length [ () | (Common _) <- h ]+ adds h = commons h + length [ () | (Add _) <- h ]+ removals h = commons h + length [ () | (Remove _) <- h ]
+ hashed-storage/Storage/Hashed/Hash.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Storage.Hashed.Hash( Hash(..), encodeBase64u, decodeBase64u+ , encodeBase16, decodeBase16, sha256, rawHash+ , match ) where++import qualified Crypto.Hash.SHA256 as SHA256 ( hash )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BSI+import qualified Data.ByteString.Lazy as BL++import qualified Codec.Binary.Base64Url as B64U+import qualified Codec.Binary.Base16 as B16++import Data.Maybe( isJust, fromJust )+import Data.Char( toLower, toUpper )++import Data.Data( Data )+import Data.Typeable( Typeable )++data Hash = SHA256 !BS.ByteString+ | SHA1 !BS.ByteString+ | NoHash+ deriving (Show, Eq, Ord, Read, Typeable, Data)++base16 :: BS.ByteString -> BS.ByteString+debase16 :: BS.ByteString -> Maybe BS.ByteString+base64u :: BS.ByteString -> BS.ByteString+debase64u :: BS.ByteString -> Maybe BS.ByteString++base16 = BS.pack . map (BSI.c2w . toLower) . B16.encode . BS.unpack+base64u = BS.pack . map BSI.c2w . B64U.encode . BS.unpack+debase64u bs = case B64U.decode $ map BSI.w2c $ BS.unpack bs of+ Just s -> Just $ BS.pack s+ Nothing -> Nothing+debase16 bs = case B16.decode $ map (toUpper . BSI.w2c) $ BS.unpack bs of+ Just s -> Just $ BS.pack s+ Nothing -> Nothing++encodeBase64u :: Hash -> BS.ByteString+encodeBase64u (SHA256 bs) = base64u bs+encodeBase64u (SHA1 bs) = base64u bs+encodeBase64u NoHash = BS.empty++-- | Produce a base16 (ascii-hex) encoded string from a hash. This can be+-- turned back into a Hash (see "decodeBase16". This is a loss-less process.+encodeBase16 :: Hash -> BS.ByteString+encodeBase16 (SHA256 bs) = base16 bs+encodeBase16 (SHA1 bs) = base16 bs+encodeBase16 NoHash = BS.empty++-- | Take a base64/url-encoded string and decode it as a "Hash". If the string+-- is malformed, yields NoHash.+decodeBase64u :: BS.ByteString -> Hash+decodeBase64u bs+ | BS.length bs == 44 && isJust (debase64u bs) = SHA256 (fromJust $ debase64u bs)+ | BS.length bs == 28 && isJust (debase64u bs) = SHA1 (fromJust $ debase64u bs)+ | otherwise = NoHash++-- | Take a base16-encoded string and decode it as a "Hash". If the string is+-- malformed, yields NoHash.+decodeBase16 :: BS.ByteString -> Hash+decodeBase16 bs | BS.length bs == 64 && isJust (debase16 bs) = SHA256 (fromJust $ debase16 bs)+ | BS.length bs == 40 && isJust (debase16 bs) = SHA1 (fromJust $ debase16 bs)+ | otherwise = NoHash++-- | Compute a sha256 of a (lazy) ByteString. However, although this works+-- correctly for any bytestring, it is only efficient if the bytestring only+-- has a sigle chunk.+sha256 :: BL.ByteString -> Hash+sha256 bits = SHA256 $ SHA256.hash $ BS.concat $ BL.toChunks bits++rawHash :: Hash -> BS.ByteString+rawHash NoHash = error "Cannot obtain raw hash from NoHash."+rawHash (SHA1 s) = s+rawHash (SHA256 s) = s++match :: Hash -> Hash -> Bool+NoHash `match` _ = False+_ `match` NoHash = False+x `match` y = x == y
+ hashed-storage/Storage/Hashed/Index.hs view
@@ -0,0 +1,525 @@+{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses #-}++-- | This module contains plain tree indexing code. The index itself is a+-- CACHE: you should only ever use it as an optimisation and never as a primary+-- storage. In practice, this means that when we change index format, the+-- application is expected to throw the old index away and build a fresh+-- index. Please note that tracking index validity is out of scope for this+-- library: this is responsibility of your application. It is advisable that in+-- your validity tracking code, you also check for format validity (see+-- 'indexFormatValid') and scrap and re-create index when needed.+--+-- The index is a binary file that overlays a hashed tree over the working+-- copy. This means that every working file and directory has an entry in the+-- index, that contains its path and hash and validity data. The validity data+-- is a timestamp plus the file size. The file hashes are sha256's of the+-- file's content. It also contains the fileid to track moved files.+--+-- There are two entry types, a file entry and a directory entry. Both have a+-- common binary format (see 'Item'). The on-disk format is best described by+-- the section /Index format/ below.+--+-- For each file, the index has a copy of the file's last modification+-- timestamp taken at the instant when the hash has been computed. This means+-- that when file size and timestamp of a file in working copy matches those in+-- the index, we assume that the hash stored in the index for given file is+-- valid. These hashes are then exposed in the resulting 'Tree' object, and can+-- be leveraged by eg. 'diffTrees' to compare many files quickly.+--+-- You may have noticed that we also keep hashes of directories. These are+-- assumed to be valid whenever the complete subtree has been valid. At any+-- point, as soon as a size or timestamp mismatch is found, the working file in+-- question is opened, its hash (and timestamp and size) is recomputed and+-- updated in-place in the index file (everything lives at a fixed offset and+-- is fixed size, so this isn't an issue). This is also true of directories:+-- when a file in a directory changes hash, this triggers recomputation of all+-- of its parent directory hashes; moreover this is done efficiently -- each+-- directory is updated at most once during an update run.+--+-- /Index format/+--+-- The Index is organised into \"lines\" where each line describes a single+-- indexed item. Cf. 'Item'.+--+-- The first word on the index \"line\" is the length of the file path (which is+-- the only variable-length part of the line). Then comes the path itself, then+-- fixed-length hash (sha256) of the file in question, then three words, one for+-- size, one for "aux", which is used differently for directories and for files, and+-- one for the fileid (inode or fhandle) of the file.+--+-- With directories, this aux holds the offset of the next sibling line in the+-- index, so we can efficiently skip reading the whole subtree starting at a+-- given directory (by just seeking aux bytes forward). The lines are+-- pre-ordered with respect to directory structure -- the directory comes first+-- and after it come all its items. Cf. 'readIndex''.+--+-- For files, the aux field holds a timestamp.++module Storage.Hashed.Index( readIndex, updateIndexFrom, indexFormatValid+ , updateIndex, listFileIDs, Index, filter+ , getFileID )+ where++import Prelude hiding ( lookup, readFile, writeFile, filter, catch )+import Storage.Hashed.Utils+import Storage.Hashed.Tree+import Storage.Hashed.AnchoredPath+import Data.Int( Int64, Int32 )++import Bundled.Posix( getFileStatusBS, modificationTime,+ getFileStatus, fileSize, fileExists, isDirectory )+import System.IO.MMap( mmapFileForeignPtr, mmapFileByteString, Mode(..) )+import System.IO( )+import System.Directory( doesFileExist, getCurrentDirectory, doesDirectoryExist )+#if mingw32_HOST_OS+import System.Directory( renameFile )+import System.FilePath( (<.>) )+#else+import System.Directory( removeFile )+#endif+import System.FilePath( (</>) )+import System.Posix.Types ( FileID )++import Control.Monad( when )+import Control.Exception( catch, SomeException )+import Control.Applicative( (<$>) )++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Data.ByteString.Unsafe( unsafeHead, unsafeDrop )+import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy+ , nullForeignPtr, c2w )++import Data.IORef( )+import Data.Maybe( fromJust, isJust, fromMaybe )+import Data.Bits( Bits )++import Foreign.Storable+import Foreign.ForeignPtr+import Foreign.Ptr++import Storage.Hashed.Hash( sha256, rawHash )+#ifdef WIN32+import System.Win32.File ( createFile, getFileInformationByHandle, BY_HANDLE_FILE_INFORMATION(..),+ fILE_SHARE_NONE, fILE_FLAG_BACKUP_SEMANTICS,+ gENERIC_NONE, oPEN_EXISTING, closeHandle )+#else+import System.PosixCompat ( fileID, getSymbolicLinkStatus )+#endif++--------------------------+-- Indexed trees+--++-- | Description of a a single indexed item. The structure itself does not+-- contain any data, just pointers to the underlying mmap (bytestring is a+-- pointer + offset + length).+--+-- The structure is recursive-ish (as opposed to flat-ish structure, which is+-- used by git...) It turns out that it's hard to efficiently read a flat index+-- with our internal data structures -- we need to turn the flat index into a+-- recursive Tree object, which is rather expensive... As a bonus, we can also+-- efficiently implement subtree queries this way (cf. 'readIndex').+data Item = Item { iBase :: !(Ptr ())+ , iHashAndDescriptor :: !BS.ByteString+ } deriving Show++size_magic :: Int+size_magic = 4 -- the magic word, first 4 bytes of the index++size_dsclen, size_hash, size_size, size_aux, size_fileid :: Int+size_size = 8 -- file/directory size (Int64)+size_aux = 8 -- aux (Int64)+size_fileid = 8 -- fileid (inode or fhandle FileID)+size_dsclen = 4 -- this many bytes store the length of the path+size_hash = 32 -- hash representation++off_size, off_aux, off_hash, off_dsc, off_dsclen, off_fileid :: Int+off_size = 0+off_aux = off_size + size_size+off_fileid = off_aux + size_aux+off_dsclen = off_fileid + size_fileid+off_hash = off_dsclen + size_dsclen+off_dsc = off_hash + size_hash++itemAllocSize :: AnchoredPath -> Int+itemAllocSize apath =+ align 4 $ size_hash + size_size + size_aux + size_fileid + size_dsclen + 2 + BS.length (flatten apath)++itemSize, itemNext :: Item -> Int+itemSize i = size_size + size_aux + size_fileid + size_dsclen + (BS.length $ iHashAndDescriptor i)+itemNext i = align 4 (itemSize i + 1)++iPath, iHash, iDescriptor :: Item -> BS.ByteString+iDescriptor = unsafeDrop size_hash . iHashAndDescriptor+iPath = unsafeDrop 1 . iDescriptor+iHash = BS.take size_hash . iHashAndDescriptor++iSize, iAux :: Item -> Ptr Int64+iSize i = plusPtr (iBase i) off_size+iAux i = plusPtr (iBase i) off_aux++iFileID :: Item -> Ptr FileID+iFileID i = plusPtr (iBase i) off_fileid++itemIsDir :: Item -> Bool+itemIsDir i = unsafeHead (iDescriptor i) == c2w 'D'++-- xlatePeek32 = fmap xlate32 . peek+xlatePeek64 :: (Storable a, Bits a) => Ptr a -> IO a+xlatePeek64 = fmap xlate64 . peek++-- xlatePoke32 ptr v = poke ptr (xlate32 v)+xlatePoke64 :: (Storable a, Bits a) => Ptr a -> a -> IO ()+xlatePoke64 ptr v = poke ptr (xlate64 v)++-- | Lay out the basic index item structure in memory. The memory location is+-- given by a ForeignPointer () and an offset. The path and type given are+-- written out, and a corresponding Item is given back. The remaining bits of+-- the item can be filled out using 'update'.+createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item+createItem typ apath fp off =+ do let dsc = BS.concat [ BSC.singleton $ if typ == TreeType then 'D' else 'F'+ , flatten apath+ , BS.singleton 0 ]+ (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc+ withForeignPtr fp $ \p ->+ withForeignPtr dsc_fp $ \dsc_p ->+ do fileid <- fromMaybe 0 <$> getFileID apath+ pokeByteOff p (off + off_fileid) (xlate64 $ fromIntegral fileid :: Int64)+ pokeByteOff p (off + off_dsclen) (xlate32 $ fromIntegral dsc_len :: Int32)+ memcpy (plusPtr p $ off + off_dsc)+ (plusPtr dsc_p dsc_start)+ (fromIntegral dsc_len)+ peekItem fp off++-- | Read the on-disk representation into internal data structure.+--+-- See the module-level section /Index format/ for details on how the index+-- is structured.+peekItem :: ForeignPtr () -> Int -> IO Item+peekItem fp off =+ withForeignPtr fp $ \p -> do+ nl' :: Int32 <- xlate32 `fmap` peekByteOff p (off + off_dsclen)+ when (nl' <= 2) $ fail "Descriptor too short in peekItem!"+ let nl = fromIntegral nl'+ dsc = fromForeignPtr (castForeignPtr fp) (off + off_hash) (size_hash + nl - 1)+ return $! Item { iBase = plusPtr p off+ , iHashAndDescriptor = dsc }++-- | Update an existing item with new hash and optionally mtime (give Nothing+-- when updating directory entries).+updateItem :: Item -> Int64 -> Hash -> IO ()+updateItem item _ NoHash =+ fail $ "Index.update NoHash: " ++ BSC.unpack (iPath item)+updateItem item size hash =+ do xlatePoke64 (iSize item) size+ unsafePokeBS (iHash item) (rawHash hash)++updateFileID :: Item -> FileID -> IO ()+updateFileID item fileid = xlatePoke64 (iFileID item) $ fromIntegral fileid+updateAux :: Item -> Int64 -> IO ()+updateAux item aux = xlatePoke64 (iAux item) $ aux+updateTime :: forall a.(Enum a) => Item -> a -> IO ()+updateTime item mtime = updateAux item (fromIntegral $ fromEnum mtime)++iHash' :: Item -> Hash+iHash' i = SHA256 (iHash i)++-- | Gives a ForeignPtr to mmapped index, which can be used for reading and+-- updates. The req_size parameter, if non-0, expresses the requested size of+-- the index file. mmapIndex will grow the index if it is smaller than this.+mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int)+mmapIndex indexpath req_size = do+ exist <- doesFileExist indexpath+ act_size <- fromIntegral `fmap` if exist then fileSize `fmap` getFileStatus indexpath+ else return 0+ let size = case req_size > 0 of+ True -> req_size+ False | act_size >= size_magic -> act_size - size_magic+ | otherwise -> 0+ case size of+ 0 -> return (castForeignPtr nullForeignPtr, size)+ _ -> do (x, _, _) <- mmapFileForeignPtr indexpath+ ReadWriteEx (Just (0, size + size_magic))+ return (x, size)++data IndexM m = Index { mmap :: (ForeignPtr ())+ , basedir :: FilePath+ , hashtree :: Tree m -> Hash+ , predicate :: AnchoredPath -> TreeItem m -> Bool }+ | EmptyIndex++type Index = IndexM IO++data State = State { dirlength :: !Int+ , path :: !AnchoredPath+ , start :: !Int }++data Result = Result { -- | marks if the item has changed since the last update to the index+ changed :: !Bool+ -- | next is the position of the next item, in bytes.+ , next :: !Int+ -- | treeitem is Nothing in case of the item doesn't exist in the tree+ -- or is filtered by a FilterTree. Or a TreeItem otherwise.+ , treeitem :: !(Maybe (TreeItem IO))+ -- | resitem is the item extracted.+ , resitem :: !Item }++data ResultF = ResultF { -- | nextF is the position of the next item, in bytes.+ nextF :: !Int+ -- | resitemF is the item extracted.+ , resitemF :: !Item+ -- | _fileIDs contains the fileids of the files and folders inside,+ -- in a folder item and its own fileid for file item).+ , _fileIDs :: [((AnchoredPath, ItemType), FileID)] }++readItem :: Index -> State -> IO Result+readItem index state = do+ item <- peekItem (mmap index) (start state)+ res' <- if itemIsDir item+ then readDir index state item+ else readFile index state item+ return res'++readDir :: Index -> State -> Item -> IO Result+readDir index state item =+ do following <- fromIntegral <$> xlatePeek64 (iAux item)+ st <- getFileStatusBS (iPath item)+ let exists = fileExists st && isDirectory st+ fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item)+ fileid' <- fromMaybe fileid <$> (getFileID' $ BSC.unpack $ iPath item)+ when (fileid == 0) $ updateFileID item fileid'+ let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC+ namelength = (BS.length $ iDescriptor item) - (dirlength state)+ myname = name item (dirlength state)+ substate = state { start = start state + itemNext item+ , path = path state `appendPath` myname+ , dirlength = if myname == Name (BSC.singleton '.')+ then dirlength state+ else dirlength state + namelength }++ want = exists && (predicate index) (path substate) (Stub undefined NoHash)+ oldhash = iHash' item++ subs off | off < following = do+ result <- readItem index $ substate { start = off }+ rest <- subs $ next result+ return $! (name (resitem result) $ dirlength substate, result) : rest+ subs coff | coff == following = return []+ | otherwise = fail $ "Offset mismatch at " ++ show coff +++ " (ends at " ++ show following ++ ")"++ inferiors <- if want then subs $ start substate+ else return []++ let we_changed = or [ changed x | (_, x) <- inferiors ] || nullleaf+ nullleaf = null inferiors && oldhash == nullsha+ nullsha = SHA256 (BS.replicate 32 0)+ tree' = makeTree [ (n, fromJust $ treeitem s) | (n, s) <- inferiors, isJust $ treeitem s ]+ treehash = if we_changed then hashtree index tree' else oldhash+ tree = tree' { treeHash = treehash }++ when (exists && we_changed) $ updateItem item 0 treehash+ return $ Result { changed = not exists || we_changed+ , next = following+ , treeitem = if want then Just $ SubTree tree+ else Nothing+ , resitem = item }++readFile :: Index -> State -> Item -> IO Result+readFile index state item =+ do st <- getFileStatusBS (iPath item)+ mtime <- fromIntegral <$> (xlatePeek64 $ iAux item)+ size <- xlatePeek64 $ iSize item+ fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item)+ fileid' <- fromMaybe fileid <$> (getFileID' $ BSC.unpack $ iPath item)+ let mtime' = modificationTime st+ size' = fromIntegral $ fileSize st+ readblob = readSegment (basedir index </> BSC.unpack (iPath item), Nothing)+ exists = fileExists st && not (isDirectory st)+ we_changed = mtime /= mtime' || size /= size'+ hash = iHash' item+ when (exists && we_changed) $+ do hash' <- sha256 `fmap` readblob+ updateItem item size' hash'+ updateTime item mtime'+ when (fileid == 0) $ updateFileID item fileid'+ return $ Result { changed = not exists || we_changed+ , next = start state + itemNext item+ , treeitem = if exists then Just $ File $ Blob readblob hash else Nothing+ , resitem = item }++updateIndex :: Index -> IO (Tree IO)+updateIndex EmptyIndex = return emptyTree+updateIndex index =+ do let initial = State { start = size_magic+ , dirlength = 0+ , path = AnchoredPath [] }+ res <- readItem index initial+ case treeitem res of+ Just (SubTree tree) -> return $ filter (predicate index) tree+ _ -> fail "Unexpected failure in updateIndex!"++-- | Return a list containing all the file/folder names in an index, with+-- their respective ItemType and FileID.+listFileIDs :: Index -> IO ([((AnchoredPath, ItemType), FileID)])+listFileIDs EmptyIndex = return []+listFileIDs index =+ do let initial = State { start = size_magic+ , dirlength = 0+ , path = AnchoredPath [] }+ res <- readItemFileIDs index initial+ return $ _fileIDs res++readItemFileIDs :: Index -> State -> IO ResultF+readItemFileIDs index state = do+ item <- peekItem (mmap index) (start state)+ res' <- if itemIsDir item+ then readDirFileIDs index state item+ else readFileFileID index state item+ return res'++readDirFileIDs :: Index -> State -> Item -> IO ResultF+readDirFileIDs index state item =+ do fileid <- fromIntegral <$> (xlatePeek64 $ iFileID item)+ following <- fromIntegral <$> xlatePeek64 (iAux item)+ let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC+ namelength = (BS.length $ iDescriptor item) - (dirlength state)+ myname = name item (dirlength state)+ substate = state { start = start state + itemNext item+ , path = path state `appendPath` myname+ , dirlength = if myname == Name (BSC.singleton '.')+ then dirlength state+ else dirlength state + namelength }+ subs off | off < following = do+ result <- readItemFileIDs index $ substate { start = off }+ rest <- subs $ nextF result+ return $! (name (resitemF result) $ dirlength substate, result) : rest+ subs coff | coff == following = return []+ | otherwise = fail $ "Offset mismatch at " ++ show coff +++ " (ends at " ++ show following ++ ")"+ inferiors <- subs $ start substate+ return $ ResultF { nextF = following+ , resitemF = item+ , _fileIDs = (((path substate, TreeType), fileid):concatMap (_fileIDs . snd) inferiors) }++readFileFileID :: Index -> State -> Item -> IO ResultF+readFileFileID _ state item =+ do fileid' <- fromIntegral <$> (xlatePeek64 $ iFileID item)+ let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it)+ myname = name item (dirlength state)+ return $ ResultF { nextF = start state + itemNext item+ , resitemF = item+ , _fileIDs = [((path state `appendPath` myname, BlobType), fileid')] }+++-- | Read an index and build up a 'Tree' object from it, referring to current+-- working directory. The initial Index object returned by readIndex is not+-- directly useful. However, you can use 'Tree.filter' on it. Either way, to+-- obtain the actual Tree object, call update.+--+-- The usual use pattern is this:+--+-- > do (idx, update) <- readIndex+-- > tree <- update =<< filter predicate idx+--+-- The resulting tree will be fully expanded.+readIndex :: FilePath -> (Tree IO -> Hash) -> IO Index+readIndex indexpath ht = do+ (mmap_ptr, mmap_size) <- mmapIndex indexpath 0+ base <- getCurrentDirectory+ return $ if mmap_size == 0 then EmptyIndex+ else Index { mmap = mmap_ptr+ , basedir = base+ , hashtree = ht+ , predicate = \_ _ -> True }++formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO ()+formatIndex mmap_ptr old reference =+ do _ <- create (SubTree reference) (AnchoredPath []) size_magic+ unsafePokeBS magic (BSC.pack "HSI5")+ where magic = fromForeignPtr (castForeignPtr mmap_ptr) 0 4+ create (File _) path' off =+ do i <- createItem BlobType path' mmap_ptr off+ let flatpath = BSC.unpack $ flatten path'+ case find old path' of+ Nothing -> return ()+ -- TODO calling getFileStatus here is both slightly+ -- inefficient and slightly race-prone+ Just ti -> do st <- getFileStatus flatpath+ let hash = itemHash ti+ mtime = modificationTime st+ size = fileSize st+ updateItem i (fromIntegral size) hash+ updateTime i mtime+ return $ off + itemNext i+ create (SubTree s) path' off =+ do i <- createItem TreeType path' mmap_ptr off+ case find old path' of+ Nothing -> return ()+ Just ti | itemHash ti == NoHash -> return ()+ | otherwise -> updateItem i 0 $ itemHash ti+ let subs [] = return $ off + itemNext i+ subs ((name,x):xs) = do+ let path'' = path' `appendPath` name+ noff <- subs xs+ create x path'' noff+ lastOff <- subs (listImmediate s)+ xlatePoke64 (iAux i) (fromIntegral lastOff)+ return lastOff+ create (Stub _ _) path' _ =+ fail $ "Cannot create index from stubbed Tree at " ++ show path'++-- | Will add and remove files in index to make it match the 'Tree' object+-- given (it is an error for the 'Tree' to contain a file or directory that+-- does not exist in a plain form in current working directory).+updateIndexFrom :: FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index+updateIndexFrom indexpath hashtree' ref =+ do old_idx <- updateIndex =<< readIndex indexpath hashtree'+ reference <- expand ref+ let len_root = itemAllocSize anchoredRoot+ len = len_root + sum [ itemAllocSize p | (p, _) <- list reference ]+ exist <- doesFileExist indexpath+#if mingw32_HOST_OS+ when exist $ renameFile indexpath (indexpath <.> "old")+#else+ when exist $ removeFile indexpath -- to avoid clobbering oldidx+#endif+ (mmap_ptr, _) <- mmapIndex indexpath len+ formatIndex mmap_ptr old_idx reference+ readIndex indexpath hashtree'++-- | Check that a given file is an index file with a format we can handle. You+-- should remove and re-create the index whenever this is not true.+indexFormatValid :: FilePath -> IO Bool+indexFormatValid path' =+ do magic <- mmapFileByteString path' (Just (0, size_magic))+ return $ case BSC.unpack magic of+ "HSI5" -> True+ _ -> False+ `catch` \(_::SomeException) -> return False++instance FilterTree IndexM IO where+ filter _ EmptyIndex = EmptyIndex+ filter p index = index { predicate = \a b -> predicate index a b && p a b }+++-- | For a given file or folder path, get the corresponding fileID from the+-- filesystem.+getFileID :: AnchoredPath -> IO (Maybe FileID)+getFileID = getFileID' . anchorPath ""++getFileID' :: FilePath -> IO (Maybe FileID)+getFileID' fp = do file_exists <- doesFileExist fp+ dir_exists <- doesDirectoryExist fp+ if file_exists || dir_exists+#ifdef WIN32+ then do h <- createFile fp gENERIC_NONE fILE_SHARE_NONE Nothing oPEN_EXISTING fILE_FLAG_BACKUP_SEMANTICS Nothing+ fhnumber <- (Just . fromIntegral . bhfiFileIndex) <$> getFileInformationByHandle h+ closeHandle h+ return fhnumber+#else+ then (Just . fileID) <$> getSymbolicLinkStatus fp+#endif+ else return Nothing
+ hashed-storage/Storage/Hashed/Monad.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE ScopedTypeVariables, BangPatterns, TypeSynonymInstances, UndecidableInstances, FlexibleInstances #-}++-- | An experimental monadic interface to Tree mutation. The main idea is to+-- simulate IO-ish manipulation of real filesystem (that's the state part of+-- the monad), and to keep memory usage down by reasonably often dumping the+-- intermediate data to disk and forgetting it. The monad interface itself is+-- generic, and a number of actual implementations can be used. This module+-- provides just 'virtualTreeIO' that never writes any changes, but may trigger+-- filesystem reads as appropriate.+module Storage.Hashed.Monad+ ( virtualTreeIO, virtualTreeMonad+ , readFile, writeFile, createDirectory, rename, copy, unlink+ , fileExists, directoryExists, exists, withDirectory+ , currentDirectory+ , tree, TreeState, TreeMonad, TreeIO, runTreeMonad+ , initialState, replaceItem+ , findM, findFileM, findTreeM+ , TreeRO, TreeRW+ ) where++import Prelude hiding ( readFile, writeFile )++import Storage.Hashed.AnchoredPath+import Storage.Hashed.Tree++import Control.Applicative( (<$>) )++import Data.List( sortBy )+import Data.Int( Int64 )+import Data.Maybe( isNothing, isJust )++import qualified Data.ByteString.Lazy.Char8 as BL+import Control.Monad.RWS.Strict+import qualified Data.Map as M++type Changed = M.Map AnchoredPath (Int64, Int64) -- size, age++-- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree+-- content, unsync'd changes and a current working directory (of the monad).+data TreeState m = TreeState { tree :: !(Tree m)+ , changed :: !Changed+ , changesize :: !Int64+ , maxage :: !Int64+ , updateHash :: TreeItem m -> m Hash+ , update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m) }++-- | A 'TreeIO' monad. A sort of like IO but it keeps a 'TreeState' around as well,+-- which is a sort of virtual filesystem. Depending on how you obtained your+-- 'TreeIO', the actions in your virtual filesystem get somehow reflected in the+-- actual real filesystem. For 'virtualTreeIO', nothing happens in real+-- filesystem, however with 'plainTreeIO', the plain tree will be updated every+-- now and then, and with 'hashedTreeIO' a darcs-style hashed tree will get+-- updated.+type TreeMonad m = RWST AnchoredPath () (TreeState m) m+type TreeIO = TreeMonad IO++class (Functor m, Monad m) => TreeRO m where+ currentDirectory :: m AnchoredPath+ withDirectory :: AnchoredPath -> m a -> m a+ expandTo :: AnchoredPath -> m AnchoredPath+ -- | Grab content of a file in the current Tree at the given path.+ readFile :: AnchoredPath -> m BL.ByteString+ -- | Check for existence of a node (file or directory, doesn't matter).+ exists :: AnchoredPath -> m Bool+ -- | Check for existence of a directory.+ directoryExists ::AnchoredPath -> m Bool+ -- | Check for existence of a file.+ fileExists :: AnchoredPath -> m Bool++class TreeRO m => TreeRW m where+ -- | Change content of a file at a given path. The change will be+ -- eventually flushed to disk, but might be buffered for some time.+ writeFile :: AnchoredPath -> BL.ByteString -> m ()+ createDirectory :: AnchoredPath -> m ()+ unlink :: AnchoredPath -> m ()+ rename :: AnchoredPath -> AnchoredPath -> m ()+ copy :: AnchoredPath -> AnchoredPath -> m ()++initialState :: Tree m -> (TreeItem m -> m Hash)+ -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)) -> TreeState m+initialState t uh u = TreeState { tree = t+ , changed = M.empty+ , changesize = 0+ , updateHash = uh+ , maxage = 0+ , update = u }++flush :: (Functor m, Monad m) => TreeMonad m ()+flush = do changed' <- map fst <$> M.toList <$> gets changed+ dirs' <- gets tree >>= \t -> return [ path | (path, SubTree _) <- list t ]+ modify $ \st -> st { changed = M.empty, changesize = 0 }+ forM_ (changed' ++ dirs' ++ [AnchoredPath []]) flushItem++runTreeMonad' :: (Functor m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m)+runTreeMonad' action initial = do+ (out, final, _) <- runRWST action (AnchoredPath []) initial+ return (out, tree final)++runTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m)+runTreeMonad action initial = do+ let action' = do x <- action+ flush+ return x+ runTreeMonad' action' initial++-- | Run a TreeIO action without storing any changes. This is useful for+-- running monadic tree mutations for obtaining the resulting Tree (as opposed+-- to their effect of writing a modified tree to disk). The actions can do both+-- read and write -- reads are passed through to the actual filesystem, but the+-- writes are held in memory in a form of modified Tree.+virtualTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m)+virtualTreeMonad action t = runTreeMonad' action $+ initialState t (\_ -> return NoHash) (\_ x -> return x)++virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO)+virtualTreeIO = virtualTreeMonad++-- | Modifies an item in the current Tree. This action keeps an account of the+-- modified data, in changed and changesize, for subsequent flush+-- operations. Any modifications (as in "modifyTree") are allowed.+modifyItem :: (Functor m, Monad m)+ => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()+modifyItem path item = do+ path' <- (`catPaths` path) `fmap` currentDirectory+ age <- gets maxage+ changed' <- gets changed+ let getsize (Just (File b)) = lift (BL.length `fmap` readBlob b)+ getsize _ = return 0+ size <- getsize item+ let change = case M.lookup path' changed' of+ Nothing -> size+ Just (oldsize, _) -> size - oldsize++ modify $ \st -> st { tree = modifyTree (tree st) path' item+ , changed = M.insert path' (size, age) (changed st)+ , maxage = age + 1+ , changesize = (changesize st + change) }++renameChanged :: (Functor m, Monad m)+ => AnchoredPath -> AnchoredPath -> TreeMonad m ()+renameChanged from to = modify $ \st -> st { changed = rename' $ changed st }+ where rename' = M.fromList . map renameone . M.toList+ renameone (x, d) | from `isPrefix` x = (to `catPaths` relative from x, d)+ | otherwise = (x, d)+ relative (AnchoredPath from') (AnchoredPath x) = AnchoredPath $ drop (length from') x++-- | Replace an item with a new version without modifying the content of the+-- tree. This does not do any change tracking. Ought to be only used from a+-- 'sync' implementation for a particular storage format. The presumed use-case+-- is that an existing in-memory Blob is replaced with a one referring to an+-- on-disk file.+replaceItem :: (Functor m, Monad m)+ => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()+replaceItem path item = do+ path' <- (`catPaths` path) `fmap` currentDirectory+ modify $ \st -> st { tree = modifyTree (tree st) path' item }++flushItem :: forall m. (Monad m, Functor m) => AnchoredPath -> TreeMonad m ()+flushItem path =+ do current <- gets tree+ case find current path of+ Nothing -> return () -- vanished, do nothing+ Just x -> do y <- fixHash x+ new <- gets update >>= ($ y) . ($ path)+ replaceItem path (Just new)+ where fixHash :: TreeItem m -> TreeMonad m (TreeItem m)+ fixHash f@(File (Blob con NoHash)) = do+ hash <- gets updateHash >>= \x -> lift $ x f+ return $ File $ Blob con hash+ fixHash (SubTree s) | treeHash s == NoHash =+ gets updateHash >>= \f -> SubTree <$> lift (addMissingHashes f s)+ fixHash x = return x+++-- | If buffers are becoming large, sync, otherwise do nothing.+flushSome :: (Monad m, Functor m) => TreeMonad m ()+flushSome = do x <- gets changesize+ when (x > megs 100) $ do+ remaining <- go =<< sortBy age <$> M.toList <$> gets changed+ modify $ \s -> s { changed = M.fromList remaining }+ where go [] = return []+ go ((path, (size, _)):chs) = do+ x <- (\s -> s - size) <$> gets changesize+ flushItem path+ modify $ \s -> s { changesize = x }+ if (x > megs 50) then go chs+ else return $ chs+ megs = (* (1024 * 1024))+ age (_, (_, a)) (_, (_, b)) = compare a b++instance (Functor m, Monad m) => TreeRO (TreeMonad m) where+ expandTo p =+ do t <- gets tree+ p' <- (`catPaths` p) `fmap` ask+ let amend = do t' <- lift $ expandPath t p'+ modify $ \st -> st { tree = t' }+ case find t p' of+ Nothing -> amend+ Just (Stub _ _) -> amend+ _ -> return ()+ return p'++ fileExists p =+ do p' <- expandTo p+ (isJust . (flip findFile p')) `fmap` gets tree++ directoryExists p =+ do p' <- expandTo p+ (isJust . (flip findTree p')) `fmap` gets tree++ exists p =+ do p' <- expandTo p+ (isJust . (flip find p')) `fmap` gets tree++ readFile p =+ do p' <- expandTo p+ t <- gets tree+ let f = findFile t p'+ case f of+ Nothing -> fail $ "No such file " ++ show p'+ Just x -> lift (readBlob x)++ currentDirectory = ask+ withDirectory dir act = do+ dir' <- expandTo dir+ local (\_ -> dir') act++instance (Functor m, Monad m) => TreeRW (TreeMonad m) where+ writeFile p con =+ do _ <- expandTo p+ modifyItem p (Just blob)+ flushSome+ where blob = File $ Blob (return con) hash+ hash = NoHash -- we would like to say "sha256 con" here, but due+ -- to strictness of Hash in Blob, this would often+ -- lead to unnecessary computation which would then+ -- be discarded anyway; we rely on the sync+ -- implementation to fix up any NoHash occurrences++ createDirectory p =+ do _ <- expandTo p+ modifyItem p $ Just $ SubTree emptyTree++ unlink p =+ do _ <- expandTo p+ modifyItem p Nothing++ rename from to =+ do from' <- expandTo from+ to' <- expandTo to+ tr <- gets tree+ let item = find tr from'+ found_to = find tr to'+ unless (isNothing found_to) $+ fail $ "Error renaming: destination " ++ show to ++ " exists."+ unless (isNothing item) $ do+ modifyItem from Nothing+ modifyItem to item+ renameChanged from to++ copy from to =+ do from' <- expandTo from+ _ <- expandTo to+ tr <- gets tree+ let item = find tr from'+ unless (isNothing item) $ modifyItem to item++findM' :: forall m a. (Monad m, Functor m)+ => (Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a+findM' what t path = fst <$> virtualTreeMonad (look path) t+ where look :: AnchoredPath -> TreeMonad m a+ look = expandTo >=> \p' -> flip what p' <$> gets tree++findM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (TreeItem m))+findM = findM' find++findTreeM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Tree m))+findTreeM = findM' findTree++findFileM :: (Monad m, Functor m) => Tree m -> AnchoredPath -> m (Maybe (Blob m))+findFileM = findM' findFile
+ hashed-storage/Storage/Hashed/Packed.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE ParallelListComp #-}+-- | This module implements an "object storage". This is a directory on disk+-- containing a content-addressed storage. This is useful for storing all kinds+-- of things, particularly filesystem trees, or darcs pristine caches and patch+-- objects. However, this is an abstract, flat storage: no tree semantics are+-- provided. You just need to provide a reference-collecting functionality,+-- computing a list of references for any given object. The system provides+-- transparent garbage collection and packing.+module Storage.Hashed.Packed+ ( Format(..), Block, OS+ -- * Basic operations.+ , hatch, compact, repack, lookup+ -- * Creating and loading.+ , create, load+ -- * Low-level.+ , format, blockLookup, live, hatchery, mature, roots, references, rootdir+ ) where++import Prelude hiding ( lookup, read )+import Storage.Hashed.AnchoredPath( )+import Storage.Hashed.Tree ( )+import Storage.Hashed.Utils+import Storage.Hashed.Hash++import Control.Monad( forM, forM_, unless )+import Control.Applicative( (<$>) )+import System.FilePath( (</>), (<.>) )+import System.Directory( createDirectoryIfMissing, removeFile+ , getDirectoryContents )++import Bundled.Posix( fileExists, isDirectory, getFileStatus )++import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as BS+import Data.Maybe( listToMaybe, catMaybes, isNothing )+import Data.Binary( encode, decode )++import qualified Data.Set as S+import qualified Data.Map as M+import Data.List( sort )+import Data.Int( Int64 )++-- | On-disk format for object storage: we implement a completely loose format+-- (one file per object), a compact format stored in a single append-only file+-- and an immutable \"pack\" format.+data Format = Loose | Compact | Pack deriving (Show, Eq)++loose_dirs :: [[Char]]+loose_dirs = let chars = ['0'..'9'] ++ ['a'..'f']+ in [ [a,b] | a <- chars, b <- chars ]++loosePath :: OS -> Hash -> FilePath+loosePath _ NoHash = error "No path for NoHash!"+loosePath os hash =+ let hash' = BS.unpack (encodeBase16 hash)+ in rootdir os </> "hatchery" </> take 2 hash' </> drop 2 hash'++looseLookup :: OS -> Hash -> IO (Maybe FileSegment)+looseLookup _ NoHash = return Nothing+looseLookup os hash = do+ let path = loosePath os hash+ exist <- fileExists <$> getFileStatus path+ return $ if exist then Just (path, Nothing)+ else Nothing++-- | Object storage block. When used as a hatchery, the loose or compact format+-- are preferable, while for mature space, the pack format is more useful.+data Block = Block { blockLookup :: Hash -> IO (Maybe FileSegment)+ , size :: Int64+ , format :: Format }++-- | Object storage. Contains a single \"hatchery\" and possibly a number of+-- mature space blocks, usually in form of packs. It also keeps a list of root+-- pointers and has a way to extract pointers from objects (externally+-- supplied). These last two things are used to implement a simple GC.+data OS = OS { hatchery :: Block+ , mature :: [Block]+ , roots :: [Hash]+ , references :: FileSegment -> IO [Hash]+ , rootdir :: FilePath }++-- | Reduce number of packs in the object storage. This may both recombine+-- packs to eliminate dead objects and join some packs to form bigger packs.+repack :: OS -> IO OS+repack _ = error "repack undefined"++-- | Add new objects to the object storage (i.e. put them into hatchery). It is+-- safe to call this even on objects that are already present in the storage:+-- such objects will be skipped.+hatch :: OS -> [BL.ByteString] -> IO OS+hatch os blobs =+ do processed <- mapM sieve blobs+ write [ (h, b) | (True, h, b) <- processed ]+ where write bits =+ case format (hatchery os) of+ Loose ->+ do _ <- forM bits $ \(hash, blob) -> do+ BL.writeFile (loosePath os hash) blob+ return os+ Compact -> error "hatch/compact undefined"+ _ -> fail "Hatchery must be either Loose or Compact."+ sieve blob = do let hash = sha256 blob+ absent <- isNothing <$> lookup os hash+ return (absent, hash, blob)++-- | Move things from hatchery into a (new) pack.+compact :: OS -> IO OS+compact os = do objects <- live os [hatchery os]+ block <- createPack os (M.toList objects)+ cleanup+ return $ os { mature = block:mature os }+ where cleanup =+ case format (hatchery os) of+ Loose -> forM_ loose_dirs $ nuke . ((rootdir os </> "hatchery") </>)+ Compact -> removeFile (rootdir os </> "hatchery") >> return ()+ _ -> fail "Hatchery must be either Loose or Compact."+ nuke dir = mapM (removeFile . (dir </>)) =<<+ (Prelude.filter (`notElem` [".", ".."]) `fmap`+ getDirectoryContents dir)++blocksLookup :: [Block] -> Hash -> IO (Maybe (Hash, FileSegment))+blocksLookup blocks hash =+ do segment <- cat `fmap` mapM (flip blockLookup hash) blocks+ return $ case segment of+ Nothing -> Nothing+ Just seg -> Just (hash, seg)+ where cat = listToMaybe . catMaybes++lookup :: OS -> Hash -> IO (Maybe FileSegment)+lookup os hash =+ do res <- blocksLookup (hatchery os : mature os) hash+ return $ case res of+ Nothing -> Nothing+ Just (_, seg) -> Just seg++-- | Create an empty object storage in given directory, with a hatchery of+-- given format. The directory is created if needed, but is assumed to be+-- empty.+create :: FilePath -> Format -> IO OS+create path fmt = do createDirectoryIfMissing True path+ _ <- initHatchery+ load path+ where initHatchery | fmt == Loose =+ do mkdir hatchpath+ forM loose_dirs $ mkdir . (hatchpath </>)+ | fmt == Compact =+ error "create/mkHatchery Compact undefined"+ | otherwise =+ error "create/mkHatchery Pack undefined"+ mkdir = createDirectoryIfMissing False+ hatchpath = path </> "hatchery"++load :: FilePath -> IO OS+load path =+ do hatch_stat <- getFileStatus $ path </> "hatchery"+ let is_os = fileExists hatch_stat+ is_dir = isDirectory hatch_stat+ unless is_os $ fail $ path ++ " is not an object storage!"+ let _hatchery = Block { blockLookup = look os+ , format = if is_dir then Loose else Compact+ , size = undefined }+ os = OS { hatchery = _hatchery+ , rootdir = path+ , mature = packs+ , roots = _roots+ , references = undefined }+ look | format _hatchery == Loose = looseLookup+ | otherwise = undefined+ packs = [] -- FIXME read packs+ _roots = [] -- FIXME read root pointers+ return os++readPack :: FilePath -> IO Block+readPack file = do bits <- readSegment (file, Nothing)+ let count = decode (BL.take 8 $ bits)+ _lookup NoHash _ _ = return Nothing+ _lookup hash first final = do+ let middle = first + ((final - first) `div` 2)+ rawhash = rawHash hash+ res <- case ( compare rawhash (hashof first)+ , compare rawhash (hashof middle)+ , compare rawhash (hashof final) ) of+ (LT, _, _) -> return Nothing+ ( _, _, GT) -> return Nothing+ (EQ, _, _) -> return $ Just (segof first)+ ( _, _, EQ) -> return $ Just (segof final)+ (GT, EQ, LT) -> return $ Just (segof middle)+ (GT, GT, LT) | middle /= final -> _lookup hash middle final+ (GT, LT, LT) | first /= middle -> _lookup hash first middle+ ( _, _, _) -> return Nothing+ return res+ headerof i = BL.take 51 $ BL.drop (8 + i * 51) bits+ hashof i = BS.concat $ BL.toChunks $ BL.take 32 $ headerof i+ segof i = (file, Just (count * 51 + 8 + from, sz))+ where from = decode (BL.take 8 $ BL.drop 33 $ headerof i)+ sz = decode (BL.take 8 $ BL.drop 42 $ headerof i)+ return $ Block { size = BL.length bits+ , format = Pack+ , blockLookup = \h -> _lookup h 0 (count - 1) }++createPack :: OS -> [(Hash, FileSegment)] -> IO Block+createPack os bits =+ do contents <- mapM readSegment (map snd bits)+ let offsets = scanl (+) 0 $ map BL.length contents+ headerbits = [ BL.concat [ BL.fromChunks [rawhash]+ , BL.pack "@"+ , encode offset+ , BL.pack "!"+ , encode $ BL.length string+ , BL.pack "\n" ]+ | (SHA256 rawhash, _) <- bits+ | string <- contents+ | offset <- offsets ]+ header = BL.concat $ (encode $ length bits) : sort headerbits+ blob = BL.concat $ header:contents+ hash = sha256 blob+ path = rootdir os </> BS.unpack (encodeBase16 hash) <.> "bin"+ BL.writeFile path blob+ readPack path++-- | Build a map of live objects (i.e. those reachable from the given roots) in+-- a given list of Blocks.+live :: OS -> [Block] -> IO (M.Map Hash FileSegment)+live os blocks =+ reachable (references os)+ (blocksLookup blocks)+ (S.fromList $ roots os)
+ hashed-storage/Storage/Hashed/Plain.hs view
@@ -0,0 +1,78 @@+-- | The plain format implementation resides in this module. The plain format+-- does not use any hashing and basically just wraps a normal filesystem tree+-- in the hashed-storage API.+--+-- NB. The 'read' function on Blobs coming from a plain tree is susceptible to+-- file content changes. Since we use mmap in 'read', this will break+-- referential transparency and produce unexpected results. Please always make+-- sure that all parallel access to the underlying filesystem tree never+-- mutates files. Unlink + recreate is fine though (in other words, the+-- 'writePlainTree' and 'plainTreeIO' implemented in this module are safe in+-- this respect).+module Storage.Hashed.Plain( readPlainTree, writePlainTree,+ plainTreeIO -- (obsolete? if so remove implementation!)+ ) where++import Data.Maybe( catMaybes )+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BL+import System.FilePath( (</>) )+import System.Directory( getDirectoryContents+ , createDirectoryIfMissing )+import Bundled.Posix( getFileStatus, isDirectory, isRegularFile, FileStatus )++import Storage.Hashed.AnchoredPath+import Storage.Hashed.Utils+import Storage.Hashed.Hash( Hash( NoHash) )+import Storage.Hashed.Tree( Tree(), TreeItem(..)+ , Blob(..), makeTree+ , list, readBlob, expand )+import Storage.Hashed.Monad( TreeIO, runTreeMonad, initialState )+import Control.Monad.State( liftIO )++readPlainDir :: FilePath -> IO [(FilePath, FileStatus)]+readPlainDir dir =+ withCurrentDirectory dir $ do+ items <- getDirectoryContents "."+ sequence [ do st <- getFileStatus s+ return (s, st)+ | s <- items, s `notElem` [ ".", ".." ] ]++readPlainTree :: FilePath -> IO (Tree IO)+readPlainTree dir = do+ items <- readPlainDir dir+ let subs = catMaybes [+ let name = Name (BS8.pack name')+ in case status of+ _ | isDirectory status -> Just (name, Stub (readPlainTree (dir </> name')) NoHash)+ _ | isRegularFile status -> Just (name, File $ Blob (readBlob' name) NoHash)+ _ -> Nothing+ | (name', status) <- items ]+ return $ makeTree subs+ where readBlob' (Name name) = readSegment (dir </> BS8.unpack name, Nothing)++-- | Write out /full/ tree to a plain directory structure. If you instead want+-- to make incremental updates, refer to "Storage.Hashed.Monad".+writePlainTree :: Tree IO -> FilePath -> IO ()+writePlainTree t dir = do+ createDirectoryIfMissing True dir+ expand t >>= mapM_ write . list+ where write (p, File b) = write' p b+ write (p, SubTree _) =+ createDirectoryIfMissing True (anchorPath dir p)+ write _ = return ()+ write' p b = readBlob b >>= BL.writeFile (anchorPath dir p)++-- | Run a 'TreeIO' action in a plain tree setting. Writes out changes to the+-- plain tree every now and then (after the action is finished, the last tree+-- state is always flushed to disk). XXX Modify the tree with filesystem+-- reading and put it back into st (ie. replace the in-memory Blobs with normal+-- ones, so the memory can be GCd).+plainTreeIO :: TreeIO a -> Tree IO -> FilePath -> IO (a, Tree IO)+plainTreeIO action t _ = runTreeMonad action $ initialState t (\_ -> return NoHash) updatePlain+ where updatePlain path (File b) =+ do liftIO $ createDirectoryIfMissing True (anchorPath "" $ parent path)+ liftIO $ readBlob b >>= BL.writeFile (anchorPath "" path)+ return $ File $ Blob (BL.readFile $ anchorPath "" path) NoHash+ updatePlain _ x = return x+
+ hashed-storage/Storage/Hashed/Test.hs view
@@ -0,0 +1,618 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Storage.Hashed.Test( tests ) where++import Prelude hiding ( filter, readFile, writeFile, lookup )+import qualified Prelude+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as BS+import Control.Exception( finally )+import System.Directory( doesFileExist, removeFile, doesDirectoryExist )+import System.FilePath( (</>) )+import Control.Monad.Identity+import Control.Monad.Trans( lift )+import Control.Applicative( (<$>) )++import Data.Maybe+import Data.Word+import Data.List( sort, intercalate, nub, intersperse )++import Storage.Hashed+import Storage.Hashed.AnchoredPath+import Storage.Hashed.Tree hiding ( lookup )+import Storage.Hashed.Index+import Storage.Hashed.Utils+import Storage.Hashed.Darcs+import Storage.Hashed.Packed hiding ( lookup )+import Storage.Hashed.Hash+import Storage.Hashed.Monad hiding ( tree )++import System.Mem( performGC )++import qualified Data.Set as S+import qualified Data.Map as M++import qualified Bundled.Posix as Posix+ ( getFileStatus, getSymbolicLinkStatus, fileSize, fileExists )++import Test.HUnit hiding ( path )+import Test.Framework( testGroup )+import qualified Test.Framework as TF ( Test )+import Test.QuickCheck++import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2++------------------------+-- Test Data+--++blobs :: [(AnchoredPath, BL.ByteString)]+blobs = [ (floatPath "foo_a", BL.pack "a\n")+ , (floatPath "foo_dir/foo_a", BL.pack "a\n")+ , (floatPath "foo_dir/foo_b", BL.pack "b\n")+ , (floatPath "foo_dir/foo_subdir/foo_a", BL.pack "a\n")+ , (floatPath "foo space/foo\nnewline", BL.pack "newline\n")+ , (floatPath "foo space/foo\\backslash", BL.pack "backslash\n")+ , (floatPath "foo space/foo_a", BL.pack "a\n") ]++files :: [AnchoredPath]+files = map fst blobs++dirs :: [AnchoredPath]+dirs = [ floatPath "foo_dir"+ , floatPath "foo_dir/foo_subdir"+ , floatPath "foo space" ]++emptyStub :: TreeItem IO+emptyStub = Stub (return emptyTree) NoHash++testTree :: Tree IO+testTree =+ makeTree [ (makeName "foo", emptyStub)+ , (makeName "subtree", SubTree sub)+ , (makeName "substub", Stub getsub NoHash) ]+ where sub = makeTree [ (makeName "stub", emptyStub)+ , (makeName "substub", Stub getsub2 NoHash)+ , (makeName "x", SubTree emptyTree) ]+ getsub = return sub+ getsub2 = return $ makeTree [ (makeName "file", File emptyBlob)+ , (makeName "file2",+ File $ Blob (return $ BL.pack "foo") NoHash) ]++equals_testdata :: Tree IO -> IO ()+equals_testdata t = sequence_ [+ do isJust (findFile t p) @? show p ++ " in tree"+ ours <- readBlob (fromJust $ findFile t p)+ ours @?= stored+ | (p, stored) <- blobs ] >>+ sequence_ [ isJust (Prelude.lookup p blobs) @? show p ++ " extra in tree"+ | (p, File _) <- list t ]++---------------------------+-- Test list+--++tests :: [TF.Test]+tests = [ testGroup "Bundled.Posix" posix+ , testGroup "Storage.Hashed.Utils" utils+ , testGroup "Storage.Hashed.Hash" hash+ , testGroup "Storage.Hashed.Tree" tree+ , testGroup "Storage.Hashed.Index" index+ , testGroup "Storage.Hashed.Packed" packed+ , testGroup "Storage.Hashed.Monad" monad+ , testGroup "Storage.Hashed" hashed ]++--------------------------+-- Tests+--++hashed :: [TF.Test]+hashed = [ testCase "plain has all files" have_files+ , testCase "pristine has all files" have_pristine_files+ , testCase "pristine has no extras" pristine_no_extra+ , testCase "pristine file contents match" pristine_contents+ , testCase "plain file contents match" plain_contents+ , testCase "writePlainTree works" write_plain ]+ where+ check_file t f = assertBool+ ("path " ++ show f ++ " is missing in tree " ++ show t)+ (isJust $ find t f)+ check_files = forM_ files . check_file++ pristine_no_extra = do+ t <- readDarcsPristine "." >>= expand+ forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree")+ (path `elem` (dirs ++ files))+ have_files = readPlainTree "." >>= expand >>= check_files+ have_pristine_files =+ readDarcsPristine "." >>= expand >>= check_files++ pristine_contents = do+ t <- readDarcsPristine "." >>= expand+ equals_testdata t++ plain_contents = do+ t <- expand =<< filter nondarcs `fmap` readPlainTree "."+ equals_testdata t++ write_plain = do+ orig <- readDarcsPristine "." >>= expand+ writePlainTree orig "_darcs/plain"+ t <- expand =<< readPlainTree "_darcs/plain"+ equals_testdata t++index :: [TF.Test]+index = [ testCase "index versioning" check_index_versions+ , testCase "index listing" check_index+ , testCase "index content" check_index_content ]+ where pristine = readDarcsPristine "." >>= expand+ build_index =+ do x <- pristine+ exist <- doesFileExist "_darcs/index"+ performGC -- required in win32 to trigger file close+ when exist $ removeFile "_darcs/index"+ idx <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x+ return (x, idx)+ check_index =+ do (pris, idx) <- build_index+ (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris)+ check_blob_pair p x y =+ do a <- readBlob x+ b <- readBlob y+ assertEqual ("content match on " ++ show p) a b+ check_index_content =+ do (_, idx) <- build_index+ plain <- readPlainTree "."+ x <- sequence $ zipCommonFiles check_blob_pair plain idx+ assertBool "files match" (length x > 0)+ check_index_versions =+ do performGC -- required in win32 to trigger file close+ Prelude.writeFile "_darcs/index" "nonsense index... do not crash!"+ valid <- indexFormatValid "_darcs/index"+ assertBool "index format invalid" $ not valid++tree :: [TF.Test]+tree = [ testCase "modifyTree" check_modify+ , testCase "complex modifyTree" check_modify_complex+ , testCase "modifyTree removal" check_modify_remove+ , testCase "expand" check_expand+ , testCase "expandPath" check_expand_path+ , testCase "expandPath of sub" check_expand_path_sub+ , testCase "diffTrees" check_diffTrees+ , testCase "diffTrees identical" check_diffTrees_ident+ , testProperty "expandPath" prop_expandPath+ , testProperty "shapeEq" prop_shape_eq+ , testProperty "expandedShapeEq" prop_expanded_shape_eq+ , testProperty "expand is identity" prop_expand_id+ , testProperty "filter True is identity" prop_filter_id+ , testProperty "filter False is empty" prop_filter_empty+ , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative+ , testProperty "restrict is a subtree of both" prop_restrict_subtree+ , testProperty "overlay keeps shape" prop_overlay_shape+ , testProperty "overlay is superset of over" prop_overlay_super ]+ where blob x = File $ Blob (return (BL.pack x)) (sha256 $ BL.pack x)+ name = Name . BS.pack+ check_modify =+ let t = makeTree [(name "foo", blob "bar")]+ modify = modifyTree t (floatPath "foo") (Just $ blob "bla")+ in do x <- readBlob $ fromJust $ findFile t (floatPath "foo")+ y <- readBlob $ fromJust $ findFile modify (floatPath "foo")+ assertEqual "old version" x (BL.pack "bar")+ assertEqual "new version" y (BL.pack "bla")+ assertBool "list has foo" $+ isJust (Prelude.lookup (floatPath "foo") $ list modify)+ length (list modify) @?= 1+ check_modify_complex =+ let t = makeTree [ (name "foo", blob "bar")+ , (name "bar", SubTree t1) ]+ t1 = makeTree [ (name "foo", blob "bar") ]+ modify = modifyTree t (floatPath "bar/foo") (Just $ blob "bla")+ in do foo <- readBlob $ fromJust $ findFile t (floatPath "foo")+ foo' <- readBlob $ fromJust $ findFile modify (floatPath "foo")+ bar_foo <- readBlob $ fromJust $+ findFile t (floatPath "bar/foo")+ bar_foo' <- readBlob $ fromJust $+ findFile modify (floatPath "bar/foo")+ assertEqual "old foo" foo (BL.pack "bar")+ assertEqual "old bar/foo" bar_foo (BL.pack "bar")+ assertEqual "new foo" foo' (BL.pack "bar")+ assertEqual "new bar/foo" bar_foo' (BL.pack "bla")+ assertBool "list has bar/foo" $+ isJust (Prelude.lookup (floatPath "bar/foo") $ list modify)+ assertBool "list has foo" $+ isJust (Prelude.lookup (floatPath "foo") $ list modify)+ length (list modify) @?= length (list t)+ check_modify_remove =+ let t1 = makeTree [(name "foo", blob "bar")]+ t2 :: Tree Identity = makeTree [ (name "foo", blob "bar")+ , (name "bar", SubTree t1) ]+ modify1 = modifyTree t1 (floatPath "foo") Nothing+ modify2 = modifyTree t2 (floatPath "bar") Nothing+ file = findFile modify1 (floatPath "foo")+ subtree = findTree modify2 (floatPath "bar")+ in do assertBool "file is gone" (isNothing file)+ assertBool "subtree is gone" (isNothing subtree)++ no_stubs t = null [ () | (_, Stub _ _) <- list t ]+ path = floatPath "substub/substub/file"+ badpath = floatPath "substub/substub/foo"+ check_expand = do+ x <- expand testTree+ assertBool "no stubs in testTree" $ not (no_stubs testTree)+ assertBool "stubs in expanded tree" $ no_stubs x+ assertBool "path reachable" $ path `elem` (map fst $ list x)+ assertBool "badpath not reachable" $+ badpath `notElem` (map fst $ list x)+ check_expand_path = do+ test_exp <- expand testTree+ t <- expandPath testTree path+ t' <- expandPath test_exp path+ t'' <- expandPath testTree $ floatPath "substub/x"+ assertBool "path not reachable in testTree" $ path `notElem` (map fst $ list testTree)+ assertBool "path reachable in t" $ path `elem` (map fst $ list t)+ assertBool "path reachable in t'" $ path `elem` (map fst $ list t')+ assertBool "path reachable in t (with findFile)" $+ isJust $ findFile t path+ assertBool "path reachable in t' (with findFile)" $+ isJust $ findFile t' path+ assertBool "path not reachable in t''" $ path `notElem` (map fst $ list t'')+ assertBool "badpath not reachable in t" $+ badpath `notElem` (map fst $ list t)+ assertBool "badpath not reachable in t'" $+ badpath `notElem` (map fst $ list t')++ check_expand_path_sub = do+ t <- expandPath testTree $ floatPath "substub"+ t' <- expandPath testTree $ floatPath "substub/stub"+ t'' <- expandPath testTree $ floatPath "subtree/stub"+ assertBool "leaf is not a Stub" $+ isNothing (findTree testTree $ floatPath "substub")+ assertBool "leaf is not a Stub" $ isJust (findTree t $ floatPath "substub")+ assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ floatPath "substub/stub")+ assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ floatPath "subtree/stub")++ check_diffTrees =+ flip finally (Prelude.writeFile "foo_dir/foo_a" "a\n") $+ do Prelude.writeFile "foo_dir/foo_a" "b\n"+ working_plain <- filter nondarcs `fmap` readPlainTree "."+ working <- updateIndex =<<+ updateIndexFrom "_darcs/index" darcsTreeHash working_plain+ pristine <- readDarcsPristine "."+ (working', pristine') <- diffTrees working pristine+ let foo_work = findFile working' (floatPath "foo_dir/foo_a")+ foo_pris = findFile pristine' (floatPath "foo_dir/foo_a")+ working' `shapeEq` pristine'+ @? show working' ++ " `shapeEq` " ++ show pristine'+ assertBool "foo_dir/foo_a is in working'" $ isJust foo_work+ assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris+ foo_work_c <- readBlob (fromJust foo_work)+ foo_pris_c <- readBlob (fromJust foo_pris)+ BL.unpack foo_work_c @?= "b\n"+ BL.unpack foo_pris_c @?= "a\n"+ assertEqual "working' tree is minimal" 2 (length $ list working')+ assertEqual "pristine' tree is minimal" 2 (length $ list pristine')++ check_diffTrees_ident = do+ pristine <- readDarcsPristine "."+ (t1, t2) <- diffTrees pristine pristine+ assertBool "t1 is empty" $ null (list t1)+ assertBool "t2 is empty" $ null (list t2)++ prop_shape_eq x = no_stubs x ==> x `shapeEq` x+ where _types = x :: Tree Identity+ prop_expanded_shape_eq x = runIdentity $ expandedShapeEq x x+ where _types = x :: Tree Identity+ prop_expand_id x = no_stubs x ==> runIdentity (expand x) `shapeEq` x+ where _types = x :: Tree Identity+ prop_filter_id x = runIdentity $ expandedShapeEq x $ filter (\_ _ -> True) x+ where _types = x :: Tree Identity+ prop_filter_empty x = runIdentity $ expandedShapeEq emptyTree $ filter (\_ _ -> False) x+ where _types = x :: Tree Identity+ prop_restrict_shape_commutative (t1, t2) =+ no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `shapeEq` emptyTree) ==>+ restrict t1 t2 `shapeEq` restrict t2 t1+ where _types = (t1 :: Tree Identity, t2 :: Tree Identity)+ prop_restrict_subtree (t1, t2) =+ no_stubs t1 && not (restrict t1 t2 `shapeEq` emptyTree) ==>+ let restricted = S.fromList (map fst $ list $ restrict t1 t2)+ orig1 = S.fromList (map fst $ list t1)+ orig2 = S.fromList (map fst $ list t2)+ in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2]+ where _types = (t1 :: Tree Identity, t2 :: Tree Identity)+ prop_overlay_shape (t1 :: Tree Identity, t2) =+ (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==>+ runIdentity $ (t1 `overlay` t2) `expandedShapeEq` t1+ prop_overlay_super (t1 :: Tree Identity, t2) =+ (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==>+ Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2)+ prop_expandPath (TreeWithPath t p) =+ notStub $ find (runIdentity $ expandPath t p) p+ where notStub (Just (Stub _ _)) = False+ notStub Nothing = error "Did not exist."+ notStub _ = True++packed :: [TF.Test]+packed = [ testCase "loose pristine tree" check_loose+ , testCase "load" check_load+ , testCase "live" check_live+ , testCase "compact" check_compact ]+ where root_hash = treeHash <$> get_pristine+ get_pristine = darcsUpdateDirHashes <$> (expand =<< readDarcsPristine ".")+ check_loose = do x <- readDarcsPristine "."+ os <- create "_darcs/loose" Loose+ (os', root) <- writePackedDarcsPristine x os+ y <- expand =<< readPackedDarcsPristine os' root+ equals_testdata y+ check_load = do os <- load "_darcs/loose"+ format (hatchery os) @?= Loose+ root <- root_hash+ y <- expand =<< readPackedDarcsPristine os root+ equals_testdata y+ check_live = do os <- load "_darcs/loose"+ x <- get_pristine+ root <- root_hash+ alive <- live (os { roots = [ root ]+ , references = darcsPristineRefs }) [hatchery os]+ sequence_ [ assertBool (show hashValue ++ " is alive") $+ hashValue `S.member` M.keysSet alive+ | hashValue <- map (itemHash . snd) $ list x ]+ length (M.toList alive) @?= 1 + length (nub $ map snd blobs) + length dirs+ check_compact = do os <- load "_darcs/loose"+ x <- darcsUpdateDirHashes `fmap` (expand =<< readDarcsPristine ".")+ (os', root) <- storePackedDarcsPristine x os+ hatch_root_old <- blockLookup (hatchery os') root+ assertBool "bits in the old hatchery" $ isJust hatch_root_old++ os'' <- compact os'+ length (mature os'') @?= 1+ hatch_root <- blockLookup (hatchery os'') root+ mature_root <- blockLookup (head $ mature os'') root+ assertBool "bits no longer in hatchery" $ isNothing hatch_root+ assertBool "bits now in the mature space" $ isJust mature_root+ mature_root_con <- readSegment (fromJust mature_root)+ Just mature_root_con @?= darcsFormatDir x++ y <- expand =<< readPackedDarcsPristine os'' root+ equals_testdata y++utils :: [TF.Test]+utils = [ testProperty "xlate32" prop_xlate32+ , testProperty "xlate64" prop_xlate64+ , testProperty "align bounded" prop_align_bounded+ , testProperty "align aligned" prop_align_aligned+ , testProperty "reachable is a subset" prop_reach_subset+ , testProperty "roots are reachable" prop_reach_roots+ , testProperty "nonexistent roots are not reachable" prop_reach_nonroots+ , testCase "an example for reachable" check_reachable+ , testCase "fixFrom" check_fixFrom+ , testCase "mmap empty file" check_mmapEmpty ]+ where prop_xlate32 x = (xlate32 . xlate32) x == x where _types = x :: Word32+ prop_xlate64 x = (xlate64 . xlate64) x == x where _types = x :: Word64+ prop_align_bounded (bound, x) =+ bound > 0 && bound < 1024 && x >= 0 ==>+ align bound x >= x && align bound x < x + bound+ where _types = (bound, x) :: (Int, Int)+ prop_align_aligned (bound, x) =+ bound > 0 && bound < 1024 && x >= 0 ==>+ align bound x `rem` bound == 0+ where _types = (bound, x) :: (Int, Int)++ check_fixFrom = let f 0 = 0+ f n = f (n - 1) in fixFrom f 5 @?= (0 :: Integer)++ check_mmapEmpty = flip finally (removeFile "test_empty") $ do+ Prelude.writeFile "test_empty" ""+ x <- readSegment ("test_empty", Nothing)+ x @?= BL.empty++ reachable' ref look rootsSet = runIdentity $ reachable ref look rootsSet++ check_reachable = let refs 0 = [1, 2]+ refs 1 = [2]+ refs 2 = [0, 4]+ refs 3 = [4, 6, 7]+ refs 4 = [0, 1]+ refs _ = error "internal error in check_reachable"+ set = S.fromList [1, 2]+ mp = M.fromList [ (n, refs n) | n <- [0..10] :: [Int] ]+ reach = reachable' return (lookup mp) set+ in do M.keysSet reach @?= S.fromList [0, 1, 2, 4]++ prop_reach_subset (set :: S.Set Int, mp :: M.Map Int [Int]) =+ M.keysSet (reachable' return (lookup mp) set)+ `S.isSubsetOf` M.keysSet mp+ prop_reach_roots (set :: S.Set Int, mp :: M.Map Int [Int]) =+ set `S.isSubsetOf` M.keysSet mp+ ==> set `S.isSubsetOf`+ M.keysSet (reachable' return (lookup mp) set)++ prop_reach_nonroots (set :: S.Set Int, mp :: M.Map Int [Int]) =+ set `S.intersection` M.keysSet mp+ == M.keysSet (reachable' (return . const [])+ (lookup mp) set)++ lookup :: (Ord a) => M.Map a [a] -> a -> Identity (Maybe (a, [a]))+ lookup m k = return $ case M.lookupIndex k m of+ Nothing -> Nothing+ Just i -> Just $ M.elemAt i m++hash :: [TF.Test]+hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16+ , testProperty "decodeBase64u . encodeBase64u == id" prop_base64u ]+ where prop_base16 x = (decodeBase16 . encodeBase16) x == x+ prop_base64u x = (decodeBase64u . encodeBase64u) x == x++monad :: [TF.Test]+monad = [ testCase "path expansion" check_virtual+ , testCase "rename" check_rename ]+ where check_virtual = virtualTreeMonad run testTree >> return ()+ where run = do file <- readFile (floatPath "substub/substub/file")+ file2 <- readFile (floatPath "substub/substub/file2")+ lift $ BL.unpack file @?= ""+ lift $ BL.unpack file2 @?= "foo"+ check_rename = do (_, t) <- virtualTreeMonad run testTree+ t' <- darcsAddMissingHashes =<< expand t+ forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) ->+ assertBool ("have hash: " ++ show p) $ itemHash i /= NoHash+ where run = do rename (floatPath "substub/substub/file") (floatPath "substub/file2")++posix :: [TF.Test]+posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus+ , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ]+ where check_stat fun = flip finally (removeFile "test_empty") $ do+ x <- Posix.fileSize `fmap` fun "foo_a"+ Prelude.writeFile "test_empty" ""+ y <- Posix.fileSize `fmap` fun "test_empty"+ exist_nonexistent <- Posix.fileExists `fmap` fun "test_does_not_exist"+ exist_existent <- Posix.fileExists `fmap` fun "test_empty"+ assertEqual "file size" x 2+ assertEqual "file size" y 0+ assertBool "existence check" $ not exist_nonexistent+ assertBool "existence check" exist_existent++----------------------------------+-- Arbitrary instances+--++instance (Arbitrary a, Ord a) => Arbitrary (S.Set a)+ where arbitrary = S.fromList `fmap` arbitrary++instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v)+ where arbitrary = M.fromList `fmap` arbitrary++instance Arbitrary BL.ByteString where+ arbitrary = BL.pack `fmap` arbitrary++instance Arbitrary Hash where+ arbitrary = sized hash'+ where hash' 0 = return NoHash+ hash' _ = do+ tag <- oneof [return False, return True]+ case tag of+ False -> SHA256 . BS.pack <$> sequence [ arbitrary | _ <- [1..32] :: [Int] ]+ True -> SHA1 . BS.pack <$> sequence [ arbitrary | _ <- [1..20] :: [Int] ]++instance (Monad m) => Arbitrary (TreeItem m) where+ arbitrary = sized tree'+ where tree' 0 = oneof [ return (File emptyBlob), return (SubTree emptyTree) ]+ tree' n = oneof [ file n, subtree n ]+ file 0 = return (File emptyBlob)+ file _ = do content <- arbitrary+ return (File $ Blob (return content) NoHash)+ subtree n = do branches <- choose (1, n)+ let sub name = do t <- tree' ((n - 1) `div` branches)+ return (makeName $ show name, t)+ sublist <- mapM sub [0..branches]+ oneof [ tree' 0+ , return (SubTree $ makeTree sublist)+ , return $ (Stub $ return (makeTree sublist)) NoHash ]++instance (Monad m) => Arbitrary (Tree m) where+ arbitrary = do item <- arbitrary+ case item of+ File _ -> arbitrary+ Stub _ _ -> arbitrary+ SubTree t -> return t++data TreeWithPath = TreeWithPath (Tree Identity) AnchoredPath deriving (Show)++instance Arbitrary TreeWithPath where+ arbitrary = do t <- arbitrary+ p <- oneof $ return (AnchoredPath []) :+ (map (return . fst) $ list (runIdentity $ expand t))+ return $ TreeWithPath t p++---------------------------+-- Other instances+--++instance Show (Blob m) where+ show (Blob _ h) = "Blob " ++ show h++instance Show (TreeItem m) where+ show (File f) = "File (" ++ show f ++ ")"+ show (Stub _ h) = "Stub _ " ++ show h+ show (SubTree s) = "SubTree (" ++ show s ++ ")"++instance Show (Tree m) where+ show t = "Tree " ++ show (treeHash t) ++ " { " +++ (concat . intersperse ", " $ itemstrs) ++ " }"+ where itemstrs = map show $ listImmediate t++instance Show (Int -> Int) where+ show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]"+ where val x = show x ++ " -> " ++ show (f x)++-----------------------+-- Test utilities+--++shapeEq :: Tree m -> Tree m -> Bool+shapeEq a b = Just EQ == cmpShape a b++expandedShapeEq :: (Monad m, Functor m) => Tree m -> Tree m -> m Bool+expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b++cmpcat :: [Maybe Ordering] -> Maybe Ordering+cmpcat (x:y:rest) | x == y = cmpcat (x:rest)+ | x == Just EQ = cmpcat (y:rest)+ | y == Just EQ = cmpcat (x:rest)+ | otherwise = Nothing+cmpcat [x] = x+cmpcat [] = Just EQ -- empty things are equal++cmpTree :: (Monad m, Functor m) => Tree m -> Tree m -> m (Maybe Ordering)+cmpTree x y = do x' <- expand x+ y' <- expand y+ con <- contentsEq x' y'+ return $ cmpcat [cmpShape x' y', con]+ where contentsEq a b = cmpcat <$> sequence (zipTrees cmp a b)+ cmp _ (Just (File a)) (Just (File b)) = do a' <- readBlob a+ b' <- readBlob b+ return $ Just (compare a' b')+ cmp _ _ _ = return (Just EQ) -- neutral++cmpShape :: Tree m -> Tree m -> Maybe Ordering+cmpShape t r = cmpcat $ zipTrees cmp t r+ where cmp _ (Just a) (Just b) = a `item` b+ cmp _ Nothing (Just _) = Just LT+ cmp _ (Just _) Nothing = Just GT+ cmp _ Nothing Nothing = Just EQ+ item (File _) (File _) = Just EQ+ item (SubTree s) (SubTree p) = s `cmpShape` p+ item _ _ = Nothing++cmpExpandedShape :: (Monad m) => Tree m -> Tree m -> m (Maybe Ordering)+cmpExpandedShape a b = do x <- expand a+ y <- expand b+ return $ x `cmpShape` y++nondarcs :: AnchoredPath -> TreeItem m -> Bool+nondarcs (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False+ | otherwise = True+nondarcs (AnchoredPath []) _ = True++readDarcsPristine :: FilePath -> IO (Tree IO)+readDarcsPristine dir = do+ let darcs = dir </> "_darcs"+ h_inventory = darcs </> "hashed_inventory"+ repo <- doesDirectoryExist darcs+ unless repo $ fail $ "Not a darcs repository: " ++ dir+ isHashed <- doesFileExist h_inventory+ if isHashed+ then do inv <- BS.readFile h_inventory+ let thelines = BS.split '\n' inv+ case thelines of+ [] -> return emptyTree+ (pris_line:_) -> do+ let thehash = decodeDarcsHash $ BS.drop 9 pris_line+ thesize = decodeDarcsSize $ BS.drop 9 pris_line+ when (thehash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line+ readDarcsHashed (darcs </> "pristine.hashed") (thesize, thehash)+ else do have_pristine <- doesDirectoryExist $ darcs </> "pristine"+ have_current <- doesDirectoryExist $ darcs </> "current"+ case (have_pristine, have_current) of+ (True, _) -> readPlainTree $ darcs </> "pristine"+ (False, True) -> readPlainTree $ darcs </> "current"+ (_, _) -> fail "No pristine tree is available!"
+ hashed-storage/Storage/Hashed/Tree.hs view
@@ -0,0 +1,464 @@+{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, BangPatterns #-}++-- | The abstract representation of a Tree and useful abstract utilities to+-- handle those.+module Storage.Hashed.Tree+ ( Tree, Blob(..), TreeItem(..), ItemType(..), Hash(..)+ , makeTree, makeTreeWithHash, emptyTree, emptyBlob, makeBlob, makeBlobBS++ -- * Unfolding stubbed (lazy) Trees.+ --+ -- | By default, Tree obtained by a read function is stubbed: it will+ -- contain Stub items that need to be executed in order to access the+ -- respective subtrees. 'expand' will produce an unstubbed Tree.+ , expandUpdate, expand, expandPath, checkExpand++ -- * Tree access and lookup.+ , items, list, listImmediate, treeHash+ , lookup, find, findFile, findTree, itemHash, itemType+ , zipCommonFiles, zipFiles, zipTrees, diffTrees++ -- * Files (Blobs).+ , readBlob++ -- * Filtering trees.+ , FilterTree(..), restrict++ -- * Manipulating trees.+ , modifyTree, updateTree, partiallyUpdateTree, updateSubtrees, overlay+ , addMissingHashes ) where++import Control.Exception( catch, IOException )+import Prelude hiding( lookup, filter, all, catch )+import Storage.Hashed.AnchoredPath+import Storage.Hashed.Hash++import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as BS+import qualified Data.Map as M++import Data.Maybe( catMaybes, isNothing )+import Data.Either( lefts, rights )+import Data.List( union, sort )+import Control.Monad( filterM )+import Control.Applicative( (<$>) )++--------------------------------+-- Tree, Blob and friends+--++data Blob m = Blob !(m BL.ByteString) !Hash+data TreeItem m = File !(Blob m)+ | SubTree !(Tree m)+ | Stub !(m (Tree m)) !Hash++data ItemType = TreeType | BlobType deriving (Show, Eq, Ord)++-- | Abstraction of a filesystem tree.+-- Please note that the Tree returned by the respective read operations will+-- have TreeStub items in it. To obtain a Tree without such stubs, call+-- expand on it, eg.:+--+-- > tree <- readDarcsPristine "." >>= expand+--+-- When a Tree is expanded, it becomes \"final\". All stubs are forced and the+-- Tree can be traversed purely. Access to actual file contents stays in IO+-- though.+--+-- A Tree may have a Hash associated with it. A pair of Tree's is identical+-- whenever their hashes are (the reverse need not hold, since not all Trees+-- come equipped with a hash).+data Tree m = Tree { items :: (M.Map Name (TreeItem m))+ -- | Get hash of a Tree. This is guaranteed to uniquely+ -- identify the Tree (including any blob content), as far as+ -- cryptographic hashes are concerned. Sha256 is recommended.+ , treeHash :: !Hash }++listImmediate :: Tree m -> [(Name, TreeItem m)]+listImmediate = M.toList . items++-- | Get a hash of a TreeItem. May be Nothing.+itemHash :: TreeItem m -> Hash+itemHash (File (Blob _ h)) = h+itemHash (SubTree t) = treeHash t+itemHash (Stub _ h) = h++itemType :: TreeItem m -> ItemType+itemType (File _) = BlobType+itemType (SubTree _) = TreeType+itemType (Stub _ _) = TreeType++emptyTree :: (Monad m) => Tree m+emptyTree = Tree { items = M.empty+ , treeHash = NoHash }++emptyBlob :: (Monad m) => Blob m+emptyBlob = Blob (return BL.empty) NoHash++makeBlob :: (Monad m) => BL.ByteString -> Blob m+makeBlob str = Blob (return str) (sha256 str)++makeBlobBS :: (Monad m) => BS.ByteString -> Blob m+makeBlobBS s' = let s = BL.fromChunks [s'] in Blob (return s) (sha256 s)++makeTree :: (Monad m) => [(Name,TreeItem m)] -> Tree m+makeTree l = Tree { items = M.fromList l+ , treeHash = NoHash }++makeTreeWithHash :: (Monad m) => [(Name,TreeItem m)] -> Hash -> Tree m+makeTreeWithHash l h = Tree { items = M.fromList l+ , treeHash = h }++-----------------------------------+-- Tree access and lookup+--++-- | Look up a 'Tree' item (an immediate subtree or blob).+lookup :: Tree m -> Name -> Maybe (TreeItem m)+lookup t n = M.lookup n (items t)++find' :: TreeItem m -> AnchoredPath -> Maybe (TreeItem m)+find' t (AnchoredPath []) = Just t+find' (SubTree t) (AnchoredPath (d : rest)) =+ case lookup t d of+ Just sub -> find' sub (AnchoredPath rest)+ Nothing -> Nothing+find' _ _ = Nothing++-- | Find a 'TreeItem' by its path. Gives 'Nothing' if the path is invalid.+find :: Tree m -> AnchoredPath -> Maybe (TreeItem m)+find = find' . SubTree++-- | Find a 'Blob' by its path. Gives 'Nothing' if the path is invalid, or does+-- not point to a Blob.+findFile :: Tree m -> AnchoredPath -> Maybe (Blob m)+findFile t p = case find t p of+ Just (File x) -> Just x+ _ -> Nothing++-- | Find a 'Tree' by its path. Gives 'Nothing' if the path is invalid, or does+-- not point to a Tree.+findTree :: Tree m -> AnchoredPath -> Maybe (Tree m)+findTree t p = case find t p of+ Just (SubTree x) -> Just x+ _ -> Nothing++-- | List all contents of a 'Tree'.+list :: Tree m -> [(AnchoredPath, TreeItem m)]+list t_ = paths t_ (AnchoredPath [])+ where paths t p = [ (appendPath p n, i)+ | (n,i) <- listImmediate t ] +++ concat [ paths subt (appendPath p subn)+ | (subn, SubTree subt) <- listImmediate t ]++expandUpdate :: (Monad m) => (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m)+expandUpdate update t_ = go (AnchoredPath []) t_+ where go path t = do+ let subtree (name, sub) = do tree <- go (path `appendPath` name) =<< unstub sub+ return (name, SubTree tree)+ expanded <- mapM subtree [ x | x@(_, item) <- listImmediate t, isSub item ]+ let orig_map = M.filter (not . isSub) (items t)+ expanded_map = M.fromList expanded+ tree = t { items = M.union orig_map expanded_map }+ update path tree++-- | Expand a stubbed Tree into a one with no stubs in it. You might want to+-- filter the tree before expanding to save IO. This is the basic+-- implementation, which may be overriden by some Tree instances (this is+-- especially true of the Index case).+expand :: (Monad m) => Tree m -> m (Tree m)+expand = expandUpdate $ \_ -> return++-- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is+-- reachable without crossing any stubs. Moreover, the leaf ought not be a Stub+-- in the resulting Tree. A non-existent path is expanded as far as it can be.+expandPath :: (Monad m) => Tree m -> AnchoredPath -> m (Tree m)+expandPath t_ path_ = expand' t_ path_+ where expand' t (AnchoredPath []) = return t+ expand' t (AnchoredPath (n:rest)) =+ case lookup t n of+ (Just item) | isSub item -> amend t n rest =<< unstub item+ _ -> return t -- fail $ "Descent error in expandPath: " ++ show path_+ amend t name rest sub = do+ sub' <- expand' sub (AnchoredPath rest)+ let tree = t { items = M.insert name (SubTree sub') (items t) }+ return tree++-- | Check the disk version of a Tree: expands it, and checks each+-- hash. Returns either the expanded tree or a list of AnchoredPaths+-- where there are problems. The first argument is the hashing function+-- used to create the tree.+checkExpand :: (TreeItem IO -> IO Hash) -> Tree IO+ -> IO (Either [(AnchoredPath, Hash, Maybe Hash)] (Tree IO))+checkExpand hashFunc t = go (AnchoredPath []) t+ where+ go path t_ = do+ let+ subtree (name, sub) =+ do let here = path `appendPath` name+ sub' <- (Just <$> unstub sub) `catch` \(_ :: IOException) -> return Nothing+ case sub' of+ Nothing -> return $ Left [(here, treeHash t_, Nothing)]+ Just sub'' -> do+ treeOrTrouble <- go (path `appendPath` name) sub''+ return $ case treeOrTrouble of+ Left problems -> Left problems+ Right tree -> Right (name, SubTree tree)+ badBlob (_, f@(File (Blob _ h))) =+ fmap (/= h) (hashFunc f `catch` (\(_ :: IOException) -> return NoHash))+ badBlob _ = return False+ render (name, f@(File (Blob _ h))) = do+ h' <- (Just <$> hashFunc f) `catch` \(_ :: IOException) -> return Nothing+ return (path `appendPath` name, h, h')+ render (name, _) = return (path `appendPath` name, NoHash, Nothing)+ subs <- mapM subtree [ x | x@(_, item) <- listImmediate t_, isSub item ]+ badBlobs <- filterM badBlob (listImmediate t) >>= mapM render+ let problems = badBlobs ++ (concat $ lefts subs)+ if null problems+ then do+ let orig_map = M.filter (not . isSub) (items t)+ expanded_map = M.fromList $ rights subs+ tree = t_ {items = orig_map `M.union` expanded_map}+ h' <- hashFunc (SubTree t_)+ if h' `match` treeHash t_+ then return $ Right tree+ else return $ Left [(path, treeHash t_, Just h')]+ else return $ Left problems++class (Monad m) => FilterTree a m where+ -- | Given @pred tree@, produce a 'Tree' that only has items for which+ -- @pred@ returns @True@.+ -- The tree might contain stubs. When expanded, these will be subject to+ -- filtering as well.+ filter :: (AnchoredPath -> TreeItem m -> Bool) -> a m -> a m++instance (Monad m) => FilterTree Tree m where+ filter predicate t_ = filter' t_ (AnchoredPath [])+ where filter' t path = t { items = M.mapMaybeWithKey (wibble path) $ items t }+ wibble path name item =+ let npath = path `appendPath` name in+ if predicate npath item+ then Just $ filterSub npath item+ else Nothing+ filterSub npath (SubTree t) = SubTree $ filter' t npath+ filterSub npath (Stub stub h) =+ Stub (do x <- stub+ return $ filter' x npath) h+ filterSub _ x = x++-- | Given two Trees, a @guide@ and a @tree@, produces a new Tree that is a+-- identical to @tree@, but only has those items that are present in both+-- @tree@ and @guide@. The @guide@ Tree may not contain any stubs.+restrict :: (FilterTree t m, Monad n) => Tree n -> t m -> t m+restrict guide tree = filter accept tree+ where accept path item =+ case (find guide path, item) of+ (Just (SubTree _), SubTree _) -> True+ (Just (SubTree _), Stub _ _) -> True+ (Just (File _), File _) -> True+ (Just (Stub _ _), _) ->+ error "*sulk* Go away, you, you precondition violator!"+ (_, _) -> False++-- | Read a Blob into a Lazy ByteString. Might be backed by an mmap, use with+-- care.+readBlob :: Blob m -> m BL.ByteString+readBlob (Blob r _) = r++-- | For every pair of corresponding blobs from the two supplied trees,+-- evaluate the supplied function and accumulate the results in a list. Hint:+-- to get IO actions through, just use sequence on the resulting list.+-- NB. This won't expand any stubs.+zipCommonFiles :: (AnchoredPath -> Blob m -> Blob m -> a) -> Tree m -> Tree m -> [a]+zipCommonFiles f a b = catMaybes [ flip (f p) x `fmap` findFile a p+ | (p, File x) <- list b ]++-- | For each file in each of the two supplied trees, evaluate the supplied+-- function (supplying the corresponding file from the other tree, or Nothing)+-- and accumulate the results in a list. Hint: to get IO actions through, just+-- use sequence on the resulting list. NB. This won't expand any stubs.+zipFiles :: (AnchoredPath -> Maybe (Blob m) -> Maybe (Blob m) -> a)+ -> Tree m -> Tree m -> [a]+zipFiles f a b = [ f p (findFile a p) (findFile b p)+ | p <- paths a `sortedUnion` paths b ]+ where paths t = sort [ p | (p, File _) <- list t ]++zipTrees :: (AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a)+ -> Tree m -> Tree m -> [a]+zipTrees f a b = [ f p (find a p) (find b p)+ | p <- reverse (paths a `sortedUnion` paths b) ]+ where paths t = sort [ p | (p, _) <- list t ]++-- | Helper function for taking the union of AnchoredPath lists that+-- are already sorted. This function does not check the precondition+-- so use it carefully.+sortedUnion :: [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]+sortedUnion [] ys = ys+sortedUnion xs [] = xs+sortedUnion a@(x:xs) b@(y:ys) = case compare x y of+ LT -> x : sortedUnion xs b+ EQ -> x : sortedUnion xs ys+ GT -> y : sortedUnion a ys++-- | Cautiously extracts differing subtrees from a pair of Trees. It will never+-- do any unneccessary expanding. Tree hashes are used to cut the comparison as+-- high up the Tree branches as possible. The result is a pair of trees that do+-- not share any identical subtrees. They are derived from the first and second+-- parameters respectively and they are always fully expanded. It might be+-- advantageous to feed the result into 'zipFiles' or 'zipTrees'.+diffTrees :: forall m. (Functor m, Monad m) => Tree m -> Tree m -> m (Tree m, Tree m)+diffTrees left right =+ if treeHash left `match` treeHash right+ then return (emptyTree, emptyTree)+ else diff left right+ where isFile (File _) = True+ isFile _ = False+ notFile = not . isFile+ isEmpty = null . listImmediate+ subtree :: TreeItem m -> m (Tree m)+ subtree (Stub x _) = x+ subtree (SubTree x) = return x+ subtree (File _) = error "diffTrees tried to descend a File as a subtree"+ maybeUnfold (Stub x _) = SubTree `fmap` (x >>= expand)+ maybeUnfold (SubTree x) = SubTree `fmap` expand x+ maybeUnfold i = return i+ immediateN t = [ n | (n, _) <- listImmediate t ]+ diff left' right' = do+ is <- sequence [+ case (lookup left' n, lookup right' n) of+ (Just l, Nothing) -> do+ l' <- maybeUnfold l+ return (n, Just l', Nothing)+ (Nothing, Just r) -> do+ r' <- maybeUnfold r+ return (n, Nothing, Just r')+ (Just l, Just r)+ | itemHash l `match` itemHash r ->+ return (n, Nothing, Nothing)+ | notFile l && notFile r ->+ do x <- subtree l+ y <- subtree r+ (x', y') <- diffTrees x y+ if isEmpty x' && isEmpty y'+ then return (n, Nothing, Nothing)+ else return (n, Just $ SubTree x', Just $ SubTree y')+ | isFile l && isFile r ->+ return (n, Just l, Just r)+ | otherwise ->+ do l' <- maybeUnfold l+ r' <- maybeUnfold r+ return (n, Just l', Just r')+ _ -> error "n lookups failed"+ | n <- immediateN left' `union` immediateN right' ]+ let is_l = [ (n, l) | (n, Just l, _) <- is ]+ is_r = [ (n, r) | (n, _, Just r) <- is ]+ return (makeTree is_l, makeTree is_r)++-- | Modify a Tree (by replacing, or removing or adding items).+modifyTree :: (Monad m) => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m+modifyTree t_ p_ i_ = snd $ go t_ p_ i_+ where fix t unmod items' = (unmod, t { items = (countmap items':: Int) `seq` items'+ , treeHash = if unmod then treeHash t else NoHash })++ go t (AnchoredPath []) (Just (SubTree sub)) = (treeHash t `match` treeHash sub, sub)++ go t (AnchoredPath [n]) (Just item) = fix t unmod items'+ where !items' = M.insert n item (items t)+ !unmod = itemHash item `match` case lookup t n of+ Nothing -> NoHash+ Just i -> itemHash i++ go t (AnchoredPath [n]) Nothing = fix t unmod items'+ where !items' = M.delete n (items t)+ !unmod = isNothing $ lookup t n++ go t path@(AnchoredPath (n:r)) item = fix t unmod items'+ where subtree s = go s (AnchoredPath r) item+ !items' = M.insert n sub (items t)+ !sub = snd sub'+ !unmod = fst sub'+ !sub' = case lookup t n of+ Just (SubTree s) -> let (mod', sub'') = subtree s in (mod', SubTree sub'')+ Just (Stub s _) -> (False, Stub (do x <- s+ return $! snd $! subtree x) NoHash)+ Nothing -> (False, SubTree $! snd $! subtree emptyTree)+ _ -> error $ "Modify tree at " ++ show path++ go _ (AnchoredPath []) (Just (Stub _ _)) =+ error $ "BUG: Error descending in modifyTree, path = " ++ show p_+ go _ (AnchoredPath []) (Just (File _)) =+ error $ "BUG: Error descending in modifyTree, path = " ++ show p_+ go _ (AnchoredPath []) Nothing =+ error $ "BUG: Error descending in modifyTree, path = " ++ show p_++countmap :: forall a k. M.Map k a -> Int+countmap = M.fold (\_ i -> i + 1) 0++updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m+updateSubtrees fun t =+ fun $ t { items = M.mapWithKey (curry $ snd . update) $ items t+ , treeHash = NoHash }+ where update (k, SubTree s) = (k, SubTree $ updateSubtrees fun s)+ update (k, File f) = (k, File f)+ update (_, Stub _ _) = error "Stubs not supported in updateTreePostorder"++-- | Does /not/ expand the tree.+updateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m)+updateTree fun t = partiallyUpdateTree fun (\_ _ -> True) t++-- | Does /not/ expand the tree.+partiallyUpdateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m))+ -> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m)+partiallyUpdateTree fun predi t' = go (AnchoredPath []) t'+ where go path t = do+ items' <- M.fromList <$> mapM (maybeupdate path) (listImmediate t)+ SubTree t'' <- fun . SubTree $ t { items = items'+ , treeHash = NoHash }+ return t''+ maybeupdate path (k, item) = case predi (path `appendPath` k) item of+ True -> update (path `appendPath` k) (k, item)+ False -> return (k, item)+ update path (k, SubTree tree) = (\new -> (k, SubTree new)) <$> go path tree+ update _ (k, item) = (\new -> (k, new)) <$> fun item++-- | Lay one tree over another. The resulting Tree will look like the base (1st+-- parameter) Tree, although any items also present in the overlay Tree will be+-- taken from the overlay. It is not allowed to overlay a different kind of an+-- object, nor it is allowed for the overlay to add new objects to base. This+-- means that the overlay Tree should be a subset of the base Tree (although+-- any extraneous items will be ignored by the implementation).+overlay :: (Functor m, Monad m) => Tree m -> Tree m -> Tree m+overlay base over = Tree { items = M.fromList immediate+ , treeHash = NoHash }+ where immediate = [ (n, get n) | (n, _) <- listImmediate base ]+ get n = case (M.lookup n $ items base, M.lookup n $ items over) of+ (Just (File _), Just f@(File _)) -> f+ (Just (SubTree b), Just (SubTree o)) -> SubTree $ overlay b o+ (Just (Stub b _), Just (SubTree o)) -> Stub (flip overlay o `fmap` b) NoHash+ (Just (SubTree b), Just (Stub o _)) -> Stub (overlay b `fmap` o) NoHash+ (Just (Stub b _), Just (Stub o _)) -> Stub (do o' <- o+ b' <- b+ return $ overlay b' o') NoHash+ (Just x, _) -> x+ (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "."++addMissingHashes :: (Monad m, Functor m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m)+addMissingHashes make = updateTree update -- use partiallyUpdateTree here+ where update (SubTree t) = make (SubTree t) >>= \x -> return $ SubTree (t { treeHash = x })+ update (File blob@(Blob con NoHash)) =+ do hash <- make $ File blob+ return $ File (Blob con hash)+ update (Stub s NoHash) = update . SubTree =<< s+ update x = return x++------ Private utilities shared among multiple functions. --------++unstub :: (Monad m) => TreeItem m -> m (Tree m)+unstub (Stub s _) = s+unstub (SubTree s) = return s+unstub _ = return emptyTree++isSub :: TreeItem m -> Bool+isSub (File _) = False+isSub _ = True+
+ hashed-storage/Storage/Hashed/Utils.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-}++-- | Mostly internal utilities for use by the rest of the library. Subject to+-- removal without further notice.+module Storage.Hashed.Utils where++import Prelude hiding ( lookup, catch )+import System.Mem( performGC )+import Bundled.Posix( getFileStatus, fileSize )+import System.Directory( getCurrentDirectory, setCurrentDirectory )+import System.FilePath( (</>), isAbsolute )+import Data.Int( Int64 )+import Data.Maybe( catMaybes )+import Control.Exception( catch, bracket, SomeException(..) )+import Control.Monad( when )+import Control.Monad.Identity( runIdentity )+import Control.Applicative( (<$>) )++import Foreign.ForeignPtr( withForeignPtr )+import Foreign.Ptr( plusPtr )+import Data.ByteString.Internal( toForeignPtr, memcpy )+import System.IO (withFile, IOMode(ReadMode), hSeek, SeekMode(AbsoluteSeek))+import Data.Bits( Bits )+#ifdef BIGENDIAN+import Data.Bits( (.&.), (.|.), shift, shiftL, rotateR )+#endif++import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString as BS++import qualified Data.Set as S+import qualified Data.Map as M++-- | Pointer to a filesystem, possibly with start/end offsets. Supposed to be+-- fed to (uncurry mmapFileByteString) or similar.+type FileSegment = (FilePath, Maybe (Int64, Int))++-- | Read in a FileSegment into a Lazy ByteString. Implemented using mmap.+readSegment :: FileSegment -> IO BL.ByteString+readSegment (f,range) = do+ bs <- tryToRead+ `catch` (\(_::SomeException) -> do+ size <- fileSize `fmap` getFileStatus f+ if size == 0+ then return BS8.empty+ else performGC >> tryToRead)+ return $ BL.fromChunks [bs]+ where+ tryToRead = do + case range of+ Nothing -> BS.readFile f+ Just (off, size) -> withFile f ReadMode $ \h -> do+ hSeek h AbsoluteSeek $ fromIntegral off+ BS.hGet h size +{-# INLINE readSegment #-}++-- | Run an IO action with @path@ as a working directory. Does neccessary+-- bracketing.+withCurrentDirectory :: FilePath -> IO a -> IO a+withCurrentDirectory name =+ bracket+ (do cwd <- getCurrentDirectory+ when (name /= "") (setCurrentDirectory name)+ return cwd)+ (\oldwd -> setCurrentDirectory oldwd+ `catch` \(_::SomeException) -> return ())+ . const++makeAbsolute :: FilePath -> IO FilePath+makeAbsolute p = do+ cwd <- getCurrentDirectory+ return $! if isAbsolute p then p else cwd </> p++-- Wow, unsafe.+unsafePokeBS :: BS8.ByteString -> BS8.ByteString -> IO ()+unsafePokeBS to from =+ do let (fp_to, off_to, len_to) = toForeignPtr to+ (fp_from, off_from, len_from) = toForeignPtr from+ when (len_to /= len_from) $ fail $ "Length mismatch in unsafePokeBS: from = "+ ++ show len_from ++ " /= to = " ++ show len_to+ withForeignPtr fp_from $ \p_from ->+ withForeignPtr fp_to $ \p_to ->+ memcpy (plusPtr p_to off_to)+ (plusPtr p_from off_from)+ (fromIntegral len_to)++align :: Integral a => a -> a -> a+align boundary i = case i `rem` boundary of+ 0 -> i+ x -> i + boundary - x+{-# INLINE align #-}++xlate32 :: (Bits a) => a -> a+xlate64 :: (Bits a) => a -> a++#ifdef LITTLEENDIAN+xlate32 = id+xlate64 = id+#endif++#ifdef BIGENDIAN+bytemask :: (Bits a) => a+bytemask = 255++xlate32 a = ((a .&. (bytemask `shift` 0)) `shiftL` 24) .|.+ ((a .&. (bytemask `shift` 8)) `shiftL` 8) .|.+ ((a .&. (bytemask `shift` 16)) `rotateR` 8) .|.+ ((a .&. (bytemask `shift` 24)) `rotateR` 24)++xlate64 a = ((a .&. (bytemask `shift` 0)) `shiftL` 56) .|.+ ((a .&. (bytemask `shift` 8)) `shiftL` 40) .|.+ ((a .&. (bytemask `shift` 16)) `shiftL` 24) .|.+ ((a .&. (bytemask `shift` 24)) `shiftL` 8) .|.+ ((a .&. (bytemask `shift` 32)) `rotateR` 8) .|.+ ((a .&. (bytemask `shift` 40)) `rotateR` 24) .|.+ ((a .&. (bytemask `shift` 48)) `rotateR` 40) .|.+ ((a .&. (bytemask `shift` 56)) `rotateR` 56)+#endif++-- | Find a monadic fixed point of @f@ that is the least above @i@. (Will+-- happily diverge if there is none.)+mfixFrom :: (Eq a, Functor m, Monad m) => (a -> m a) -> a -> m a+mfixFrom f i = do x <- f i+ if x == i then return i+ else mfixFrom f x++-- | Find a fixed point of @f@ that is the least above @i@. (Will happily+-- diverge if there is none.)+fixFrom :: (Eq a) => (a -> a) -> a -> a+fixFrom f i = runIdentity $ mfixFrom (return . f) i++-- | For a @refs@ function, a @map@ (@key@ -> @value@) and a @rootSet@, find a+-- submap of @map@ such that all items in @map@ are reachable, through @refs@+-- from @rootSet@.+reachable :: forall monad key value. (Functor monad, Monad monad, Ord key, Eq value) =>+ (value -> monad [key])+ -> (key -> monad (Maybe (key, value)))+ -> S.Set key -> monad (M.Map key value)+reachable refs lookup rootSet =+ do lookupSet rootSet >>= mfixFrom expand+ where lookupSet :: S.Set key -> monad (M.Map key value)+ expand :: M.Map key value -> monad (M.Map key value)++ lookupSet s = do list <- mapM lookup (S.toAscList s)+ return $ M.fromAscList (catMaybes list)+ expand from = do refd <- concat <$> mapM refs (M.elems from)+ M.union from <$> lookupSet (S.fromList refd)
+ hashed-storage/test.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE ScopedTypeVariables #-}+import Storage.Hashed.Test( tests )+import Prelude hiding( catch )+import Test.Framework( defaultMain )+import System.Directory( createDirectory, removeDirectoryRecursive+ , setCurrentDirectory )+import Codec.Archive.Zip( extractFilesFromArchive, toArchive )+import qualified Data.ByteString.Lazy as BL+import Control.Exception( catch, IOException )++main :: IO ()+main = do zipFile <- toArchive `fmap` BL.readFile "hashed-storage/testdata.zip"+ removeDirectoryRecursive "_test_playground" `catch` \(_ :: IOException) -> return ()+ createDirectory "_test_playground"+ setCurrentDirectory "_test_playground"+ extractFilesFromArchive [] zipFile+ defaultMain tests
+ hashed-storage/testdata.zip view
binary file changed (absent → 16669 bytes)
release/distributed-context view
@@ -1,1 +1,1 @@-Just "\nContext:\n\n[TAG 2.8.5\nGanesh Sittampalam <ganesh@earth.li>**20140825204639\n Ignore-this: 4e6c90569ceab19a231cdd4c5089b4c2\n] \n"+Just "\nContext:\n\n[TAG 2.10.0\nGuillaume Hoffmann <guillaumh@gmail.com>**20150419200705\n Ignore-this: 6d154c9aa51c8328c777ca9a2c223125\n] \n"
− src/ByteStringUtils.hs
@@ -1,547 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2-{-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP, ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module : ByteStringUtils--- Copyright : (c) The University of Glasgow 2001,--- David Roundy 2003-2005--- License : GPL (I'm happy to also license this file BSD style but don't--- want to bother distributing two license files with darcs.------ Maintainer : droundy@abridgegame.org--- Stability : experimental--- Portability : portable------ GZIp and MMap IO for ByteStrings, encoding utilities, and miscellaneous--- functions for Data.ByteString-----module ByteStringUtils (-- unsafeWithInternals,- unpackPSFromUTF8,- packStringToUTF8,-- -- IO with mmap or gzip- gzReadFilePS,- mmapFilePS,- gzWriteFilePS,- gzWriteFilePSs,- gzReadStdin,-- -- gzip handling- isGZFile,- gzDecompress,-- -- list utilities- dropSpace,- breakSpace,- linesPS,- unlinesPS,- hashPS,- breakFirstPS,- breakLastPS,- substrPS,- readIntPS,- isFunky,- fromHex2PS,- fromPS2Hex,- betweenLinesPS,- breakAfterNthNewline,- breakBeforeNthNewline,- intercalate,-- -- encoding and unicode utilities- isAscii,- decodeLocale,- encodeLocale,- decodeString- ) where--import Prelude hiding ( catch )-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Internal as BI-import Data.ByteString (intercalate)-import Data.ByteString.Internal (fromForeignPtr)--#if defined (HAVE_MMAP)-import Control.Exception.Extensible ( catch, SomeException )-#endif-import System.IO-import System.IO.Unsafe ( unsafePerformIO )--import Encoding ( decode, encode )--import Foreign.Storable ( peekElemOff, peek )-import Foreign.Marshal.Array ( advancePtr )-import Foreign.C.Types ( CInt(..) )--import Data.Bits ( rotateL )-import Data.Char ( ord, isSpace )-import Data.Word ( Word8 )-import Data.Int ( Int32 )-import qualified Data.Text as T ( pack, unpack )-import Data.Text.Encoding ( encodeUtf8, decodeUtf8With )-import Data.Text.Encoding.Error ( lenientDecode )-import Control.Monad ( when )--import Foreign.Ptr ( plusPtr, Ptr )-import Foreign.ForeignPtr ( withForeignPtr )--#ifdef DEBUG_PS-import Foreign.ForeignPtr ( addForeignPtrFinalizer )-import Foreign.Ptr ( FunPtr )-#endif--import qualified Data.ByteString.Lazy as BL-import qualified Codec.Compression.GZip as GZ-import qualified Codec.Compression.Zlib.Internal as ZI-import Darcs.Global ( addCRCWarning )--#ifdef HAVE_MMAP-import System.IO.MMap( mmapFileByteString )-import System.Mem( performGC )-import System.Posix.Files( fileSize, getSymbolicLinkStatus )-#endif---- -------------------------------------------------------------------------------- obsolete debugging code---- -------------------------------------------------------------------------------- unsafeWithInternals---- | Do something with the internals of a PackedString. Beware of--- altering the contents!-unsafeWithInternals :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a-unsafeWithInternals ps f- = case BI.toForeignPtr ps of- (fp,s,l) -> withForeignPtr fp $ \p -> f (p `plusPtr` s) l---- | readIntPS skips any whitespace at the beginning of its argument, and--- reads an Int from the beginning of the PackedString. If there is no--- integer at the beginning of the string, it returns Nothing, otherwise it--- just returns the int read, along with a B.ByteString containing the--- remainder of its input.--readIntPS :: B.ByteString -> Maybe (Int, B.ByteString)-readIntPS = BC.readInt . BC.dropWhile isSpace---- -------------------------------------------------------------------------------- Destructor functions (taking PackedStrings apart)---- | Decodes a 'ByteString' containing UTF-8 to a 'String'. Decoding errors are--- flagged with the U+FFFD character.-unpackPSFromUTF8 :: B.ByteString -> String-unpackPSFromUTF8 = T.unpack . decodeUtf8With lenientDecode--packStringToUTF8 :: String -> B.ByteString-packStringToUTF8 = encodeUtf8 . T.pack----------------------------------------------------------------------------- A reimplementation of Data.ByteString.Char8.dropSpace, but--- specialised to darcs' need for a 4 way isspace.------ TODO: if it is safe to use the expanded definition of isSpaceWord8--- provided by Data.ByteString.Char8, then all this can go.---- A locale-independent isspace(3) so patches are interpreted the same everywhere.--- ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r')-isSpaceWord8 :: Word8 -> Bool-isSpaceWord8 w =- w == 0x20 || -- ' '- w == 0x09 || -- '\t'- w == 0x0A || -- '\n'- w == 0x0D -- '\r'-{-# INLINE isSpaceWord8 #-}--firstnonspace :: Ptr Word8 -> Int -> Int -> IO Int-firstnonspace !ptr !n !m- | n >= m = return n- | otherwise = do w <- peekElemOff ptr n- if isSpaceWord8 w then firstnonspace ptr (n+1) m else return n--firstspace :: Ptr Word8 -> Int -> Int -> IO Int-firstspace !ptr !n !m- | n >= m = return n- | otherwise = do w <- peekElemOff ptr n- if (not . isSpaceWord8) w then firstspace ptr (n+1) m else return n---- | 'dropSpace' efficiently returns the 'ByteString' argument with--- white space Chars removed from the front. It is more efficient than--- calling dropWhile for removing whitespace. I.e.------ > dropWhile isSpace == dropSpace----dropSpace :: B.ByteString -> B.ByteString-dropSpace (BI.PS x s l) = BI.inlinePerformIO $ withForeignPtr x $ \p -> do- i <- firstnonspace (p `plusPtr` s) 0 l- return $! if i == l then B.empty else BI.PS x (s+i) (l-i)-{-# INLINE dropSpace #-}---- | 'breakSpace' returns the pair of ByteStrings when the argument is--- broken at the first whitespace byte. I.e.------ > break isSpace == breakSpace----breakSpace :: B.ByteString -> (B.ByteString,B.ByteString)-breakSpace (BI.PS x s l) = BI.inlinePerformIO $ withForeignPtr x $ \p -> do- i <- firstspace (p `plusPtr` s) 0 l- return $! case () of {_- | i == 0 -> (B.empty, BI.PS x s l)- | i == l -> (BI.PS x s l, B.empty)- | otherwise -> (BI.PS x s i, BI.PS x (s+i) (l-i))- }-{-# INLINE breakSpace #-}----------------------------------------------------------------------------{-# INLINE isFunky #-}-isFunky :: B.ByteString -> Bool-isFunky ps = case BI.toForeignPtr ps of- (x,s,l) ->- unsafePerformIO $ withForeignPtr x $ \p->- (/=0) `fmap` has_funky_char (p `plusPtr` s) (fromIntegral l)--foreign import ccall unsafe "fpstring.h has_funky_char" has_funky_char- :: Ptr Word8 -> CInt -> IO CInt------------------------------------------------------------------------------ ByteString rewrites break (=='x') to breakByte 'x'--- break ((==) x) = breakChar x--- break (==x) = breakChar x-----{--{-# INLINE breakOnPS #-}-breakOnPS :: Char -> B.ByteString -> (B.ByteString, B.ByteString)-breakOnPS c p = case BC.elemIndex c p of- Nothing -> (p, BC.empty)- Just n -> (B.take n p, B.drop n p)--}--{-# INLINE hashPS #-}-hashPS :: B.ByteString -> Int32-hashPS ps =- case BI.toForeignPtr ps of- (x,s,l) ->- unsafePerformIO $ withForeignPtr x $ \p->- hash (p `plusPtr` s) l--hash :: Ptr Word8 -> Int -> IO Int32-hash ptr len = f (0 :: Int32) ptr len- where f h _ 0 = return h- f h p n = do x <- peek p- let !h' = (fromIntegral x) + (rotateL h 8)- f h' (p `advancePtr` 1) (n-1)--{-# INLINE substrPS #-}-substrPS :: B.ByteString -> B.ByteString -> Maybe Int-substrPS tok str- | B.null tok = Just 0- | B.length tok > B.length str = Nothing- | otherwise = do n <- BC.elemIndex (BC.head tok) str- let ttok = B.tail tok- reststr = B.drop (n+1) str- if ttok == B.take (B.length ttok) reststr- then Just n- else ((n+1)+) `fmap` substrPS tok reststr------------------------------------------------------------------------------ TODO: replace breakFirstPS and breakLastPS with definitions based on--- ByteString's break/breakEnd-{-# INLINE breakFirstPS #-}-breakFirstPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString)-breakFirstPS c p = case BC.elemIndex c p of- Nothing -> Nothing- Just n -> Just (B.take n p, B.drop (n+1) p)--{-# INLINE breakLastPS #-}-breakLastPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString)-breakLastPS c p = case BC.elemIndexEnd c p of- Nothing -> Nothing- Just n -> Just (B.take n p, B.drop (n+1) p)---- TODO: rename-{-# INLINE linesPS #-}-linesPS :: B.ByteString -> [B.ByteString]-linesPS ps- | B.null ps = [B.empty]- | otherwise = BC.split '\n' ps--{- QuickCheck property:--import Test.QuickCheck-import qualified Data.ByteString.Char8 as BC-import Data.Char-instance Arbitrary BC.ByteString where- arbitrary = fmap BC.pack arbitrary-instance Arbitrary Char where- arbitrary = chr `fmap` choose (32,127)-deepCheck = check (defaultConfig { configMaxTest = 10000})-testLines = deepCheck (\x -> (linesPS x == linesPSOld x))-linesPSOld ps = case BC.elemIndex '\n' ps of- Nothing -> [ps]- Just n -> B.take n ps : linesPS (B.drop (n+1) ps) -}--{-| This function acts exactly like the "Prelude" unlines function, or like-"Data.ByteString.Char8" 'unlines', but with one important difference: it will-produce a string which may not end with a newline! That is:--> unlinesPS ["foo", "bar"]--evaluates to \"foo\\nbar\", not \"foo\\nbar\\n\"! This point should hold true for-'linesPS' as well.--TODO: rename this function. -}-unlinesPS :: [B.ByteString] -> B.ByteString-unlinesPS [] = BC.empty-unlinesPS x = BC.init $ BC.unlines x-{-# INLINE unlinesPS #-}-{- QuickCheck property:--testUnlines = deepCheck (\x -> (unlinesPS x == unlinesPSOld x))-unlinesPSOld ss = BC.concat $ intersperse_newlines ss- where intersperse_newlines (a:b:s) = a : newline : intersperse_newlines (b:s)- intersperse_newlines s = s- newline = BC.pack "\n" -}---- -------------------------------------------------------------------------------- gzReadFilePS---- |Decompress the given bytestring into a lazy list of chunks, along with a boolean--- flag indicating (if True) that the CRC was corrupted.--- Inspecting the flag will cause the entire list of chunks to be evaluated (but if--- you throw away the list immediately this should run in constant space).-gzDecompress :: Maybe Int -> BL.ByteString -> ([B.ByteString], Bool)-gzDecompress mbufsize =- -- This is what the code would be without the bad CRC recovery logic:- -- return . BL.toChunks . GZ.decompressWith decompressParams- toListWarn . ZI.decompressWithErrors ZI.gzipFormat decompressParams- where- decompressParams = case mbufsize of- Just bufsize -> GZ.defaultDecompressParams { GZ.decompressBufferSize = bufsize }- Nothing -> GZ.defaultDecompressParams-- toListWarn :: ZI.DecompressStream -> ([B.ByteString], Bool)- toListWarn = foldDecompressStream (\x ~(xs, b) -> (x:xs, b)) ([], False) handleBad-- -- cut and paste from Zlib since it's not currently exported (interface not yet certain)- foldDecompressStream :: (B.ByteString -> a -> a) -> a- -> (ZI.DecompressError -> String -> a)- -> ZI.DecompressStream -> a- foldDecompressStream chunk end err = fold- where- fold ZI.StreamEnd = end- fold (ZI.StreamChunk bs stream) = chunk bs (fold stream)- fold (ZI.StreamError code msg) = err code msg-- -- For a while a bug in darcs caused gzip files with good data but bad CRCs to be- -- produced. Trap bad CRC messages, run the specified action to report that it happened,- -- but continue on the assumption that the data is valid.- handleBad ZI.DataError "incorrect data check" = ([], True)- handleBad _ msg = error msg--isGZFile :: FilePath -> IO (Maybe Int)-isGZFile f = do- h <- openBinaryFile f ReadMode- header <- B.hGet h 2- if header /= BC.pack "\31\139"- then do hClose h- return Nothing- else do hSeek h SeekFromEnd (-4)- len <- hGetLittleEndInt h- hClose h- return (Just len)---- | Read an entire file, which may or may not be gzip compressed, directly--- into a 'B.ByteString'.-gzReadFilePS :: FilePath -> IO B.ByteString-gzReadFilePS f = do- mlen <- isGZFile f- case mlen of- Nothing -> mmapFilePS f- Just len ->- do -- Passing the length to gzDecompress means that it produces produces one chunk,- -- which in turn means that B.concat won't need to copy data.- -- If the length is wrong this will just affect efficiency, not correctness- let doDecompress buf = let (res, bad) = gzDecompress (Just len) buf- in do when bad $ addCRCWarning f- return res- compressed <- (BL.fromChunks . return) `fmap` mmapFilePS f- B.concat `fmap` doDecompress compressed--hGetLittleEndInt :: Handle -> IO Int-hGetLittleEndInt h = do- b1 <- ord `fmap` hGetChar h- b2 <- ord `fmap` hGetChar h- b3 <- ord `fmap` hGetChar h- b4 <- ord `fmap` hGetChar h- return $ b1 + 256*b2 + 65536*b3 + 16777216*b4--gzWriteFilePS :: FilePath -> B.ByteString -> IO ()-gzWriteFilePS f ps = gzWriteFilePSs f [ps]--gzWriteFilePSs :: FilePath -> [B.ByteString] -> IO ()-gzWriteFilePSs f pss =- BL.writeFile f $ GZ.compress $ BL.fromChunks pss---- | Read standard input, which may or may not be gzip compressed, directly--- into a 'B.ByteString'.-gzReadStdin :: IO B.ByteString-gzReadStdin = do header <- B.hGet stdin 2- rest <- B.hGetContents stdin- let allStdin = B.concat [header,rest]- return $- if header /= BC.pack "\31\139"- then allStdin- else let decompress = fst . gzDecompress Nothing- compressed = BL.fromChunks [allStdin]- in- B.concat $ decompress compressed---- -------------------------------------------------------------------------------- mmapFilePS---- | Like readFilePS, this reads an entire file directly into a--- 'B.ByteString', but it is even more efficient. It involves directly--- mapping the file to memory. This has the advantage that the contents of--- the file never need to be copied. Also, under memory pressure the page--- may simply be discarded, wile in the case of readFilePS it would need to--- be written to swap. If you read many small files, mmapFilePS will be--- less memory-efficient than readFilePS, since each mmapFilePS takes up a--- separate page of memory. Also, you can run into bus errors if the file--- is modified. NOTE: as with 'readFilePS', the string representation in--- the file is assumed to be ISO-8859-1.--mmapFilePS :: FilePath -> IO B.ByteString-#ifdef HAVE_MMAP-mmapFilePS f = do- x <- mmapFileByteString f Nothing- `catch` (\(_ :: SomeException) -> do- size <- fileSize `fmap` getSymbolicLinkStatus f- if size == 0- then return B.empty- else performGC >> mmapFileByteString f Nothing)- return x-#else-mmapFilePS = B.readFile-#endif---- ---------------------------------------------------------------------------- fromPS2Hex--foreign import ccall unsafe "static fpstring.h conv_to_hex" conv_to_hex- :: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()--fromPS2Hex :: B.ByteString -> B.ByteString-fromPS2Hex ps = case BI.toForeignPtr ps of- (x,s,l) ->- BI.unsafeCreate (2*l) $ \p -> withForeignPtr x $ \f ->- conv_to_hex p (f `plusPtr` s) $ fromIntegral l---- ---------------------------------------------------------------------------- fromHex2PS--foreign import ccall unsafe "static fpstring.h conv_from_hex" conv_from_hex- :: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()--fromHex2PS :: B.ByteString -> B.ByteString-fromHex2PS ps = case BI.toForeignPtr ps of- (x,s,l) ->- BI.unsafeCreate (l `div` 2) $ \p -> withForeignPtr x $ \f ->- conv_from_hex p (f `plusPtr` s) (fromIntegral $ l `div` 2)---- ---------------------------------------------------------------------------- betweenLinesPS---- | betweenLinesPS returns the B.ByteString between the two lines given,--- or Nothing if they do not appear.--betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString- -> Maybe (B.ByteString)-betweenLinesPS start end ps- = case break (start ==) (linesPS ps) of- (_, _:rest@(bs1:_)) ->- case BI.toForeignPtr bs1 of- (ps1,s1,_) ->- case break (end ==) rest of- (_, bs2:_) -> case BI.toForeignPtr bs2 of (_,s2,_) -> Just $ fromForeignPtr ps1 s1 (s2 - s1)- _ -> Nothing- _ -> Nothing---- ---------------------------------------------------------------------------- breakAfterNthNewline--breakAfterNthNewline :: Int -> B.ByteString- -> Maybe (B.ByteString, B.ByteString)-breakAfterNthNewline 0 the_ps | B.null the_ps = Just (B.empty, B.empty)-breakAfterNthNewline n the_ps =- case BI.toForeignPtr the_ps of- (fp,the_s,l) ->- unsafePerformIO $ withForeignPtr fp $ \p ->- do let findit 0 s | s == end = return $ Just (the_ps, B.empty)- findit _ s | s == end = return Nothing- findit 0 s = let left_l = s - the_s- in return $ Just (fromForeignPtr fp the_s left_l,- fromForeignPtr fp s (l - left_l))- findit i s = do w <- peekElemOff p s- if w == nl then findit (i-1) (s+1)- else findit i (s+1)- nl = BI.c2w '\n'- end = the_s + l- findit n the_s---- ---------------------------------------------------------------------------- breakBeforeNthNewline--breakBeforeNthNewline :: Int -> B.ByteString -> (B.ByteString, B.ByteString)-breakBeforeNthNewline 0 the_ps- | B.null the_ps = (B.empty, B.empty)-breakBeforeNthNewline n the_ps =- case BI.toForeignPtr the_ps of- (fp,the_s,l) ->- unsafePerformIO $ withForeignPtr fp $ \p ->- do let findit _ s | s == end = return (the_ps, B.empty)- findit i s = do w <- peekElemOff p s- if w == nl- then if i == 0- then let left_l = s - the_s- in return (fromForeignPtr fp the_s left_l,- fromForeignPtr fp s (l - left_l))- else findit (i-1) (s+1)- else findit i (s+1)- nl = BI.c2w '\n'- end = the_s + l- findit n the_s---- | Test if a ByteString is made of ascii characters-isAscii :: B.ByteString -> Bool-isAscii = B.all (\w -> w < 128)---- | Decode a ByteString to a String according to the current locale--- unsafePerformIO in the locale function is ratified by the fact that GHC 6.12--- 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 = 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--- than 255, its byte becomes the character value modulo 256)-encodeLatin1 :: String -> B.ByteString-encodeLatin1 = B.pack . (map (fromIntegral . ord))---- | Encode a String to a ByteString according to the current locale-encodeLocale :: String -> B.ByteString-encodeLocale = unsafePerformIO . encode---- | Take a @String@ that represents byte values and re-decode it acording to--- the current locale.-decodeString :: String -> String-decodeString = decodeLocale . encodeLatin1--
− src/CommandLine.hs
@@ -1,140 +0,0 @@--- Copyright (C) 2005 Benedikt Schmidt------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- |--- Module : CommandLine--- Copyright : 2005 Benedikt Schmidt--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable------ |A parser for commandlines, returns an arg list and expands--- format strings given in a translation table. Additionally--- the commandline can end with "%<" specifying that the command--- expects input on stdin.------ Some tests for the parser.------ > formatTable = [('s',"<insert subject here>"),--- > ('a',"<insert author here>")]--- >--- > testParser :: (Show a, Eq a) => Parser a -> String -> a -> a--- > testParser p s ok = case parse p "" s of--- > Left e -> error $ "Parser failed with: " ++ (show e)--- > Right res -> if res == ok--- > then res--- > else error $ "Parser failed: got "--- > ++ (show res) ++ ", expected "--- > ++ (show ok)--- >--- > testCases = [("a b",(["a","b"], False)),--- > ("a b %<",(["a","b"], True)),--- > ("a b %< ",(["a","b"], True)),--- > ("\"arg0 contains spaces \\\"quotes\\\"\" b",--- > (["arg0 contains spaces \"quotes\"","b"],False)),--- > ("a %s %<",(["a","<insert subject here>"], True))]--- >--- > runTests = map (uncurry $ testParser (commandline formatTable)) testCases--module CommandLine- ( parseCmd- , addUrlencoded- ) where--import Control.Arrow ( (***) )-import Data.Char ( ord, intToDigit, toUpper )-import Data.List ( find )-import Text.ParserCombinators.Parsec---- | assoc list mapping characters to strings--- eg (c,s) means that %c is replaced by s-type FTable = [(Char,String)]--commandline :: FTable -> Parser ([String], Bool)-commandline ftable = consumeAll $ do- l <- sepEndBy1 (arg ftable) (try separator)- redir <- formatRedir- spaces- return (l,redir)--arg :: FTable -> Parser String-arg ftable = quotedArg ftable <|> unquotedArg ftable--unquotedArg :: FTable -> Parser String-unquotedArg ftable = try (format ftable) <|> many1 (noneOf " \t\"%")--quotedArg :: FTable -> Parser String-quotedArg ftable = between quoteChar quoteChar $ quoteContent ftable- where- quoteChar = char '"'--quoteContent :: FTable -> Parser String-quoteContent ftable = do s1 <- escape- <|> try (format ftable)- <|> many1 (noneOf "\"\\%")- s2 <- quoteContent ftable- return $ s1 ++ s2- <|> return ""--formatRedir :: Parser Bool-formatRedir = (string "%<" >> return True)- <|> return False--format :: FTable -> Parser String-format ftable = do _ <- char '%'- c <- oneOf (map fst ftable)- return $ expandFormat ftable c--escape :: Parser String-escape = do _ <- char '\\'- c <- anyChar- return [c]--consumeAll :: Parser a -> Parser a-consumeAll p = do r <- p- eof- return r--separator :: Parser ()-separator = skipMany1 space--expandFormat :: FTable -> Char -> String-expandFormat ftable c = case find ((==c) . fst) ftable of- Just (_,s) -> s- Nothing -> error "impossible"---- | parse a commandline returning a list of strings--- (intended to be used as argv) and a bool value which--- specifies if the command expects input on stdin--- format specifiers with a mapping in ftable are accepted--- and replaced by the given strings. E.g. if the ftable is--- [('s',"Some subject")], then "%s" is replaced by "Some subject"-parseCmd :: FTable -> String -> Either ParseError ([String],Bool)-parseCmd ftable = parse (commandline ftable) ""--urlEncode :: String -> String-urlEncode s = concatMap escapeC s- where escapeC x = if allowed x then [x] else '%' : intToHex (ord x)- intToHex i = map intToDigit [i `div` 16, i `mod` 16]- allowed x = x `elem` allowedChars- allowedChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "!'()*-.~"---- | for every mapping (c,s), add a mapping with uppercase c--- and the urlencoded string s-addUrlencoded :: FTable -> FTable-addUrlencoded ftable = ftable ++ map (toUpper *** urlEncode) ftable
− src/Crypt/SHA256.hs
@@ -1,45 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}---- |--- Module: Data.Digest.SHA256--- Copyright: Zooko O'Whielacronx--- License: GPL------ Stability: experimental---- ByteString-based, zero-copying binding to Crypto++'s sha interface---- thanks to Don Stewart <dons@galois.com>, Matthew Sackman--- <matthew@wellquite.org>, Brian O'Sullivan, lispy, Adam Langley--module Crypt.SHA256 ( sha256sum ) where--import Foreign hiding ( unsafePerformIO )-import Foreign.C.Types-import Numeric (showHex)-import Foreign.C.String ( withCString )-import Data.ByteString.Unsafe (unsafeUseAsCStringLen)-import qualified Data.ByteString as B-import System.IO.Unsafe ( unsafePerformIO )--sha256sum :: B.ByteString -> String-sha256sum p = unsafePerformIO $- withCString (take 64 $ repeat 'x') $ \digestCString ->- unsafeUseAsCStringLen p $ \(ptr,n) ->- do let digest = castPtr digestCString :: Ptr Word8- c_sha256 ptr (fromIntegral n) digest- go digest 0 []- where -- print it in 0-padded hex format- go :: Ptr Word8 -> Int -> [String] -> IO String- go q n acc | seq q n >= 32 = return $ concat (reverse acc)- | otherwise = do w <- peekElemOff q n- go q (n+1) (draw w : acc)- draw w = case showHex w [] of- [x] -> ['0', x]- x -> x---- void sha256sum(const unsigned char *d, size_t n, unsigned char *md);----foreign import ccall unsafe "sha2.h darcs_sha256" c_sha256- :: Ptr CChar -> CSize -> Ptr Word8 -> IO ()-
− src/Crypt/sha2.c
@@ -1,949 +0,0 @@-/*- * FIPS 180-2 SHA-224/256/384/512 implementation- * Last update: 02/02/2007- * Issue date: 04/30/2005- *- * Copyright (C) 2005, 2007 Olivier Gay <olivier.gay@a3.epfl.ch>- * All rights reserved.- *- * Redistribution and use in source and binary forms, with or without- * modification, are permitted provided that the following conditions- * are met:- * 1. Redistributions of source code must retain the above copyright- * notice, this list of conditions and the following disclaimer.- * 2. Redistributions 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.- * 3. Neither the name of the project nor the names of its contributors- * may be used to endorse or promote products derived from this software- * without specific prior written permission.- *- * THIS SOFTWARE IS PROVIDED BY THE PROJECT 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 PROJECT OR 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.- */--#if 0-#define UNROLL_LOOPS /* Enable loops unrolling */-#endif--#include <string.h>--#include "sha2.h"--#define SHFR(x, n) (x >> n)-#define ROTR(x, n) ((x >> n) | (x << ((sizeof(x) << 3) - n)))-#define ROTL(x, n) ((x << n) | (x >> ((sizeof(x) << 3) - n)))-#define CH(x, y, z) ((x & y) ^ (~x & z))-#define MAJ(x, y, z) ((x & y) ^ (x & z) ^ (y & z))--#define SHA256_F1(x) (ROTR(x, 2) ^ ROTR(x, 13) ^ ROTR(x, 22))-#define SHA256_F2(x) (ROTR(x, 6) ^ ROTR(x, 11) ^ ROTR(x, 25))-#define SHA256_F3(x) (ROTR(x, 7) ^ ROTR(x, 18) ^ SHFR(x, 3))-#define SHA256_F4(x) (ROTR(x, 17) ^ ROTR(x, 19) ^ SHFR(x, 10))--#define SHA512_F1(x) (ROTR(x, 28) ^ ROTR(x, 34) ^ ROTR(x, 39))-#define SHA512_F2(x) (ROTR(x, 14) ^ ROTR(x, 18) ^ ROTR(x, 41))-#define SHA512_F3(x) (ROTR(x, 1) ^ ROTR(x, 8) ^ SHFR(x, 7))-#define SHA512_F4(x) (ROTR(x, 19) ^ ROTR(x, 61) ^ SHFR(x, 6))--#define UNPACK32(x, str) \-{ \- *((str) + 3) = (uint8) ((x) ); \- *((str) + 2) = (uint8) ((x) >> 8); \- *((str) + 1) = (uint8) ((x) >> 16); \- *((str) + 0) = (uint8) ((x) >> 24); \-}--#define PACK32(str, x) \-{ \- *(x) = ((uint32) *((str) + 3) ) \- | ((uint32) *((str) + 2) << 8) \- | ((uint32) *((str) + 1) << 16) \- | ((uint32) *((str) + 0) << 24); \-}--#define UNPACK64(x, str) \-{ \- *((str) + 7) = (uint8) ((x) ); \- *((str) + 6) = (uint8) ((x) >> 8); \- *((str) + 5) = (uint8) ((x) >> 16); \- *((str) + 4) = (uint8) ((x) >> 24); \- *((str) + 3) = (uint8) ((x) >> 32); \- *((str) + 2) = (uint8) ((x) >> 40); \- *((str) + 1) = (uint8) ((x) >> 48); \- *((str) + 0) = (uint8) ((x) >> 56); \-}--#define PACK64(str, x) \-{ \- *(x) = ((uint64) *((str) + 7) ) \- | ((uint64) *((str) + 6) << 8) \- | ((uint64) *((str) + 5) << 16) \- | ((uint64) *((str) + 4) << 24) \- | ((uint64) *((str) + 3) << 32) \- | ((uint64) *((str) + 2) << 40) \- | ((uint64) *((str) + 1) << 48) \- | ((uint64) *((str) + 0) << 56); \-}--/* Macros used for loops unrolling */--#define SHA256_SCR(i) \-{ \- w[i] = SHA256_F4(w[i - 2]) + w[i - 7] \- + SHA256_F3(w[i - 15]) + w[i - 16]; \-}--#define SHA512_SCR(i) \-{ \- w[i] = SHA512_F4(w[i - 2]) + w[i - 7] \- + SHA512_F3(w[i - 15]) + w[i - 16]; \-}--#define SHA256_EXP(a, b, c, d, e, f, g, h, j) \-{ \- t1 = wv[h] + SHA256_F2(wv[e]) + CH(wv[e], wv[f], wv[g]) \- + sha256_k[j] + w[j]; \- t2 = SHA256_F1(wv[a]) + MAJ(wv[a], wv[b], wv[c]); \- wv[d] += t1; \- wv[h] = t1 + t2; \-}--#define SHA512_EXP(a, b, c, d, e, f, g ,h, j) \-{ \- t1 = wv[h] + SHA512_F2(wv[e]) + CH(wv[e], wv[f], wv[g]) \- + sha512_k[j] + w[j]; \- t2 = SHA512_F1(wv[a]) + MAJ(wv[a], wv[b], wv[c]); \- wv[d] += t1; \- wv[h] = t1 + t2; \-}--static uint32 sha224_h0[8] =- {0xc1059ed8, 0x367cd507, 0x3070dd17, 0xf70e5939,- 0xffc00b31, 0x68581511, 0x64f98fa7, 0xbefa4fa4};--static uint32 sha256_h0[8] =- {0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a,- 0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19};--static uint64 sha384_h0[8] =- {0xcbbb9d5dc1059ed8ULL, 0x629a292a367cd507ULL,- 0x9159015a3070dd17ULL, 0x152fecd8f70e5939ULL,- 0x67332667ffc00b31ULL, 0x8eb44a8768581511ULL,- 0xdb0c2e0d64f98fa7ULL, 0x47b5481dbefa4fa4ULL};--static uint64 sha512_h0[8] =- {0x6a09e667f3bcc908ULL, 0xbb67ae8584caa73bULL,- 0x3c6ef372fe94f82bULL, 0xa54ff53a5f1d36f1ULL,- 0x510e527fade682d1ULL, 0x9b05688c2b3e6c1fULL,- 0x1f83d9abfb41bd6bULL, 0x5be0cd19137e2179ULL};--static uint32 sha256_k[64] =- {0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5,- 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,- 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3,- 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,- 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc,- 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,- 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7,- 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,- 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13,- 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,- 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3,- 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,- 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5,- 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,- 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208,- 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2};--static uint64 sha512_k[80] =- {0x428a2f98d728ae22ULL, 0x7137449123ef65cdULL,- 0xb5c0fbcfec4d3b2fULL, 0xe9b5dba58189dbbcULL,- 0x3956c25bf348b538ULL, 0x59f111f1b605d019ULL,- 0x923f82a4af194f9bULL, 0xab1c5ed5da6d8118ULL,- 0xd807aa98a3030242ULL, 0x12835b0145706fbeULL,- 0x243185be4ee4b28cULL, 0x550c7dc3d5ffb4e2ULL,- 0x72be5d74f27b896fULL, 0x80deb1fe3b1696b1ULL,- 0x9bdc06a725c71235ULL, 0xc19bf174cf692694ULL,- 0xe49b69c19ef14ad2ULL, 0xefbe4786384f25e3ULL,- 0x0fc19dc68b8cd5b5ULL, 0x240ca1cc77ac9c65ULL,- 0x2de92c6f592b0275ULL, 0x4a7484aa6ea6e483ULL,- 0x5cb0a9dcbd41fbd4ULL, 0x76f988da831153b5ULL,- 0x983e5152ee66dfabULL, 0xa831c66d2db43210ULL,- 0xb00327c898fb213fULL, 0xbf597fc7beef0ee4ULL,- 0xc6e00bf33da88fc2ULL, 0xd5a79147930aa725ULL,- 0x06ca6351e003826fULL, 0x142929670a0e6e70ULL,- 0x27b70a8546d22ffcULL, 0x2e1b21385c26c926ULL,- 0x4d2c6dfc5ac42aedULL, 0x53380d139d95b3dfULL,- 0x650a73548baf63deULL, 0x766a0abb3c77b2a8ULL,- 0x81c2c92e47edaee6ULL, 0x92722c851482353bULL,- 0xa2bfe8a14cf10364ULL, 0xa81a664bbc423001ULL,- 0xc24b8b70d0f89791ULL, 0xc76c51a30654be30ULL,- 0xd192e819d6ef5218ULL, 0xd69906245565a910ULL,- 0xf40e35855771202aULL, 0x106aa07032bbd1b8ULL,- 0x19a4c116b8d2d0c8ULL, 0x1e376c085141ab53ULL,- 0x2748774cdf8eeb99ULL, 0x34b0bcb5e19b48a8ULL,- 0x391c0cb3c5c95a63ULL, 0x4ed8aa4ae3418acbULL,- 0x5b9cca4f7763e373ULL, 0x682e6ff3d6b2b8a3ULL,- 0x748f82ee5defb2fcULL, 0x78a5636f43172f60ULL,- 0x84c87814a1f0ab72ULL, 0x8cc702081a6439ecULL,- 0x90befffa23631e28ULL, 0xa4506cebde82bde9ULL,- 0xbef9a3f7b2c67915ULL, 0xc67178f2e372532bULL,- 0xca273eceea26619cULL, 0xd186b8c721c0c207ULL,- 0xeada7dd6cde0eb1eULL, 0xf57d4f7fee6ed178ULL,- 0x06f067aa72176fbaULL, 0x0a637dc5a2c898a6ULL,- 0x113f9804bef90daeULL, 0x1b710b35131c471bULL,- 0x28db77f523047d84ULL, 0x32caab7b40c72493ULL,- 0x3c9ebe0a15c9bebcULL, 0x431d67c49c100d4cULL,- 0x4cc5d4becb3e42b6ULL, 0x597f299cfc657e2aULL,- 0x5fcb6fab3ad6faecULL, 0x6c44198c4a475817ULL};--/* SHA-256 functions */--static void sha256_transf(sha256_ctx *ctx, const unsigned char *message,- unsigned int block_nb)-{- uint32 w[64];- uint32 wv[8];- uint32 t1, t2;- const unsigned char *sub_block;- int i;--#ifndef UNROLL_LOOPS- int j;-#endif-- for (i = 0; i < (int) block_nb; i++) {- sub_block = message + (i << 6);--#ifndef UNROLL_LOOPS- for (j = 0; j < 16; j++) {- PACK32(&sub_block[j << 2], &w[j]);- }-- for (j = 16; j < 64; j++) {- SHA256_SCR(j);- }-- for (j = 0; j < 8; j++) {- wv[j] = ctx->h[j];- }-- for (j = 0; j < 64; j++) {- t1 = wv[7] + SHA256_F2(wv[4]) + CH(wv[4], wv[5], wv[6])- + sha256_k[j] + w[j];- t2 = SHA256_F1(wv[0]) + MAJ(wv[0], wv[1], wv[2]);- wv[7] = wv[6];- wv[6] = wv[5];- wv[5] = wv[4];- wv[4] = wv[3] + t1;- wv[3] = wv[2];- wv[2] = wv[1];- wv[1] = wv[0];- wv[0] = t1 + t2;- }-- for (j = 0; j < 8; j++) {- ctx->h[j] += wv[j];- }-#else- PACK32(&sub_block[ 0], &w[ 0]); PACK32(&sub_block[ 4], &w[ 1]);- PACK32(&sub_block[ 8], &w[ 2]); PACK32(&sub_block[12], &w[ 3]);- PACK32(&sub_block[16], &w[ 4]); PACK32(&sub_block[20], &w[ 5]);- PACK32(&sub_block[24], &w[ 6]); PACK32(&sub_block[28], &w[ 7]);- PACK32(&sub_block[32], &w[ 8]); PACK32(&sub_block[36], &w[ 9]);- PACK32(&sub_block[40], &w[10]); PACK32(&sub_block[44], &w[11]);- PACK32(&sub_block[48], &w[12]); PACK32(&sub_block[52], &w[13]);- PACK32(&sub_block[56], &w[14]); PACK32(&sub_block[60], &w[15]);-- SHA256_SCR(16); SHA256_SCR(17); SHA256_SCR(18); SHA256_SCR(19);- SHA256_SCR(20); SHA256_SCR(21); SHA256_SCR(22); SHA256_SCR(23);- SHA256_SCR(24); SHA256_SCR(25); SHA256_SCR(26); SHA256_SCR(27);- SHA256_SCR(28); SHA256_SCR(29); SHA256_SCR(30); SHA256_SCR(31);- SHA256_SCR(32); SHA256_SCR(33); SHA256_SCR(34); SHA256_SCR(35);- SHA256_SCR(36); SHA256_SCR(37); SHA256_SCR(38); SHA256_SCR(39);- SHA256_SCR(40); SHA256_SCR(41); SHA256_SCR(42); SHA256_SCR(43);- SHA256_SCR(44); SHA256_SCR(45); SHA256_SCR(46); SHA256_SCR(47);- SHA256_SCR(48); SHA256_SCR(49); SHA256_SCR(50); SHA256_SCR(51);- SHA256_SCR(52); SHA256_SCR(53); SHA256_SCR(54); SHA256_SCR(55);- SHA256_SCR(56); SHA256_SCR(57); SHA256_SCR(58); SHA256_SCR(59);- SHA256_SCR(60); SHA256_SCR(61); SHA256_SCR(62); SHA256_SCR(63);-- wv[0] = ctx->h[0]; wv[1] = ctx->h[1];- wv[2] = ctx->h[2]; wv[3] = ctx->h[3];- wv[4] = ctx->h[4]; wv[5] = ctx->h[5];- wv[6] = ctx->h[6]; wv[7] = ctx->h[7];-- SHA256_EXP(0,1,2,3,4,5,6,7, 0); SHA256_EXP(7,0,1,2,3,4,5,6, 1);- SHA256_EXP(6,7,0,1,2,3,4,5, 2); SHA256_EXP(5,6,7,0,1,2,3,4, 3);- SHA256_EXP(4,5,6,7,0,1,2,3, 4); SHA256_EXP(3,4,5,6,7,0,1,2, 5);- SHA256_EXP(2,3,4,5,6,7,0,1, 6); SHA256_EXP(1,2,3,4,5,6,7,0, 7);- SHA256_EXP(0,1,2,3,4,5,6,7, 8); SHA256_EXP(7,0,1,2,3,4,5,6, 9);- SHA256_EXP(6,7,0,1,2,3,4,5,10); SHA256_EXP(5,6,7,0,1,2,3,4,11);- SHA256_EXP(4,5,6,7,0,1,2,3,12); SHA256_EXP(3,4,5,6,7,0,1,2,13);- SHA256_EXP(2,3,4,5,6,7,0,1,14); SHA256_EXP(1,2,3,4,5,6,7,0,15);- SHA256_EXP(0,1,2,3,4,5,6,7,16); SHA256_EXP(7,0,1,2,3,4,5,6,17);- SHA256_EXP(6,7,0,1,2,3,4,5,18); SHA256_EXP(5,6,7,0,1,2,3,4,19);- SHA256_EXP(4,5,6,7,0,1,2,3,20); SHA256_EXP(3,4,5,6,7,0,1,2,21);- SHA256_EXP(2,3,4,5,6,7,0,1,22); SHA256_EXP(1,2,3,4,5,6,7,0,23);- SHA256_EXP(0,1,2,3,4,5,6,7,24); SHA256_EXP(7,0,1,2,3,4,5,6,25);- SHA256_EXP(6,7,0,1,2,3,4,5,26); SHA256_EXP(5,6,7,0,1,2,3,4,27);- SHA256_EXP(4,5,6,7,0,1,2,3,28); SHA256_EXP(3,4,5,6,7,0,1,2,29);- SHA256_EXP(2,3,4,5,6,7,0,1,30); SHA256_EXP(1,2,3,4,5,6,7,0,31);- SHA256_EXP(0,1,2,3,4,5,6,7,32); SHA256_EXP(7,0,1,2,3,4,5,6,33);- SHA256_EXP(6,7,0,1,2,3,4,5,34); SHA256_EXP(5,6,7,0,1,2,3,4,35);- SHA256_EXP(4,5,6,7,0,1,2,3,36); SHA256_EXP(3,4,5,6,7,0,1,2,37);- SHA256_EXP(2,3,4,5,6,7,0,1,38); SHA256_EXP(1,2,3,4,5,6,7,0,39);- SHA256_EXP(0,1,2,3,4,5,6,7,40); SHA256_EXP(7,0,1,2,3,4,5,6,41);- SHA256_EXP(6,7,0,1,2,3,4,5,42); SHA256_EXP(5,6,7,0,1,2,3,4,43);- SHA256_EXP(4,5,6,7,0,1,2,3,44); SHA256_EXP(3,4,5,6,7,0,1,2,45);- SHA256_EXP(2,3,4,5,6,7,0,1,46); SHA256_EXP(1,2,3,4,5,6,7,0,47);- SHA256_EXP(0,1,2,3,4,5,6,7,48); SHA256_EXP(7,0,1,2,3,4,5,6,49);- SHA256_EXP(6,7,0,1,2,3,4,5,50); SHA256_EXP(5,6,7,0,1,2,3,4,51);- SHA256_EXP(4,5,6,7,0,1,2,3,52); SHA256_EXP(3,4,5,6,7,0,1,2,53);- SHA256_EXP(2,3,4,5,6,7,0,1,54); SHA256_EXP(1,2,3,4,5,6,7,0,55);- SHA256_EXP(0,1,2,3,4,5,6,7,56); SHA256_EXP(7,0,1,2,3,4,5,6,57);- SHA256_EXP(6,7,0,1,2,3,4,5,58); SHA256_EXP(5,6,7,0,1,2,3,4,59);- SHA256_EXP(4,5,6,7,0,1,2,3,60); SHA256_EXP(3,4,5,6,7,0,1,2,61);- SHA256_EXP(2,3,4,5,6,7,0,1,62); SHA256_EXP(1,2,3,4,5,6,7,0,63);-- ctx->h[0] += wv[0]; ctx->h[1] += wv[1];- ctx->h[2] += wv[2]; ctx->h[3] += wv[3];- ctx->h[4] += wv[4]; ctx->h[5] += wv[5];- ctx->h[6] += wv[6]; ctx->h[7] += wv[7];-#endif /* !UNROLL_LOOPS */- }-}--static void sha256_init(sha256_ctx *ctx)-{-#ifndef UNROLL_LOOPS- int i;- for (i = 0; i < 8; i++) {- ctx->h[i] = sha256_h0[i];- }-#else- ctx->h[0] = sha256_h0[0]; ctx->h[1] = sha256_h0[1];- ctx->h[2] = sha256_h0[2]; ctx->h[3] = sha256_h0[3];- ctx->h[4] = sha256_h0[4]; ctx->h[5] = sha256_h0[5];- ctx->h[6] = sha256_h0[6]; ctx->h[7] = sha256_h0[7];-#endif /* !UNROLL_LOOPS */-- ctx->len = 0;- ctx->tot_len = 0;-}--static void sha256_update(sha256_ctx *ctx, const unsigned char *message,- unsigned int len)-{- unsigned int block_nb;- unsigned int new_len, rem_len, tmp_len;- const unsigned char *shifted_message;-- tmp_len = SHA256_BLOCK_SIZE - ctx->len;- rem_len = len < tmp_len ? len : tmp_len;-- memcpy(&ctx->block[ctx->len], message, rem_len);-- if (ctx->len + len < SHA256_BLOCK_SIZE) {- ctx->len += len;- return;- }-- new_len = len - rem_len;- block_nb = new_len / SHA256_BLOCK_SIZE;-- shifted_message = message + rem_len;-- sha256_transf(ctx, ctx->block, 1);- sha256_transf(ctx, shifted_message, block_nb);-- rem_len = new_len % SHA256_BLOCK_SIZE;-- memcpy(ctx->block, &shifted_message[block_nb << 6],- rem_len);-- ctx->len = rem_len;- ctx->tot_len += (block_nb + 1) << 6;-}--static void sha256_final(sha256_ctx *ctx, unsigned char *digest)-{- unsigned int block_nb;- unsigned int pm_len;- unsigned int len_b;--#ifndef UNROLL_LOOPS- int i;-#endif-- block_nb = (1 + ((SHA256_BLOCK_SIZE - 9)- < (ctx->len % SHA256_BLOCK_SIZE)));-- len_b = (ctx->tot_len + ctx->len) << 3;- pm_len = block_nb << 6;-- memset(ctx->block + ctx->len, 0, pm_len - ctx->len);- ctx->block[ctx->len] = 0x80;- UNPACK32(len_b, ctx->block + pm_len - 4);-- sha256_transf(ctx, ctx->block, block_nb);--#ifndef UNROLL_LOOPS- for (i = 0 ; i < 8; i++) {- UNPACK32(ctx->h[i], &digest[i << 2]);- }-#else- UNPACK32(ctx->h[0], &digest[ 0]);- UNPACK32(ctx->h[1], &digest[ 4]);- UNPACK32(ctx->h[2], &digest[ 8]);- UNPACK32(ctx->h[3], &digest[12]);- UNPACK32(ctx->h[4], &digest[16]);- UNPACK32(ctx->h[5], &digest[20]);- UNPACK32(ctx->h[6], &digest[24]);- UNPACK32(ctx->h[7], &digest[28]);-#endif /* !UNROLL_LOOPS */-}--void darcs_sha256(const unsigned char *message, unsigned int len, unsigned char *digest)-{- sha256_ctx ctx;-- sha256_init(&ctx);- sha256_update(&ctx, message, len);- sha256_final(&ctx, digest);-}--/* SHA-512 functions */--static void sha512_transf(sha512_ctx *ctx, const unsigned char *message,- unsigned int block_nb)-{- uint64 w[80];- uint64 wv[8];- uint64 t1, t2;- const unsigned char *sub_block;- int i, j;-- for (i = 0; i < (int) block_nb; i++) {- sub_block = message + (i << 7);--#ifndef UNROLL_LOOPS- for (j = 0; j < 16; j++) {- PACK64(&sub_block[j << 3], &w[j]);- }-- for (j = 16; j < 80; j++) {- SHA512_SCR(j);- }-- for (j = 0; j < 8; j++) {- wv[j] = ctx->h[j];- }-- for (j = 0; j < 80; j++) {- t1 = wv[7] + SHA512_F2(wv[4]) + CH(wv[4], wv[5], wv[6])- + sha512_k[j] + w[j];- t2 = SHA512_F1(wv[0]) + MAJ(wv[0], wv[1], wv[2]);- wv[7] = wv[6];- wv[6] = wv[5];- wv[5] = wv[4];- wv[4] = wv[3] + t1;- wv[3] = wv[2];- wv[2] = wv[1];- wv[1] = wv[0];- wv[0] = t1 + t2;- }-- for (j = 0; j < 8; j++) {- ctx->h[j] += wv[j];- }-#else- PACK64(&sub_block[ 0], &w[ 0]); PACK64(&sub_block[ 8], &w[ 1]);- PACK64(&sub_block[ 16], &w[ 2]); PACK64(&sub_block[ 24], &w[ 3]);- PACK64(&sub_block[ 32], &w[ 4]); PACK64(&sub_block[ 40], &w[ 5]);- PACK64(&sub_block[ 48], &w[ 6]); PACK64(&sub_block[ 56], &w[ 7]);- PACK64(&sub_block[ 64], &w[ 8]); PACK64(&sub_block[ 72], &w[ 9]);- PACK64(&sub_block[ 80], &w[10]); PACK64(&sub_block[ 88], &w[11]);- PACK64(&sub_block[ 96], &w[12]); PACK64(&sub_block[104], &w[13]);- PACK64(&sub_block[112], &w[14]); PACK64(&sub_block[120], &w[15]);-- SHA512_SCR(16); SHA512_SCR(17); SHA512_SCR(18); SHA512_SCR(19);- SHA512_SCR(20); SHA512_SCR(21); SHA512_SCR(22); SHA512_SCR(23);- SHA512_SCR(24); SHA512_SCR(25); SHA512_SCR(26); SHA512_SCR(27);- SHA512_SCR(28); SHA512_SCR(29); SHA512_SCR(30); SHA512_SCR(31);- SHA512_SCR(32); SHA512_SCR(33); SHA512_SCR(34); SHA512_SCR(35);- SHA512_SCR(36); SHA512_SCR(37); SHA512_SCR(38); SHA512_SCR(39);- SHA512_SCR(40); SHA512_SCR(41); SHA512_SCR(42); SHA512_SCR(43);- SHA512_SCR(44); SHA512_SCR(45); SHA512_SCR(46); SHA512_SCR(47);- SHA512_SCR(48); SHA512_SCR(49); SHA512_SCR(50); SHA512_SCR(51);- SHA512_SCR(52); SHA512_SCR(53); SHA512_SCR(54); SHA512_SCR(55);- SHA512_SCR(56); SHA512_SCR(57); SHA512_SCR(58); SHA512_SCR(59);- SHA512_SCR(60); SHA512_SCR(61); SHA512_SCR(62); SHA512_SCR(63);- SHA512_SCR(64); SHA512_SCR(65); SHA512_SCR(66); SHA512_SCR(67);- SHA512_SCR(68); SHA512_SCR(69); SHA512_SCR(70); SHA512_SCR(71);- SHA512_SCR(72); SHA512_SCR(73); SHA512_SCR(74); SHA512_SCR(75);- SHA512_SCR(76); SHA512_SCR(77); SHA512_SCR(78); SHA512_SCR(79);-- wv[0] = ctx->h[0]; wv[1] = ctx->h[1];- wv[2] = ctx->h[2]; wv[3] = ctx->h[3];- wv[4] = ctx->h[4]; wv[5] = ctx->h[5];- wv[6] = ctx->h[6]; wv[7] = ctx->h[7];-- j = 0;-- do {- SHA512_EXP(0,1,2,3,4,5,6,7,j); j++;- SHA512_EXP(7,0,1,2,3,4,5,6,j); j++;- SHA512_EXP(6,7,0,1,2,3,4,5,j); j++;- SHA512_EXP(5,6,7,0,1,2,3,4,j); j++;- SHA512_EXP(4,5,6,7,0,1,2,3,j); j++;- SHA512_EXP(3,4,5,6,7,0,1,2,j); j++;- SHA512_EXP(2,3,4,5,6,7,0,1,j); j++;- SHA512_EXP(1,2,3,4,5,6,7,0,j); j++;- } while (j < 80);-- ctx->h[0] += wv[0]; ctx->h[1] += wv[1];- ctx->h[2] += wv[2]; ctx->h[3] += wv[3];- ctx->h[4] += wv[4]; ctx->h[5] += wv[5];- ctx->h[6] += wv[6]; ctx->h[7] += wv[7];-#endif /* !UNROLL_LOOPS */- }-}--static void sha512_init(sha512_ctx *ctx)-{-#ifndef UNROLL_LOOPS- int i;- for (i = 0; i < 8; i++) {- ctx->h[i] = sha512_h0[i];- }-#else- ctx->h[0] = sha512_h0[0]; ctx->h[1] = sha512_h0[1];- ctx->h[2] = sha512_h0[2]; ctx->h[3] = sha512_h0[3];- ctx->h[4] = sha512_h0[4]; ctx->h[5] = sha512_h0[5];- ctx->h[6] = sha512_h0[6]; ctx->h[7] = sha512_h0[7];-#endif /* !UNROLL_LOOPS */-- ctx->len = 0;- ctx->tot_len = 0;-}--static void sha512_update(sha512_ctx *ctx, const unsigned char *message,- unsigned int len)-{- unsigned int block_nb;- unsigned int new_len, rem_len, tmp_len;- const unsigned char *shifted_message;-- tmp_len = SHA512_BLOCK_SIZE - ctx->len;- rem_len = len < tmp_len ? len : tmp_len;-- memcpy(&ctx->block[ctx->len], message, rem_len);-- if (ctx->len + len < SHA512_BLOCK_SIZE) {- ctx->len += len;- return;- }-- new_len = len - rem_len;- block_nb = new_len / SHA512_BLOCK_SIZE;-- shifted_message = message + rem_len;-- sha512_transf(ctx, ctx->block, 1);- sha512_transf(ctx, shifted_message, block_nb);-- rem_len = new_len % SHA512_BLOCK_SIZE;-- memcpy(ctx->block, &shifted_message[block_nb << 7],- rem_len);-- ctx->len = rem_len;- ctx->tot_len += (block_nb + 1) << 7;-}--static void sha512_final(sha512_ctx *ctx, unsigned char *digest)-{- unsigned int block_nb;- unsigned int pm_len;- unsigned int len_b;--#ifndef UNROLL_LOOPS- int i;-#endif-- block_nb = 1 + ((SHA512_BLOCK_SIZE - 17)- < (ctx->len % SHA512_BLOCK_SIZE));-- len_b = (ctx->tot_len + ctx->len) << 3;- pm_len = block_nb << 7;-- memset(ctx->block + ctx->len, 0, pm_len - ctx->len);- ctx->block[ctx->len] = 0x80;- UNPACK32(len_b, ctx->block + pm_len - 4);-- sha512_transf(ctx, ctx->block, block_nb);--#ifndef UNROLL_LOOPS- for (i = 0 ; i < 8; i++) {- UNPACK64(ctx->h[i], &digest[i << 3]);- }-#else- UNPACK64(ctx->h[0], &digest[ 0]);- UNPACK64(ctx->h[1], &digest[ 8]);- UNPACK64(ctx->h[2], &digest[16]);- UNPACK64(ctx->h[3], &digest[24]);- UNPACK64(ctx->h[4], &digest[32]);- UNPACK64(ctx->h[5], &digest[40]);- UNPACK64(ctx->h[6], &digest[48]);- UNPACK64(ctx->h[7], &digest[56]);-#endif /* !UNROLL_LOOPS */-}--void darcs_sha512(const unsigned char *message, unsigned int len,- unsigned char *digest)-{- sha512_ctx ctx;-- sha512_init(&ctx);- sha512_update(&ctx, message, len);- sha512_final(&ctx, digest);-}--/* SHA-384 functions */--static void sha384_init(sha384_ctx *ctx)-{-#ifndef UNROLL_LOOPS- int i;- for (i = 0; i < 8; i++) {- ctx->h[i] = sha384_h0[i];- }-#else- ctx->h[0] = sha384_h0[0]; ctx->h[1] = sha384_h0[1];- ctx->h[2] = sha384_h0[2]; ctx->h[3] = sha384_h0[3];- ctx->h[4] = sha384_h0[4]; ctx->h[5] = sha384_h0[5];- ctx->h[6] = sha384_h0[6]; ctx->h[7] = sha384_h0[7];-#endif /* !UNROLL_LOOPS */-- ctx->len = 0;- ctx->tot_len = 0;-}--static void sha384_update(sha384_ctx *ctx, const unsigned char *message,- unsigned int len)-{- unsigned int block_nb;- unsigned int new_len, rem_len, tmp_len;- const unsigned char *shifted_message;-- tmp_len = SHA384_BLOCK_SIZE - ctx->len;- rem_len = len < tmp_len ? len : tmp_len;-- memcpy(&ctx->block[ctx->len], message, rem_len);-- if (ctx->len + len < SHA384_BLOCK_SIZE) {- ctx->len += len;- return;- }-- new_len = len - rem_len;- block_nb = new_len / SHA384_BLOCK_SIZE;-- shifted_message = message + rem_len;-- sha512_transf(ctx, ctx->block, 1);- sha512_transf(ctx, shifted_message, block_nb);-- rem_len = new_len % SHA384_BLOCK_SIZE;-- memcpy(ctx->block, &shifted_message[block_nb << 7],- rem_len);-- ctx->len = rem_len;- ctx->tot_len += (block_nb + 1) << 7;-}--static void sha384_final(sha384_ctx *ctx, unsigned char *digest)-{- unsigned int block_nb;- unsigned int pm_len;- unsigned int len_b;--#ifndef UNROLL_LOOPS- int i;-#endif-- block_nb = (1 + ((SHA384_BLOCK_SIZE - 17)- < (ctx->len % SHA384_BLOCK_SIZE)));-- len_b = (ctx->tot_len + ctx->len) << 3;- pm_len = block_nb << 7;-- memset(ctx->block + ctx->len, 0, pm_len - ctx->len);- ctx->block[ctx->len] = 0x80;- UNPACK32(len_b, ctx->block + pm_len - 4);-- sha512_transf(ctx, ctx->block, block_nb);--#ifndef UNROLL_LOOPS- for (i = 0 ; i < 6; i++) {- UNPACK64(ctx->h[i], &digest[i << 3]);- }-#else- UNPACK64(ctx->h[0], &digest[ 0]);- UNPACK64(ctx->h[1], &digest[ 8]);- UNPACK64(ctx->h[2], &digest[16]);- UNPACK64(ctx->h[3], &digest[24]);- UNPACK64(ctx->h[4], &digest[32]);- UNPACK64(ctx->h[5], &digest[40]);-#endif /* !UNROLL_LOOPS */-}--void darcs_sha384(const unsigned char *message, unsigned int len,- unsigned char *digest)-{- sha384_ctx ctx;-- sha384_init(&ctx);- sha384_update(&ctx, message, len);- sha384_final(&ctx, digest);-}--/* SHA-224 functions */--static void sha224_init(sha224_ctx *ctx)-{-#ifndef UNROLL_LOOPS- int i;- for (i = 0; i < 8; i++) {- ctx->h[i] = sha224_h0[i];- }-#else- ctx->h[0] = sha224_h0[0]; ctx->h[1] = sha224_h0[1];- ctx->h[2] = sha224_h0[2]; ctx->h[3] = sha224_h0[3];- ctx->h[4] = sha224_h0[4]; ctx->h[5] = sha224_h0[5];- ctx->h[6] = sha224_h0[6]; ctx->h[7] = sha224_h0[7];-#endif /* !UNROLL_LOOPS */-- ctx->len = 0;- ctx->tot_len = 0;-}--static void sha224_update(sha224_ctx *ctx, const unsigned char *message,- unsigned int len)-{- unsigned int block_nb;- unsigned int new_len, rem_len, tmp_len;- const unsigned char *shifted_message;-- tmp_len = SHA224_BLOCK_SIZE - ctx->len;- rem_len = len < tmp_len ? len : tmp_len;-- memcpy(&ctx->block[ctx->len], message, rem_len);-- if (ctx->len + len < SHA224_BLOCK_SIZE) {- ctx->len += len;- return;- }-- new_len = len - rem_len;- block_nb = new_len / SHA224_BLOCK_SIZE;-- shifted_message = message + rem_len;-- sha256_transf(ctx, ctx->block, 1);- sha256_transf(ctx, shifted_message, block_nb);-- rem_len = new_len % SHA224_BLOCK_SIZE;-- memcpy(ctx->block, &shifted_message[block_nb << 6],- rem_len);-- ctx->len = rem_len;- ctx->tot_len += (block_nb + 1) << 6;-}--static void sha224_final(sha224_ctx *ctx, unsigned char *digest)-{- unsigned int block_nb;- unsigned int pm_len;- unsigned int len_b;--#ifndef UNROLL_LOOPS- int i;-#endif-- block_nb = (1 + ((SHA224_BLOCK_SIZE - 9)- < (ctx->len % SHA224_BLOCK_SIZE)));-- len_b = (ctx->tot_len + ctx->len) << 3;- pm_len = block_nb << 6;-- memset(ctx->block + ctx->len, 0, pm_len - ctx->len);- ctx->block[ctx->len] = 0x80;- UNPACK32(len_b, ctx->block + pm_len - 4);-- sha256_transf(ctx, ctx->block, block_nb);--#ifndef UNROLL_LOOPS- for (i = 0 ; i < 7; i++) {- UNPACK32(ctx->h[i], &digest[i << 2]);- }-#else- UNPACK32(ctx->h[0], &digest[ 0]);- UNPACK32(ctx->h[1], &digest[ 4]);- UNPACK32(ctx->h[2], &digest[ 8]);- UNPACK32(ctx->h[3], &digest[12]);- UNPACK32(ctx->h[4], &digest[16]);- UNPACK32(ctx->h[5], &digest[20]);- UNPACK32(ctx->h[6], &digest[24]);-#endif /* !UNROLL_LOOPS */-}--void darcs_sha224(const unsigned char *message, unsigned int len,- unsigned char *digest)-{- sha224_ctx ctx;-- sha224_init(&ctx);- sha224_update(&ctx, message, len);- sha224_final(&ctx, digest);-}--#ifdef TEST_VECTORS--/* FIPS 180-2 Validation tests */--#include <stdio.h>-#include <stdlib.h>--void test(const unsigned char *vector, unsigned char *digest,- unsigned int digest_size)-{- unsigned char output[2 * SHA512_DIGEST_SIZE + 1];- int i;-- output[2 * digest_size] = '\0';-- for (i = 0; i < (int) digest_size ; i++) {- sprintf((char *) output + 2 * i, "%02x", digest[i]);- }-- printf("H: %s\n", output);- if (strcmp((char *) vector, (char *) output)) {- fprintf(stderr, "Test failed.\n");- exit(EXIT_FAILURE);- }-}--int main()-{- static const unsigned char *vectors[4][3] =- { /* SHA-224 */- {- "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7",- "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525",- "20794655980c91d8bbb4c1ea97618a4bf03f42581948b2ee4ee7ad67",- },- /* SHA-256 */- {- "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad",- "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1",- "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0",- },- /* SHA-384 */- {- "cb00753f45a35e8bb5a03d699ac65007272c32ab0eded1631a8b605a43ff5bed"- "8086072ba1e7cc2358baeca134c825a7",- "09330c33f71147e83d192fc782cd1b4753111b173b3b05d22fa08086e3b0f712"- "fcc7c71a557e2db966c3e9fa91746039",- "9d0e1809716474cb086e834e310a4a1ced149e9c00f248527972cec5704c2a5b"- "07b8b3dc38ecc4ebae97ddd87f3d8985",- },- /* SHA-512 */- {- "ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a"- "2192992a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f",- "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018"- "501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909",- "e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973eb"- "de0ff244877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b"- }- };-- static const unsigned char message1[] = "abc";- static const unsigned char message2a[] = "abcdbcdecdefdefgefghfghighijhi"- "jkijkljklmklmnlmnomnopnopq";- static const unsigned char message2b[] =- "abcdefghbcdefghicdefghijdefghijkefghij"- "klfghijklmghijklmnhijklmnoijklmnopjklm"- "nopqklmnopqrlmnopqrsmnopqrstnopqrstu";- unsigned char *message3;- unsigned int message3_len = 1000000;- unsigned char digest[SHA512_DIGEST_SIZE];-- message3 = malloc(message3_len);- if (message3 == NULL) {- fprintf(stderr, "Can't allocate memory\n");- return -1;- }- memset(message3, 'a', message3_len);-- printf("SHA-2 FIPS 180-2 Validation tests\n\n");- printf("SHA-224 Test vectors\n");-- sha224(message1, strlen((char *) message1), digest);- test(vectors[0][0], digest, SHA224_DIGEST_SIZE);- sha224(message2a, strlen((char *) message2a), digest);- test(vectors[0][1], digest, SHA224_DIGEST_SIZE);- sha224(message3, message3_len, digest);- test(vectors[0][2], digest, SHA224_DIGEST_SIZE);- printf("\n");-- printf("SHA-256 Test vectors\n");-- sha256(message1, strlen((char *) message1), digest);- test(vectors[1][0], digest, SHA256_DIGEST_SIZE);- sha256(message2a, strlen((char *) message2a), digest);- test(vectors[1][1], digest, SHA256_DIGEST_SIZE);- sha256(message3, message3_len, digest);- test(vectors[1][2], digest, SHA256_DIGEST_SIZE);- printf("\n");-- printf("SHA-384 Test vectors\n");-- sha384(message1, strlen((char *) message1), digest);- test(vectors[2][0], digest, SHA384_DIGEST_SIZE);- sha384(message2b, strlen((char *) message2b), digest);- test(vectors[2][1], digest, SHA384_DIGEST_SIZE);- sha384(message3, message3_len, digest);- test(vectors[2][2], digest, SHA384_DIGEST_SIZE);- printf("\n");-- printf("SHA-512 Test vectors\n");-- sha512(message1, strlen((char *) message1), digest);- test(vectors[3][0], digest, SHA512_DIGEST_SIZE);- sha512(message2b, strlen((char *) message2b), digest);- test(vectors[3][1], digest, SHA512_DIGEST_SIZE);- sha512(message3, message3_len, digest);- test(vectors[3][2], digest, SHA512_DIGEST_SIZE);- printf("\n");-- printf("All tests passed.\n");-- return 0;-}--#endif /* TEST_VECTORS */
− src/Crypt/sha2.h
@@ -1,88 +0,0 @@-/*- * FIPS 180-2 SHA-224/256/384/512 implementation- * Last update: 02/02/2007- * Issue date: 04/30/2005- *- * Copyright (C) 2005, 2007 Olivier Gay <olivier.gay@a3.epfl.ch>- * All rights reserved.- *- * Redistribution and use in source and binary forms, with or without- * modification, are permitted provided that the following conditions- * are met:- * 1. Redistributions of source code must retain the above copyright- * notice, this list of conditions and the following disclaimer.- * 2. Redistributions 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.- * 3. Neither the name of the project nor the names of its contributors- * may be used to endorse or promote products derived from this software- * without specific prior written permission.- *- * THIS SOFTWARE IS PROVIDED BY THE PROJECT 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 PROJECT OR 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.- */--#ifndef SHA2_H-#define SHA2_H--#define SHA224_DIGEST_SIZE ( 224 / 8)-#define SHA256_DIGEST_SIZE ( 256 / 8)-#define SHA384_DIGEST_SIZE ( 384 / 8)-#define SHA512_DIGEST_SIZE ( 512 / 8)--#define SHA256_BLOCK_SIZE ( 512 / 8)-#define SHA512_BLOCK_SIZE (1024 / 8)-#define SHA384_BLOCK_SIZE SHA512_BLOCK_SIZE-#define SHA224_BLOCK_SIZE SHA256_BLOCK_SIZE--#ifndef SHA2_TYPES-#define SHA2_TYPES-typedef unsigned char uint8;-typedef unsigned int uint32;-typedef unsigned long long uint64;-#endif--#ifdef __cplusplus-extern "C" {-#endif--typedef struct {- unsigned int tot_len;- unsigned int len;- unsigned char block[2 * SHA256_BLOCK_SIZE];- uint32 h[8];-} sha256_ctx;--typedef struct {- unsigned int tot_len;- unsigned int len;- unsigned char block[2 * SHA512_BLOCK_SIZE];- uint64 h[8];-} sha512_ctx;--typedef sha512_ctx sha384_ctx;-typedef sha256_ctx sha224_ctx;--void darcs_sha224(const unsigned char *message, unsigned int len,- unsigned char *digest);-void darcs_sha256(const unsigned char *message, unsigned int len,- unsigned char *digest);-void darcs_sha384(const unsigned char *message, unsigned int len,- unsigned char *digest);-void darcs_sha512(const unsigned char *message, unsigned int len,- unsigned char *digest);--#ifdef __cplusplus-}-#endif--#endif /* !SHA2_H */
− src/Darcs/Annotate.hs
@@ -1,262 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, MultiParamTypeClasses #-}---- Copyright (C) 2010 Petr Rockai------ 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.---- |--- Module : Darcs.Annotate--- Copyright : 2010 Petr Rockai--- License : MIT--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module Darcs.Annotate- (- annotate- , annotateDirectory- , format- , machineFormat- ) where--import Prelude hiding ( pi )--import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.Map as M-import qualified Data.Vector as V--import Data.List( nub, groupBy )-import Data.Maybe( isJust, catMaybes, isNothing )--import Control.Monad.State ( modify, when, gets, State, execState )-import Control.Applicative( (<$>) )--import Darcs.Patch.ApplyMonad( ApplyMonad(..) )-import Darcs.Patch.FileName( FileName, movedirfilename, fn2ps, ps2fn )-import Darcs.Patch.Apply ( Apply, apply, ApplyState )-import Darcs.Patch.Info ( PatchInfo(..), humanFriendly, piAuthor, makeFilename )-import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd )-import Darcs.Witnesses.Ordered--import Storage.Hashed.Tree( Tree )-import Lcs( getChanges )-import Printer( renderString )-import ByteStringUtils ( linesPS, unlinesPS )--#include "gadts.h"-#include "impossible.h"---data FileOrDirectory = File- | Directory- deriving (Show, Eq)--data Annotated = Annotated- { annotated :: V.Vector (Maybe PatchInfo, B.ByteString)- , current :: [(Int, B.ByteString)]- , path :: Maybe FileName- , what :: FileOrDirectory- , currentInfo :: PatchInfo- } deriving Show---type AnnotatedM = State Annotated---- XXX: No explicit method nor default method for 'editFile', 'editDirectory'-instance ApplyMonad AnnotatedM Tree where- type ApplyMonadBase AnnotatedM = AnnotatedM-- nestedApply _ _ = undefinedFun "nestedApply"- liftApply _ _ = undefinedFun "liftApply"- getApplyState = undefinedFun "getApplyState"- putApplyState _ = undefinedFun "putApplyState"- mReadFilePS = undefinedFun "mReadFilePS"-- mDoesFileExist _ = return True- mDoesDirectoryExist _ = return True- mCreateDirectory _ = return ()- mCreateFile _ = return ()-- mRemoveFile f = do- p <- gets path- when (p == Just f) $ modify (\x -> x { path = Nothing })- updateDirectory f-- mRemoveDirectory = mRemoveFile-- mRename a b = do- p <- gets path- w <- gets what- when (isJust p) $- modify $ \st -> st { path = Just $ movedirfilename a b (fromJust p) }- when (w == Directory) $ do- let fix (i, x) = (i, fn2ps $ movedirfilename a b (ps2fn x))- modify $ \st -> st { current = map fix $ current st }-- mModifyFilePS f job = do- p <- gets path- when (p == Just f) $ updateFile (fmap linesPS . job . unlinesPS)-- mModifyFilePSs f job = do- p <- gets path- when (p == Just f) $ updateFile job--undefinedFun :: Monad m- => String- -> m a-undefinedFun name = fail $ name ++ " undefined for Annotated"---updateFile :: ([B.ByteString]- -> AnnotatedM [B.ByteString])- -> AnnotatedM ()-updateFile job = (==File) <$> gets what >>= flip when go- where- go = do- before <- map snd `fmap` gets current- after <- job before- reannotate $ getChanges before after-- reannotate [] = return ()- reannotate ((off, remove, add):rest) = do- i <- gets currentInfo- c <- gets current- a <- gets annotated- modify $ \s -> s { current = take off c ++ [ (-1, x) | x <- add ] ++- drop (off + length remove) c- , annotated = merge i a $ take (length remove) $ drop off c- }- reannotate rest-- merge i a l = a V.// [ (line, (Just i, B.empty))- | (line, _) <- l, line >= 0 && line < V.length a]---updateDirectory :: FileName -> AnnotatedM ()-updateDirectory p = (==Directory) <$> gets what >>= flip when go- where- go = do let line = fn2ps p- files <- gets current- case filter ((==line) . snd) files of- [match@(ident, _)] -> reannotate ident match line- _ -> return ()- reannotate ident match line =- modify $ \x -> x { annotated = annotated x V.// [ (ident, update line $ currentInfo x) ]- , current = filter (/= match) $ current x }- update line inf = (Just inf, BC.concat [ " -- created as: ", line ])---complete :: Annotated -> Bool-complete x = (V.all (isJust . fst) $ annotated x) || (isNothing $ path x)---annotate' :: (Apply p, ApplyState p ~ Tree)- => FL (PatchInfoAnd p) C(x y)- -> Annotated- -> Annotated-annotate' NilFL ann = ann-annotate' (p :>: ps) ann- | complete ann = ann- | otherwise = annotate' ps $ execState (apply p) (ann { currentInfo = info p })---annotate :: (Apply p, ApplyState p ~ Tree)- => FL (PatchInfoAnd p) C(x y)- -> FileName- -> B.ByteString- -> Annotated-annotate patches inipath inicontent = annotate' patches initial- where- initial = Annotated { path = Just inipath- , currentInfo = error "There is no currentInfo."- , current = zip [0..] (linesPS inicontent)- , what = File- , annotated = V.replicate (length $ breakLines inicontent)- (Nothing, B.empty)- }---annotateDirectory :: (Apply p, ApplyState p ~ Tree)- => FL (PatchInfoAnd p) C(x y)- -> FileName- -> [FileName]- -> Annotated-annotateDirectory patches inipath inicontent = annotate' patches initial- where- initial = Annotated { path = Just inipath- , currentInfo = error "There is no currentInfo."- , current = zip [0..] (map fn2ps inicontent)- , what = Directory- , annotated = V.replicate (length inicontent) (Nothing, B.empty)- }---machineFormat :: B.ByteString -> Annotated -> String-machineFormat d a = unlines [ case i of- Just inf -> makeFilename inf- Nothing -> -- make unknowns uniform, for easier parsing- "19700101000000-0000-0000000000000000000000000000000000000000.gz"- ++ " | " ++ BC.unpack line ++ " " ++ BC.unpack add- | ((i, add), line) <- zip (V.toList $ annotated a) (breakLines d) ]---format :: B.ByteString- -> Annotated- -> String-format d a = pi_list ++ "\n" ++ file- where- pi_list = unlines $ [ show n ++ ": " ++ renderString (humanFriendly i)- | (n :: Int, i) <- zip [1..] pis ]-- file = concat [ annotation (fst $ head chunk) ++ " | " ++ line (head chunk) ++- "\n" ++ unlines [ indent 25 (" | " ++ line l) | l <- tail chunk ]- | chunk <- file_ann ]-- pis = nub $ catMaybes . map fst $ V.toList (annotated a)-- pi_map = M.fromList (zip pis [1 :: Int ..])-- file_ann = groupBy (\x y -> fst x == fst y) $ zip (V.toList $ annotated a) (breakLines d)-- line ((_, add), l) = BC.unpack $ BC.concat [l, " ", add]-- annotation (Just i, _) | Just n <- M.lookup i pi_map =- pad 20 (piMail i) ++ " " ++ pad 4 ("#" ++ show n)- annotation _ = pad 25 "unknown"-- pad n str = replicate (n - length str) ' ' ++ (take n str)-- indent n str = replicate n ' ' ++ str-- piMail pi- | '<' `elem` piAuthor pi = takeWhile (/= '>') . drop 1 . dropWhile (/= '<') $ piAuthor pi- | otherwise = piAuthor pi---breakLines :: BC.ByteString- -> [BC.ByteString]-breakLines s = case BC.split '\n' s of- [] -> []- split | BC.null (last split) -> init split- | otherwise -> split-
− src/Darcs/ArgumentDefaults.hs
@@ -1,79 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.ArgumentDefaults ( getDefaultFlags ) where-import Data.Maybe ( listToMaybe, mapMaybe )--import Darcs.Arguments ( DarcsFlag,- atomicOptions, DarcsAtomicOption( .. ), DarcsOption ( .. ),- applyDefaults,- arein )-import Darcs.Commands ( CommandControl( CommandData ),- commandAlloptions )-import Darcs.Commands.Help ( commandControlList )-import Darcs.Repository.Prefs ( getGlobal, getPreflist )--getDefaultFlags :: String -> [DarcsOption] -> [DarcsFlag] -> IO [DarcsFlag]-getDefaultFlags com com_opts already = do- repo_defs <- defaultContent $ getPreflist "defaults"- global_defs <- defaultContent $ getGlobal "defaults"- let repo_flags = getFlagsFrom com com_opts already repo_defs- global_flags = getFlagsFrom com com_opts- (already++repo_flags) global_defs- return $ applyDefaults com_opts -- hard-coded defaults (respects user preferences)- $ repo_flags ++ global_flags -- user preferences--getFlagsFrom :: String -> [DarcsOption] -> [DarcsFlag] -> [(String,String,String)] -> [DarcsFlag]-getFlagsFrom com com_opts already defs =- options_for com_defs com_opts com_opts ++- options_for all_defs com_opts all_opts- where com_defs = filter (\ (c,_,_) -> c == com) defs- all_defs = filter (\ (c,_,_) -> c == "ALL") defs- options_for d o ao = concatMap (findOption o ao already) d- all_opts = concatMap get_opts commandControlList- get_opts (CommandData c) = let (o1, o2) = commandAlloptions c- in o1 ++ o2- get_opts _ = []--findOption :: [DarcsOption] -> [DarcsOption] -> [DarcsFlag] -> (String,String,String) -> [DarcsFlag]-findOption opts all_opts already (c, f, d) =- if null $ mapMaybe choose_option all_opts- then error $ "Bad default option: command '"++c++"' has no option '"++f++"'."- else concat $ mapMaybe choose_option opts- where choose_atomic_option (DarcsNoArgOption _ fls o _)- | f `elem` fls = if null d- then Just [o]- else error $ "Bad default option: '"++f- ++"' takes no argument, but '"++d- ++"' argument given."- choose_atomic_option (DarcsArgOption _ fls o _ _)- | f `elem` fls = if null d- then error $ "Bad default option: '"++f- ++"' requires an argument, but no "- ++"argument given."- else Just [o d]- choose_atomic_option _ = Nothing- choose_option o- | o `arein` already = Just []- | otherwise = listToMaybe $ mapMaybe choose_atomic_option $ atomicOptions o--defaultContent :: IO [String] -> IO [(String,String,String)]-defaultContent = fmap (mapMaybe (doline . words))- where doline (c:a:r) = Just (c, drop_dashdash a, unwords r)- doline _ = Nothing- drop_dashdash ('-':'-':a) = a- drop_dashdash a = a
− src/Darcs/Arguments.hs
@@ -1,1596 +0,0 @@--- Copyright (C) 2002-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, PatternGuards #-}--#include "gadts.h"--module Darcs.Arguments ( DarcsFlag( .. ), flagToString, applyDefaults, nubOptions,- maxCount,- isin, arein,- setEnvDarcsPatches, setEnvDarcsFiles,- fixFilePathOrStd, fixUrl, fixUrlFlag,- fixSubPaths, maybeFixSubPaths,- DarcsAtomicOption( .. ), atomicOptions,- DarcsOption( .. ), optionFromDarcsOption,- help, listOptions, listFiles,- anyVerbosity, disable, restrictPaths,- notest, test, workingRepoDir,- remoteRepo,- leaveTestDir,- possiblyRemoteRepoDir, getRepourl,- listRegisteredFiles, listUnregisteredFiles,- author, getAuthor, getEasyAuthor, getSendmailCmd,- fileHelpAuthor, environmentHelpEmail,- patchnameOption, distnameOption,- logfile, rmlogfile, fromOpt, subject, getSubject,- charset, getCharset,- inReplyTo, getInReplyTo,- target, ccSend, ccApply, getCc, output, outputAutoName,- recursive, patchFormatChoices,- upgradeFormat, useWorkingDir,- askdeps, ignoretimes, lookforadds,- askLongComment, keepDate, sendmailCmd,- environmentHelpSendmail,- sign, verify, editDescription,- reponame, creatorhash,- applyConflictOptions, reply,- pullConflictOptions, useExternalMerge,- depsSel, nocompress,- uncompressNocompress, repoCombinator,- optionsLatex, reorderPatches,- noskipBoring, allowProblematicFilenames,- applyas, humanReadable, machineReadable,- changesReverse, onlyToFiles,- changesFormat, matchOneContext, matchOneNontag,- matchMaxcount,- sendToContext,- getContext,- pipeInteractive, allInteractive,- allPipeInteractive,- summary, unified, tokens,- partial,- diffCmdFlag, diffflags, unidiff, xmloutput,- pauseForGui,- forceReplace, dryRun, dryRunNoxml,- printDryRunMessageAndExit, showFriendly,- matchOne, matchSeveral, matchRange,- matchSeveralOrRange, happyForwarding,- matchSeveralOrLast,- setDefault,- setScriptsExecutableOption, bisect,- sibling, flagsToSiblings, relink,- files, directories, pending,- posthookCmd, posthookPrompt,- getPosthookCmd,- prehookCmd, prehookPrompt,- getPrehookCmd, nullFlag,- umaskOption,- storeInMemory,- patchSelectFlag,- networkOptions, noCache,- allowUnrelatedRepos,- checkOrRepair, justThisRepo, optimizePristine,- optimizeHTTP, getOutput, makeScriptsExecutable,- usePacks, recordRollback, amendUnrecord- ) where-import System.Console.GetOpt-import System.Directory ( doesDirectoryExist )--import Storage.Hashed.AnchoredPath( anchorPath )-import Storage.Hashed.Plain( readPlainTree )-import Storage.Hashed.Tree( list, expand, emptyTree )--import Data.List ( (\\), nub, intercalate )-import Data.Maybe ( fromMaybe, listToMaybe, maybeToList, isNothing, catMaybes,- mapMaybe )-import System.Exit ( ExitCode(ExitSuccess), exitWith )-import Control.Monad ( when, unless )-import Control.Applicative( (<$>) )-import Data.Char ( isDigit )-#ifndef WIN32-import Printer ( renderString )-import System.Posix.Env ( setEnv )-import Darcs.Patch ( listTouchedFiles )-import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO )-#endif--import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefullyM )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch ( RepoPatch, Patchy, showNicely, description, xmlSummary )-import Darcs.Patch.Info ( toXml )-import Darcs.Witnesses.Ordered ( FL, mapFL )-import qualified Darcs.Patch ( summary )-import Darcs.Utils ( askUser, askUserListItem, maybeGetEnv, firstJustIO,- catchall,- withCurrentDirectory )-import Darcs.Repository.Prefs ( getPreflist, getGlobal, globalPrefsDirDoc )-import Darcs.Repository.State ( restrictBoring, applyTreeFilter, readRecordedAndPending )-import Darcs.Repository( setScriptsExecutablePatches )-import Darcs.URL ( isFile )-import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd, SubPath, toFilePath,- makeSubPathOf, ioAbsolute, ioAbsoluteOrStd,- makeAbsolute, makeAbsoluteOrStd )-import Darcs.Patch.MatchData ( patchMatch )-import Darcs.Flags ( DarcsFlag(..), maxCount, defaultFlag )-import Darcs.Repository ( withRepository, RepoJob(..) )-import Darcs.Global ( darcsdir )-import Darcs.Lock ( writeLocaleFile )-import Printer ( Doc, putDocLn, text, vsep, ($$), vcat, insertBeforeLastline,- prefix )-import ByteStringUtils ( decodeString )-import Storage.Hashed.Tree( Tree )-#include "impossible.h"--data FlagContent = NoContent | AbsoluteContent AbsolutePath | AbsoluteOrStdContent AbsolutePathOrStd | StringContent String- deriving (Eq, Show, Ord)---- getContent is very tedious to write, but this is the only way (that--- I know of) to guarantee that it works for all flags (which then--- guarantees that isAnAbsolute, isa, flagToString, etc also work--- properly)---- | 'getContentString' returns the content of a flag, if any.--- For instance, the content of @Author \"Louis Aragon\"@ is @StringContent--- \"Louis Aragon\"@, while the content of @Pipe@ is @NoContent@-getContent :: DarcsFlag -> FlagContent-getContent (PatchName s) = StringContent s-getContent (Output s) = AbsoluteOrStdContent s-getContent Verbose = NoContent-getContent Help = NoContent-getContent ListOptions = NoContent-getContent Test = NoContent-getContent NoTest = NoContent-getContent OnlyChangesToFiles = NoContent-getContent ChangesToAllFiles = NoContent-getContent LeaveTestDir = NoContent-getContent NoLeaveTestDir = NoContent-getContent Timings = NoContent-getContent Debug = NoContent-getContent DebugVerbose = NoContent-getContent DebugHTTP = NoContent-getContent NormalVerbosity = NoContent-getContent Quiet = NoContent-getContent (Target s) = StringContent s-getContent (Cc s) = StringContent s-getContent (Subject s) = StringContent s-getContent (Charset s) = StringContent s-getContent (InReplyTo s) = StringContent s-getContent (SendmailCmd s) = StringContent s-getContent (Author s) = StringContent s-getContent (OnePatch s) = StringContent s-getContent (SeveralPatch s) = StringContent s-getContent (AfterPatch s) = StringContent s-getContent (UpToPatch s) = StringContent s-getContent (TagName s) = StringContent s-getContent (LastN s) = StringContent (show s)-getContent (MaxCount s) = StringContent (show s)-getContent (OneTag s) = StringContent s-getContent (AfterTag s) = StringContent s-getContent (UpToTag s) = StringContent s-getContent (Context s) = AbsoluteContent s-getContent GenContext = NoContent-getContent (LogFile s) = AbsoluteContent s-getContent (OutputAutoName s) = AbsoluteContent s-getContent NumberPatches = NoContent-getContent (PatchIndexRange _ _) = NoContent -- FIXME this doesn't fit into a neat category-getContent Count = NoContent-getContent All = NoContent-getContent Recursive = NoContent-getContent NoRecursive = NoContent-getContent Reorder = NoContent-getContent RestrictPaths = NoContent-getContent DontRestrictPaths = NoContent-getContent AskDeps = NoContent-getContent NoAskDeps = NoContent-getContent RmLogFile = NoContent-getContent DontRmLogFile = NoContent-getContent (DistName s) = StringContent s-getContent (CreatorHash s) = StringContent s-getContent (SignAs s) = StringContent s-getContent (SignSSL s) = StringContent s-getContent (Verify s) = AbsoluteContent s-getContent (VerifySSL s) = AbsoluteContent s-getContent IgnoreTimes = NoContent-getContent DontIgnoreTimes = NoContent-getContent LookForAdds = NoContent-getContent NoLookForAdds = NoContent-getContent AnyOrder = NoContent-getContent Intersection = NoContent-getContent Unified = NoContent-getContent NonUnified = NoContent-getContent Union = NoContent-getContent Complement = NoContent-getContent Sign = NoContent-getContent NoSign = NoContent-getContent HappyForwarding = NoContent-getContent NoHappyForwarding = NoContent-getContent (RemoteDarcsOpt s) = StringContent s-getContent (Toks s) = StringContent s-getContent (WorkRepoDir s) = StringContent s-getContent (WorkRepoUrl s) = StringContent s-getContent (RemoteRepo s) = StringContent s-getContent (NewRepo s) = StringContent s-getContent (Reply s) = StringContent s-getContent EditDescription = NoContent-getContent NoEditDescription = NoContent-getContent EditLongComment = NoContent-getContent NoEditLongComment = NoContent-getContent PromptLongComment = NoContent-getContent KeepDate = NoContent-getContent NoKeepDate = NoContent-getContent AllowConflicts = NoContent-getContent MarkConflicts = NoContent-getContent NoAllowConflicts = NoContent-getContent SkipConflicts = NoContent-getContent Boring = NoContent-getContent SkipBoring = NoContent-getContent AllowCaseOnly = NoContent-getContent DontAllowCaseOnly = NoContent-getContent AllowWindowsReserved = NoContent-getContent DontAllowWindowsReserved = NoContent-getContent DontGrabDeps = NoContent-getContent DontPromptForDependencies = NoContent-getContent PromptForDependencies = NoContent-getContent Compress = NoContent-getContent NoCompress = NoContent-getContent UnCompress = NoContent-getContent MachineReadable = NoContent-getContent HumanReadable = NoContent-getContent Pipe = NoContent-getContent Interactive = NoContent-getContent Summary = NoContent-getContent NoSummary = NoContent-getContent (ApplyAs s) = StringContent s-getContent (DiffCmd s) = StringContent s-getContent (ExternalMerge s) = StringContent s-getContent PauseForGui = NoContent-getContent NoPauseForGui = NoContent-getContent (DiffFlags s) = StringContent s-getContent (OnePattern _) = NoContent -- FIXME!!!-getContent (SeveralPattern _) = NoContent -- FIXME!!!-getContent (UpToPattern _) = NoContent -- FIXME!!!-getContent (AfterPattern _) = NoContent -- FIXME!!!-getContent Reverse = NoContent-getContent Forward = NoContent-getContent Complete = NoContent-getContent Lazy = NoContent-getContent (FixFilePath _ _) = NoContent -- FIXME!!!-getContent XMLOutput = NoContent-getContent ForceReplace = NoContent-getContent NonApply = NoContent-getContent NonVerify = NoContent-getContent NonForce = NoContent-getContent DryRun = NoContent-getContent (SetDefault _) = NoContent-getContent (NoSetDefault _) = NoContent-getContent Disable = NoContent-getContent SetScriptsExecutable = NoContent-getContent DontSetScriptsExecutable = NoContent-getContent Bisect = NoContent-getContent UseHashedInventory = NoContent-getContent UseFormat2 = NoContent-getContent NoUpdateWorking = NoContent-getContent UpgradeFormat = NoContent-getContent Relink = NoContent-getContent Files = NoContent-getContent NoFiles = NoContent-getContent Directories = NoContent-getContent NoDirectories = NoContent-getContent Pending = NoContent-getContent NoPending = NoContent-getContent NoPosthook = NoContent-getContent AskPosthook = NoContent-getContent (Sibling s) = AbsoluteContent s-getContent (PosthookCmd s) = StringContent s-getContent RunPosthook = NoContent-getContent NoPrehook = NoContent-getContent RunPrehook = NoContent-getContent AskPrehook = NoContent-getContent StoreInMemory = NoContent-getContent ApplyOnDisk = NoContent-getContent NoHTTPPipelining = NoContent-getContent Packs = NoContent-getContent NoPacks = NoContent-getContent NoCache = NoContent-getContent NullFlag = NoContent-getContent (PrehookCmd s) = StringContent s-getContent (UMask s) = StringContent s-getContent AllowUnrelatedRepos = NoContent-getContent Check = NoContent-getContent Repair = NoContent-getContent JustThisRepo = NoContent-getContent OptimizePristine = NoContent-getContent OptimizeHTTP = NoContent-getContent RecordRollback = NoContent-getContent NoRecordRollback = NoContent-getContent AmendUnrecord = NoContent-getContent NoAmendUnrecord = NoContent-getContent UseWorkingDir = NoContent-getContent UseNoWorkingDir = NoContent--getContentString :: DarcsFlag -> Maybe String-getContentString f =- do StringContent s <- Just $ getContent f- return s---- | @a `'isa'` b@ tests whether @a@ is flag @b@ with a string argument.--- @b@ typically is a Flag constructor expecting a string--- For example, @(Author \"Ted Hughes\") `isa` Author@ returns true.-isa :: DarcsFlag -> (String -> DarcsFlag) -> Bool-a `isa` b = case getContentString a of- Nothing -> False- Just s -> a == b s---- | @a `'isAnAbsolute'` b@ tests whether @a@ is flag @b@ with an absolute path argument.--- @b@ typically is a Flag constructor expecting an absolute path argument--- For example, @(Context contextfile) `isAnAbsolute` Context@ returns true.-isAnAbsolute :: DarcsFlag -> (AbsolutePath -> DarcsFlag) -> Bool-isAnAbsolute f x = case getContent f of- AbsoluteContent s -> f == x s- _ -> False---- | @a `'isAnAbsoluteOrStd'` b@ tests whether @a@ is flag @b@ with a path argument.--- @b@ typically is a Flag constructor expecting a path argument--- For example, @(Output o) `isAnAbsoluteOrStd` @ returns true.-isAnAbsoluteOrStd :: DarcsFlag -> (AbsolutePathOrStd -> DarcsFlag) -> Bool-isAnAbsoluteOrStd f x = case getContent f of- AbsoluteOrStdContent s -> f == x s- _ -> False--isin :: DarcsAtomicOption -> [DarcsFlag] -> Bool-(DarcsInternalOption f) `isin` fs = f `elem` fs-(DarcsNoArgOption _ _ f _) `isin` fs = f `elem` fs-(DarcsArgOption _ _ f _ _) `isin` fs = any (`isa` f) fs-(DarcsAbsPathOption _ _ f _ _) `isin` fs = any (`isAnAbsolute` f) fs-(DarcsAbsPathOrStdOption _ _ f _ _) `isin` fs = any (`isAnAbsoluteOrStd` f) fs-(DarcsOptAbsPathOption _ _ _ f _ _) `isin` fs = any (`isAnAbsolute` f) fs--arein :: DarcsOption -> [DarcsFlag] -> Bool-o `arein` fs = any (`isin` fs) (atomicOptions o)---- | A type for darcs' options. The value contains the command line--- switch(es) for the option, a help string, and a function to build a--- @DarcsFlag@ from the command line arguments. for each constructor,--- 'shortSwitches' represents the list of short command line switches--- which invoke the option, longSwitches the list of long command line--- switches, optDescr the description of the option, and argDescr the description--- of its argument, if any. mkFlag is a function which makes a @DarcsFlag@ from--- the arguments of the option.-data DarcsAtomicOption- = DarcsArgOption [Char] [String] (String->DarcsFlag) String String- -- ^ @DarcsArgOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@- -- The constructor for options with a string argument, such as- -- @--tag@-- | DarcsAbsPathOption [Char] [String] (AbsolutePath -> DarcsFlag) String String- -- ^ @DarcsAbsPathOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@- -- The constructor for options with an absolute path argument, such as- -- @--sibling@-- | DarcsAbsPathOrStdOption [Char] [String] (AbsolutePathOrStd -> DarcsFlag) String String- -- ^ @DarcsAbsPathOrStdOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@- -- The constructor for options with a path argument, such as @-o@-- | DarcsOptAbsPathOption [Char] [String] String (AbsolutePath -> DarcsFlag) String String- -- ^ @DarcsOptAbsPathOrStdOption shortSwitches longSwitches defaultPath- -- mkFlag ArgDescr OptDescr@ where defaultPath is a default value- -- for the Path, as a string to be parsed as if it had been given- -- on the command line.- -- The constructor for options with an optional path argument, such as @-O@-- | DarcsNoArgOption [Char] [String] DarcsFlag String- -- ^ @DarcsNoArgOption shortSwitches longSwitches mkFlag optDescr@- -- The constructon fon options with no arguments.-- | DarcsInternalOption DarcsFlag- -- ^ @DarcsInternalOption@- -- An option just for internal use (e.g. defaulting), not directly available to the user.---data DarcsOption- = DarcsSingleOption DarcsAtomicOption- | DarcsMultipleChoiceOption [DarcsAtomicOption]- -- ^ A constructor for grouping related options together, such as- -- @--hashed@ and @--darcs-2@.-- | DarcsMutuallyExclusive [DarcsAtomicOption] -- choices- ([DarcsFlag] -> [DarcsFlag]) -- setter--type NoArgPieces = (DarcsFlag -> String -> DarcsAtomicOption, DarcsFlag , String)--mkMutuallyExclusive :: [NoArgPieces] -- ^ before- -> NoArgPieces -- ^ default- -> [NoArgPieces] -- ^ after- -> DarcsOption-mkMutuallyExclusive os1 od_ os2 =- DarcsMutuallyExclusive (map option (os1 ++ (od : os2)))- (defaultFlag (map flag (os1 ++ os2)) (flag od))- where- od = third (++ " [DEFAULT]") od_- flag (_,f,_) = f- option (x,y,z) = x y z- third f (x,y,z) = (x,y,f z)--nubOptions :: [DarcsOption] -> [DarcsFlag] -> [DarcsFlag]-nubOptions [] opts = opts-nubOptions (DarcsMutuallyExclusive ch _:options) opts = nubOptions options $ collapse opts- where collapse (x:xs) | x `elem` flags ch = x : clear xs- | otherwise = x : collapse xs- collapse [] = []- clear (x:xs) | x `elem` flags ch = clear xs- | otherwise = x : clear xs- clear [] = []- flags (DarcsNoArgOption _ _ fl _:xs) = fl : flags xs- flags (DarcsInternalOption fl:xs) = fl : flags xs- flags (_:xs) = flags xs- flags [] = []-nubOptions (_:options) opts = nubOptions options opts--applyDefaults :: [DarcsOption] -> [DarcsFlag] -> [DarcsFlag]-applyDefaults opts = foldr (.) id (mapMaybe getSetter opts)- where- getSetter (DarcsMutuallyExclusive _ f) = Just f- getSetter _ = Nothing--optionFromDarcsAtomicOption :: AbsolutePath -> DarcsAtomicOption -> Maybe (OptDescr DarcsFlag)-optionFromDarcsAtomicOption _ (DarcsInternalOption _) = Nothing-optionFromDarcsAtomicOption _ (DarcsNoArgOption a b c h) = Just $ Option a b (NoArg c) h-optionFromDarcsAtomicOption _ (DarcsArgOption a b c n h) = Just $ Option a b (ReqArg c n) h-optionFromDarcsAtomicOption wd (DarcsAbsPathOrStdOption a b c n h) =- Just $ Option a b (ReqArg (c . makeAbsoluteOrStd wd) n) h-optionFromDarcsAtomicOption wd (DarcsAbsPathOption a b c n h) =- Just $ Option a b (ReqArg (c . makeAbsolute wd) n) h-optionFromDarcsAtomicOption wd (DarcsOptAbsPathOption a b d c n h) =- Just $ Option a b (OptArg (c . makeAbsolute wd . fromMaybe d) n) h--atomicOptions :: DarcsOption -> [DarcsAtomicOption]-atomicOptions (DarcsSingleOption x) = [x]-atomicOptions (DarcsMultipleChoiceOption xs) = xs-atomicOptions (DarcsMutuallyExclusive xs _) = xs--optionFromDarcsOption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag]-optionFromDarcsOption wd = mapMaybe (optionFromDarcsAtomicOption wd) . atomicOptions---- | 'concat_option' creates a DarcsMultipleChoiceOption from a list of--- option, flattening any DarcsMultipleChoiceOption in the list.-concatOptions :: [DarcsOption] -> DarcsOption-concatOptions = DarcsMultipleChoiceOption . concatMap atomicOptions--extractFixPath :: [DarcsFlag] -> Maybe (AbsolutePath, AbsolutePath)-extractFixPath [] = Nothing-extractFixPath ((FixFilePath repo orig):_) = Just (repo, orig)-extractFixPath (_:fs) = extractFixPath fs--fixFilePath :: [DarcsFlag] -> FilePath -> IO AbsolutePath-fixFilePath opts f = case extractFixPath opts of- Nothing -> bug "Can't fix path in fixFilePath"- Just (_,o) -> withCurrentDirectory o $ ioAbsolute f--fixFilePathOrStd :: [DarcsFlag] -> FilePath -> IO AbsolutePathOrStd-fixFilePathOrStd opts f =- case extractFixPath opts of- Nothing -> bug "Can't fix path in fixFilePathOrStd"- Just (_,o) -> withCurrentDirectory o $ ioAbsoluteOrStd f--fixUrlFlag :: [DarcsFlag] -> DarcsFlag -> IO DarcsFlag-fixUrlFlag opts (RemoteRepo f) = RemoteRepo `fmap` fixUrl opts f-fixUrlFlag _ f = return f--fixUrl :: [DarcsFlag] -> String -> IO String-fixUrl opts f = if isFile f- then toFilePath `fmap` fixFilePath opts f- else return f---- | @maybeFixSubPaths files@ tries to turn the file paths in its argument into--- @SubPath@s.------ When converting a relative path to an absolute one, this function first tries--- to interpret the relative path with respect to the current working directory.--- If that fails, it tries to interpret it with respect to the repository--- directory. Only when that fails does it put a @Nothing@ in the result at the--- position of the path that cannot be converted.------ It is intended for validating file arguments to darcs commands.-maybeFixSubPaths :: [DarcsFlag] -> [FilePath] -> IO [Maybe SubPath]-maybeFixSubPaths flags fs = withCurrentDirectory o $ do- fixedFs <- mapM fixit fs- let bads = snd . unzip . filter (isNothing . fst) $ zip fixedFs fs- unless (null bads) . putStrLn $ "Ignoring non-repository paths: " ++- intercalate ", " bads- return fixedFs- where- (r,o) = case extractFixPath flags of- Just xxx -> xxx- Nothing -> bug "Can't fix path in fixSubPaths"- fixit p = do ap <- ioAbsolute p- case makeSubPathOf r ap of- Just sp -> return $ Just sp- Nothing -> withCurrentDirectory r $ do- absolutePathByRepodir <- ioAbsolute p- return $ makeSubPathOf r absolutePathByRepodir---- | @fixSubPaths files@ returns the @SubPath@s for the paths in @files@ that--- are inside the repository, preserving their order. Paths in @files@ that are--- outside the repository directory are not in the result.------ When converting a relative path to an absolute one, this function first tries--- to interpret the relative path with respect to the current working directory.--- If that fails, it tries to interpret it with respect to the repository--- directory. Only when that fails does it omit the path from the result.------ It is intended for validating file arguments to darcs commands.-fixSubPaths :: [DarcsFlag] -> [FilePath] -> IO [SubPath]-fixSubPaths flags fs = nub . catMaybes <$> (maybeFixSubPaths flags $- filter (not . null) fs)---- | 'list_option' is an option which lists the command's arguments-listOptions :: DarcsOption-listOptions = DarcsSingleOption $ DarcsNoArgOption [] ["list-options"] ListOptions- "simply list the command's arguments"--flagToString :: [DarcsOption] -> DarcsFlag -> Maybe String-flagToString x f = listToMaybe $ mapMaybe f2o $ concatMap atomicOptions x- where f2o (DarcsArgOption _ (s:_) c _ _) =- do arg <- getContentString f- if c arg == f- then return $ unwords [('-':'-':s), arg]- else Nothing- f2o (DarcsNoArgOption _ (s:_) f' _) | f == f' = Just ('-':'-':s)- f2o _ = Nothing--pipeInteractive, allPipeInteractive, allInteractive,- humanReadable, machineReadable,- diffflags, allowProblematicFilenames, noskipBoring,- askLongComment, matchOneNontag, changesReverse, creatorhash,- changesFormat, matchOneContext, happyForwarding, sendToContext,- diffCmdFlag, storeInMemory, useExternalMerge,- pauseForGui,- pullConflictOptions, target, ccSend, ccApply, applyConflictOptions, reply, xmloutput,- distnameOption, patchnameOption, editDescription,- output, outputAutoName, unidiff, repoCombinator,- unified, summary, uncompressNocompress, subject, charset, inReplyTo,- nocompress, matchSeveralOrRange, matchSeveralOrLast,- author, askdeps, lookforadds, ignoretimes, test, notest, help, forceReplace,- allowUnrelatedRepos,- matchOne, matchRange, matchSeveral, sendmailCmd,- logfile, rmlogfile, leaveTestDir, fromOpt, recordRollback, amendUnrecord- :: DarcsOption--sign, applyas, verify :: DarcsOption--help = DarcsSingleOption $ DarcsNoArgOption ['h'] ["help"] Help- "shows brief description of command and its arguments"--disable :: DarcsOption-disable = DarcsSingleOption $ DarcsNoArgOption [] ["disable"] Disable- "disable this command"--anyVerbosity :: [DarcsOption]-anyVerbosity =[DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["debug"] Debug- "give only debug output",- DarcsNoArgOption [] ["debug-verbose"] DebugVerbose- "give debug and verbose output",- DarcsNoArgOption [] ["debug-http"] DebugHTTP- "give debug output for libcurl",- DarcsNoArgOption ['v'] ["verbose"] Verbose- "give verbose output",- DarcsNoArgOption ['q'] ["quiet"] Quiet- "suppress informational output",- DarcsNoArgOption [] ["standard-verbosity"] NormalVerbosity- "neither verbose nor quiet output"],- DarcsSingleOption- (DarcsNoArgOption [] ["timings"] Timings "provide debugging timings information")]--workingRepoDir :: DarcsOption-workingRepoDir = DarcsSingleOption $ DarcsArgOption [] ["repodir"] WorkRepoDir "DIRECTORY"- "specify the repository directory in which to run"--possiblyRemoteRepoDir :: DarcsOption-possiblyRemoteRepoDir = DarcsSingleOption $ DarcsArgOption [] ["repo"] WorkRepoUrl "URL"- "specify the repository URL"---- | 'getRepourl' takes a list of flags and returns the url of the--- repository specified by @Repodir \"directory\"@ in that list of flags, if any.--- This flag is present if darcs was invoked with @--repodir=DIRECTORY@-getRepourl :: [DarcsFlag] -> Maybe String-getRepourl [] = Nothing-getRepourl (WorkRepoUrl d:_) | not (isFile d) = Just d-getRepourl (_:fs) = getRepourl fs---- | 'remoteRepo' is the option used to specify the URL of the remote--- repository to work with-remoteRepo :: DarcsOption-remoteRepo = DarcsSingleOption $ DarcsArgOption [] ["remote-repo"] RemoteRepo "URL"- "specify the remote repository URL to work with"--patchnameOption = DarcsSingleOption $ DarcsArgOption ['m'] ["name"]- (PatchName . decodeString) "PATCHNAME" "name of patch"--sendToContext = DarcsSingleOption $ DarcsAbsPathOption [] ["context"] Context "FILENAME"- "send to context stored in FILENAME"--matchOneContext =- DarcsMultipleChoiceOption- [DarcsArgOption [] ["to-match"] mp "PATTERN"- "select changes up to a patch matching PATTERN",- DarcsArgOption [] ["to-patch"] OnePatch "REGEXP"- "select changes up to a patch matching REGEXP",- __tag,- DarcsAbsPathOption [] ["context"] Context "FILENAME"- "version specified by the context in FILENAME"- ]- where mp s = OnePattern (patchMatch s)--matchOne = DarcsMultipleChoiceOption [__match, __patch, __tag, __index]- -- [NOTE --index removed from matchOneNontag because issue1926]- -- The --index option was removed for 2.5 release because it isn't handled- -- by amend-record (see issue1926).- --- -- At this moment, amend-record is the only command that uses 'matchOneNontag',- -- so there is no other command affected.-matchOneNontag = DarcsMultipleChoiceOption [__match, __patch {- , __index -} ]-matchSeveral = DarcsMultipleChoiceOption [__matches, __patches, __tags]-matchRange = concatOptions $ [ matchTo, matchFrom- , DarcsMultipleChoiceOption [__match, __patch, __last, __indexes] ]-matchSeveralOrRange = concatOptions [ matchTo, matchFrom- , DarcsMultipleChoiceOption [ __last, __indexes, __matches, __patches, __tags] ]-matchSeveralOrLast = concatOptions [ matchFrom- , DarcsMultipleChoiceOption [ __last, __matches, __patches, __tags] ]--matchTo, matchFrom :: DarcsOption-matchTo = DarcsMultipleChoiceOption- [DarcsArgOption [] ["to-match"] uptop "PATTERN"- "select changes up to a patch matching PATTERN",- DarcsArgOption [] ["to-patch"] UpToPatch "REGEXP"- "select changes up to a patch matching REGEXP",- DarcsArgOption [] ["to-tag"] UpToTag "REGEXP"- "select changes up to a tag matching REGEXP"]- where uptop s = UpToPattern (patchMatch s)-matchFrom = DarcsMultipleChoiceOption- [DarcsArgOption [] ["from-match"] fromp "PATTERN"- "select changes starting with a patch matching PATTERN",- DarcsArgOption [] ["from-patch"] AfterPatch "REGEXP"- "select changes starting with a patch matching REGEXP",- DarcsArgOption [] ["from-tag"] AfterTag "REGEXP"- "select changes starting with a tag matching REGEXP"]- where fromp s = AfterPattern (patchMatch s)--__tag, __tags, __patch, __patches, __match, __matches, __last, __index, __indexes :: DarcsAtomicOption--__tag = DarcsArgOption ['t'] ["tag"] OneTag "REGEXP"- "select tag matching REGEXP"-__tags = DarcsArgOption ['t'] ["tags"] OneTag "REGEXP"- "select tags matching REGEXP"--__patch = DarcsArgOption ['p'] ["patch"] OnePatch "REGEXP"- "select a single patch matching REGEXP"-__patches = DarcsArgOption ['p'] ["patches"] SeveralPatch "REGEXP"- "select patches matching REGEXP"--__match = DarcsArgOption [] ["match"] mp "PATTERN"- "select a single patch matching PATTERN"- where mp s = OnePattern (patchMatch s)-__matches = DarcsArgOption [] ["matches"] mp "PATTERN"- "select patches matching PATTERN"- where mp s = SeveralPattern (patchMatch s)--__last = DarcsArgOption [] ["last"] lastn "NUMBER"- "select the last NUMBER patches"- where lastn = LastN . numberString--__index = DarcsArgOption ['n'] ["index"] indexrange "N" "select one patch"- where indexrange s = if all isDigit s- then PatchIndexRange (read s) (read s)- else PatchIndexRange 0 0--__indexes = DarcsArgOption ['n'] ["index"] indexrange "N-M" "select a range of patches"- where indexrange s = if all isokay s- then if '-' `elem` s- then let x1 = takeWhile (/= '-') s- x2 = reverse $ takeWhile (/= '-') $ reverse s- in PatchIndexRange (read x1) (read x2)- else PatchIndexRange (read s) (read s)- else PatchIndexRange 0 0- isokay c = isDigit c || c == '-'--matchMaxcount :: DarcsOption-matchMaxcount = DarcsSingleOption $ DarcsArgOption [] ["max-count"] mc "NUMBER"- "return only NUMBER results"- where mc = MaxCount . numberString----- | 'getContext' takes a list of flags and returns the context--- specified by @Context c@ in that list of flags, if any.--- This flag is present if darcs was invoked with @--context=FILE@-getContext :: [DarcsFlag] -> Maybe AbsolutePath-getContext xs = listToMaybe [ c | Context c <- xs ]--notest = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script",- DarcsNoArgOption [] ["test"] Test "run the test script"]-test = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["test"] Test "run the test script",- DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script"]-leaveTestDir = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["leave-test-directory"]- LeaveTestDir "don't remove the test directory",- DarcsNoArgOption [] ["remove-test-directory"]- NoLeaveTestDir "remove the test directory"]--recordRollback = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["record"]- RecordRollback "record the rollback patch (default)",- DarcsNoArgOption [] ["no-record"]- NoRecordRollback "don't record the rollback patch (only roll back in working dir)"]--amendUnrecord = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["add"]- NoAmendUnrecord "add the changes to patch (default)",- DarcsNoArgOption [] ["unrecord"]- AmendUnrecord "subtract the changes from patch"]--ignoretimes =- DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["ignore-times"] IgnoreTimes- "don't trust the file modification times"- ,DarcsNoArgOption [] ["no-ignore-times"] DontIgnoreTimes- "trust modification times to find modified files [DEFAULT]"- ]--lookforadds =- DarcsMultipleChoiceOption- [DarcsNoArgOption ['l'] ["look-for-adds"] LookForAdds- "look for (non-boring) files that could be added",- DarcsNoArgOption [] ["dont-look-for-adds","no-look-for-adds"] NoLookForAdds- "don't look for any files that could be added [DEFAULT]"]--askdeps =- DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["ask-deps"] AskDeps- "ask for extra dependencies",- DarcsNoArgOption [] ["no-ask-deps"] NoAskDeps- "don't ask for extra dependencies"]--askLongComment =- DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["edit-long-comment"] EditLongComment- "edit the long comment by default",- DarcsNoArgOption [] ["skip-long-comment"] NoEditLongComment- "don't give a long comment",- DarcsNoArgOption [] ["prompt-long-comment"] PromptLongComment- "prompt for whether to edit the long comment"]--keepDate :: DarcsOption-keepDate =- DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["keep-date"] KeepDate- "keep the date of the original patch",- DarcsNoArgOption [] ["no-keep-date"] NoKeepDate- "use the current date for the amended patch"- ]--logfile = DarcsSingleOption $ DarcsAbsPathOption [] ["logfile"] LogFile "FILE"- "give patch name and comment in file"--rmlogfile = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["delete-logfile"] RmLogFile- "delete the logfile when done",- DarcsNoArgOption [] ["no-delete-logfile"] DontRmLogFile- "keep the logfile when done [DEFAULT]"]--author = DarcsSingleOption $- DarcsArgOption ['A'] ["author"] (Author . decodeString) "EMAIL" "specify author id"-fromOpt = DarcsSingleOption $- DarcsArgOption [] ["from"] (Author . decodeString) "EMAIL" "specify email address"--fileHelpAuthor :: [String]-fileHelpAuthor = [- "Each patch is attributed to its author, usually by email address (for",- "example, `Fred Bloggs <fred@example.net>'). Darcs looks in several",- "places for this author string: the --author option, the files",- "_darcs/prefs/author (in the repository) and " ++ globalPrefsDirDoc ++ "author (in your",- "home directory), and the environment variables $DARCS_EMAIL and",- "$EMAIL. If none of those exist, Darcs will prompt you for an author",- "string and write it to _darcs/prefs/author. Note that if if you have more",- "than one email address, note that you can put them all in " ++ globalPrefsDirDoc ++ "author,",- "one author per line. Darcs will still prompt you for an author, but it",- "allows you to select from the list, or to type in an alternative."- ]--environmentHelpEmail :: ([String], [String])-environmentHelpEmail = (["DARCS_EMAIL","EMAIL"], fileHelpAuthor)---- | 'getAuthor' takes a list of flags and returns the author of the--- change specified by @Author \"Leo Tolstoy\"@ in that list of flags, if any.--- Otherwise, if @Pipe@ is present, asks the user who is the author and--- returns the answer. If neither are present, try to guess the author,--- from @_darcs/prefs@, and if it's not possible, ask the user.-getAuthor :: [DarcsFlag] -> IO String-getAuthor (Author a:_) = return a-getAuthor (Pipe:_) = askUser "Who is the author? "-getAuthor (_:flags) = getAuthor flags-getAuthor [] = do- easy_author <- getEasyAuthor- case easy_author of- [a] -> return a- [] -> askForAuthor shortPrompt longPrompt- as -> askForAuthor (fancyPrompt as) (fancyPrompt as)- where- shortPrompt = askUser "What is your email address? "- longPrompt = askUser "What is your email address (e.g. Fred Bloggs <fred@example.net>)? "- fancyPrompt xs =- do putDocLn $ text "" $$- text "You have saved the following email addresses to your global settings:"- str <- askUserListItem "Please select an email address for this repository: " (xs ++ ["Other"])- if str == "Other"- then longPrompt- else return str- askForAuthor askfn1 askfn2 = do- aminrepo <- doesDirectoryExist (darcsdir++"/prefs")- if aminrepo then do- putDocLn $- text "Each patch is attributed to its author, usually by email address (for" $$- text "example, `Fred Bloggs <fred@example.net>'). Darcs could not determine" $$- text "your email address, so you will be prompted for it." $$- text "" $$- text ("Your address will be stored in " ++ darcsdir ++ "/prefs/author.") $$- text "It will be used for all patches recorded in this repository." $$- text ("If you move that file to " ++ globalPrefsDirDoc ++ "author, it will be used for patches") $$- text "you record in ALL repositories."- add <- askfn1- writeLocaleFile (darcsdir ++ "/prefs/author") $- unlines ["# " ++ line | line <- fileHelpAuthor] ++ "\n" ++ add- return add- else askfn2---- | 'getEasyAuthor' tries to get the author name first from the repository preferences,--- then from global preferences, then from environment variables. Returns @[]@--- if it could not get it. Note that it may only return multiple possibilities when--- reading from global preferences-getEasyAuthor :: IO [String]-getEasyAuthor = fmap (map decodeString) $- firstNotNullIO [ (take 1 . nonblank) `fmap` getPreflist "author"- , nonblank `fmap` getGlobal "author"- , maybeToList `fmap` maybeGetEnv "DARCS_EMAIL"- , maybeToList `fmap` maybeGetEnv "EMAIL"- ]- where- nonblank = filter (not . null)- -- this could perhaps be simplified with Control.Monad- -- but note that we do NOT want to concatenate the results- firstNotNullIO [] = return []- firstNotNullIO (e:es) = do- v <- e `catchall` return []- if null v then firstNotNullIO es else return v--nocompress = DarcsMultipleChoiceOption [__compress, __dontCompress]-uncompressNocompress = DarcsMultipleChoiceOption [__compress, __dontCompress, __uncompress]--__compress, __dontCompress, __uncompress :: DarcsAtomicOption-__compress = DarcsNoArgOption [] ["compress"] Compress- "create compressed patches"-__dontCompress = DarcsNoArgOption [] ["dont-compress","no-compress"] NoCompress- "don't create compressed patches"-__uncompress = DarcsNoArgOption [] ["uncompress"] UnCompress- "uncompress patches"--summary = DarcsMultipleChoiceOption- [DarcsNoArgOption ['s'] ["summary"] Summary "summarize changes",- DarcsNoArgOption [] ["no-summary"] NoSummary "don't summarize changes"]-unified = DarcsMultipleChoiceOption- [DarcsNoArgOption ['u'] ["unified"] Unified- "output changes in a darcs-specific format similar to diff -u",- DarcsNoArgOption [] ["no-unified"] NonUnified- "output changes in darcs' usual format"]--unidiff = DarcsMultipleChoiceOption- [DarcsNoArgOption ['u'] ["unified"] Unified- "pass -u option to diff [DEFAULT]",- DarcsNoArgOption [] ["no-unified"] NonUnified- "output patch in diff's dumb format"]--diffCmdFlag = DarcsSingleOption $- DarcsArgOption [] ["diff-command"] DiffCmd "COMMAND" "specify diff command (ignores --diff-opts)"--pauseForGui = DarcsMultipleChoiceOption- [ DarcsNoArgOption- []- ["pause-for-gui"]- PauseForGui- "pause for an external diff or merge command to finish [DEFAULT]"- , DarcsNoArgOption- []- ["no-pause-for-gui"]- NoPauseForGui- "return immediately after external diff or merge command finishes"- ]--storeInMemory = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["store-in-memory"] StoreInMemory- "do patch application in memory rather than on disk",- DarcsNoArgOption [] ["no-store-in-memory"] ApplyOnDisk- "do patch application on disk [DEFAULT]"]--target = DarcsSingleOption $- DarcsArgOption [] ["to"] Target "EMAIL" "specify destination email"-ccSend = DarcsSingleOption $- DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s)"-ccApply = DarcsSingleOption $- DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s). Requires --reply"---- |'getCc' takes a list of flags and returns the addresses to send a copy of--- the patch bundle to when using @darcs send@.--- looks for a cc address specified by @Cc \"address\"@ in that list of flags.--- Returns the addresses as a comma separated string.-getCc :: [DarcsFlag] -> String-getCc fs = lt $ mapMaybe whatcc fs- where whatcc (Cc t) = Just t- whatcc _ = Nothing- lt [t] = t- lt [t,""] = t- lt (t:ts) = t++" , "++lt ts- lt [] = ""--subject = DarcsSingleOption $ DarcsArgOption [] ["subject"] Subject "SUBJECT" "specify mail subject"---- |'getSubject' takes a list of flags and returns the subject of the mail--- to be sent by @darcs send@. Looks for a subject specified by--- @Subject \"subject\"@ in that list of flags, if any.--- This flag is present if darcs was invoked with @--subject=SUBJECT@-getSubject :: [DarcsFlag] -> Maybe String-getSubject (Subject s:_) = Just s-getSubject (_:fs) = getSubject fs-getSubject [] = Nothing--charset = DarcsSingleOption $ DarcsArgOption [] ["charset"] Charset "CHARSET" "specify mail charset"--getCharset :: [DarcsFlag] -> Maybe String-getCharset (Charset s:_) = Just s-getCharset (_:fs) = getCharset fs-getCharset [] = Nothing--inReplyTo = DarcsSingleOption $ DarcsArgOption [] ["in-reply-to"] InReplyTo "EMAIL" "specify in-reply-to header"-getInReplyTo :: [DarcsFlag] -> Maybe String-getInReplyTo (InReplyTo s:_) = Just s-getInReplyTo (_:fs) = getInReplyTo fs-getInReplyTo [] = Nothing--output = DarcsSingleOption $ DarcsAbsPathOrStdOption ['o'] ["output"] Output "FILE"- "specify output filename"--outputAutoName = DarcsSingleOption $- DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY"- "output to automatically named file in DIRECTORY, default: current directory"--getOutput :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd-getOutput (Output a:_) _ = return a-getOutput (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f-getOutput (_:flags) f = getOutput flags f-getOutput [] _ = Nothing--editDescription = mkMutuallyExclusive [] yes [no]- where- yes = ( DarcsNoArgOption [] ["edit-description"]- , EditDescription- , "edit the patch bundle description" )- no = ( DarcsNoArgOption [] ["dont-edit-description","no-edit-description"]- , NoEditDescription- , "don't edit the patch bundle description" )--distnameOption = DarcsSingleOption $- DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME" "name of version"--recursive :: String -> DarcsOption-recursive h- = DarcsMultipleChoiceOption- [DarcsNoArgOption ['r'] ["recursive"] Recursive h,- DarcsNoArgOption [] ["not-recursive","no-recursive"] NoRecursive ("don't "++h)]--patchFormatChoices :: DarcsOption-patchFormatChoices =- DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["hashed"] UseHashedInventory- "Some new features. Compatible with older repos",- DarcsNoArgOption [] ["darcs-2"] UseFormat2- "All features. Related repos must use same format [DEFAULT]."]--useWorkingDir :: DarcsOption-useWorkingDir =- DarcsMultipleChoiceOption- [ DarcsNoArgOption [] ["with-working-dir"] UseWorkingDir- "Create a working directory (normal repository)",- DarcsNoArgOption [] ["no-working-dir"] UseNoWorkingDir- "Do not create a working directory (bare repository)"]--upgradeFormat :: DarcsOption-upgradeFormat = DarcsSingleOption $- DarcsNoArgOption [] ["upgrade"] UpgradeFormat- "upgrade repository to latest compatible format"--xmloutput = DarcsSingleOption $- DarcsNoArgOption [] ["xml-output"] XMLOutput "generate XML formatted output"--creatorhash = DarcsSingleOption $- DarcsArgOption [] ["creator-hash"] CreatorHash "HASH" "specify hash of creator patch (see docs)"--sign = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["sign"] Sign- "sign the patch with your gpg key",- DarcsArgOption [] ["sign-as"] SignAs "KEYID"- "sign the patch with a given keyid",- DarcsArgOption [] ["sign-ssl"] SignSSL "IDFILE"- "sign the patch using openssl with a given private key",- DarcsNoArgOption [] ["dont-sign","no-sign"] NoSign- "don't sign the patch"]-applyas = DarcsMultipleChoiceOption- [DarcsArgOption [] ["apply-as"] ApplyAs "USERNAME"- "apply patch as another user using sudo",- DarcsNoArgOption [] ["no-apply-as"] NonApply- "don't use sudo to apply as another user [DEFAULT]"]--happyForwarding = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["happy-forwarding"] HappyForwarding- "forward unsigned messages without extra header",- DarcsNoArgOption [] ["no-happy-forwarding"] NoHappyForwarding- "don't forward unsigned messages without extra header [DEFAULT]"]--setDefault :: Bool -> DarcsOption-setDefault wantYes- | wantYes = mkMutuallyExclusive [yes,no] defaultyes []- | otherwise = mkMutuallyExclusive [yes,no] defaultno []- where- yes = ( DarcsNoArgOption [] ["set-default"], SetDefault True- , "set default repository" ++ defaultText wantYes )- no = ( DarcsNoArgOption [] ["no-set-default"], NoSetDefault True- , "don't set default repository" ++ defaultText (not wantYes) )- defaultyes = ( \f _ -> DarcsInternalOption f, SetDefault False, "" )- defaultno = ( \f _ -> DarcsInternalOption f, NoSetDefault False, "" )- defaultText True = " [DEFAULT]"- defaultText False = ""--verify = DarcsMultipleChoiceOption- [DarcsAbsPathOption [] ["verify"] Verify "PUBRING"- "verify that the patch was signed by a key in PUBRING",- DarcsAbsPathOption [] ["verify-ssl"] VerifySSL "KEYS"- "verify using openSSL with authorized keys from file KEYS",- DarcsNoArgOption [] ["no-verify"] NonVerify- "don't verify patch signature"]--reponame :: DarcsOption-reponame = DarcsSingleOption $- DarcsArgOption [] ["repo-name","repodir"] NewRepo "DIRECTORY"- "path of output directory" --repodir is there for compatibility- --should be removed eventually-depsSel :: DarcsOption-depsSel = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["no-deps"] DontGrabDeps- "don't automatically fulfill dependencies",- DarcsNoArgOption [] ["dont-prompt-for-dependencies"] DontPromptForDependencies- "don't ask about patches that are depended on by matched patches (with --match or --patch)",- DarcsNoArgOption [] ["prompt-for-dependencies"] PromptForDependencies- "prompt about patches that are depended on by matched patches [DEFAULT]"]--tokens :: DarcsOption-tokens = DarcsSingleOption $- DarcsArgOption [] ["token-chars"] Toks "\"[CHARS]\""- "define token to contain these characters"--partial :: DarcsOption-partial = DarcsMultipleChoiceOption [__lazy, __complete]--__lazy, __complete :: DarcsAtomicOption-__lazy = DarcsNoArgOption [] ["lazy"] Lazy- "get patch files only as needed"-__complete = DarcsNoArgOption [] ["complete"] Complete- "get a complete copy of the repository"--forceReplace = DarcsMultipleChoiceOption- [DarcsNoArgOption ['f'] ["force"] ForceReplace- "proceed with replace even if 'new' token already exists",- DarcsNoArgOption [] ["no-force"]- NonForce "don't force the replace if it looks scary"]--reply = DarcsSingleOption $- DarcsArgOption [] ["reply"] Reply "FROM" "reply to email-based patch using FROM address"-applyConflictOptions- = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["mark-conflicts"]- MarkConflicts "mark conflicts",- DarcsNoArgOption [] ["allow-conflicts"]- AllowConflicts "allow conflicts, but don't mark them",- DarcsNoArgOption [] ["no-resolve-conflicts"] NoAllowConflicts- "equivalent to --dont-allow-conflicts, for backwards compatibility",- DarcsNoArgOption [] ["dont-allow-conflicts","no-allow-conflicts"]- NoAllowConflicts "fail if there are patches that would create conflicts [DEFAULT]",- DarcsNoArgOption [] ["skip-conflicts"]- SkipConflicts "filter out any patches that would create conflicts"- ]-pullConflictOptions- = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["mark-conflicts"]- MarkConflicts "mark conflicts [DEFAULT]",- DarcsNoArgOption [] ["allow-conflicts"]- AllowConflicts "allow conflicts, but don't mark them",- DarcsNoArgOption [] ["dont-allow-conflicts","no-allow-conflicts"]- NoAllowConflicts "fail if there are patches that would create conflicts",- DarcsNoArgOption [] ["skip-conflicts"]- SkipConflicts "filter out any patches that would create conflicts"- ]-useExternalMerge = DarcsSingleOption $- DarcsArgOption [] ["external-merge"] ExternalMerge "COMMAND"- "use external tool to merge conflicts"---- NOTE: I'd rather work to have no uses of dryRunNoxml, so that any time--- --dry-run is a possibility, automated users can examine the results more--- easily with --xml.-dryRunNoxml :: DarcsOption-dryRunNoxml = DarcsSingleOption $- DarcsNoArgOption [] ["dry-run"] DryRun "don't actually take the action"--dryRun :: [DarcsOption]-dryRun = [dryRunNoxml, xmloutput]---- | @'showFriendly' flags patch@ returns a 'Doc' representing the right--- way to show @patch@ given the list @flags@ of flags darcs was invoked with.-showFriendly :: Patchy p => [DarcsFlag] -> p C(x y) -> Doc-showFriendly opts p | Verbose `elem` opts = showNicely p- | Summary `elem` opts = Darcs.Patch.summary p- | otherwise = description p---- | @'printDryRunMessageAndExit' action opts patches@ prints a string--- representing the action that would be taken if the @--dry-run@ option--- had not been passed to darcs. Then darcs exits successfully.--- @action@ is the name of the action being taken, like @\"push\"@--- @opts@ is the list of flags which were sent to darcs--- @patches@ is the sequence of patches which would be touched by @action@.-printDryRunMessageAndExit :: (RepoPatch p, ApplyState p ~ Tree) => String -> [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO ()-printDryRunMessageAndExit action opts patches =- do when (DryRun `elem` opts) $ do- putInfo $ text $ "Would " ++ action ++ " the following changes:"- putDocLn $ put_mode- putInfo $ text $ ""- putInfo $ text $ "Making no changes: this is a dry run."- exitWith ExitSuccess- when (All `elem` opts && Summary `elem` opts) $ do- putInfo $ text $ "Will " ++ action ++ " the following changes:"- putDocLn $ put_mode- where put_mode = if XMLOutput `elem` opts- then (text "<patches>" $$- vcat (mapFL (indent . xml_info) patches) $$- text "</patches>")- else (vsep $ mapFL (showFriendly opts) patches)- putInfo = if XMLOutput `elem` opts then \_ -> return () else putDocLn- xml_info pl- | Summary `elem` opts = xml_with_summary pl- | otherwise = (toXml . info) pl-- xml_with_summary hp- | Just p <- hopefullyM hp = insertBeforeLastline- (toXml $ info hp) (indent $ xmlSummary p)- xml_with_summary hp = toXml (info hp)- indent = prefix " "---noskipBoring = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["boring"]- Boring "don't skip boring files",- DarcsNoArgOption [] ["no-boring"]- SkipBoring "skip boring files [DEFAULT]"]--allowProblematicFilenames = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["case-ok"] AllowCaseOnly- "don't refuse to add files differing only in case"- ,DarcsNoArgOption [] ["no-case-ok"] DontAllowCaseOnly- "refuse to add files whose name differ only in case [DEFAULT]"- ,DarcsNoArgOption [] ["reserved-ok"] AllowWindowsReserved- "don't refuse to add files with Windows-reserved names"- ,DarcsNoArgOption [] ["no-reserved-ok"] DontAllowWindowsReserved- "refuse to add files with Windows-reserved names [DEFAULT]"]--diffflags = DarcsSingleOption $- DarcsArgOption [] ["diff-opts"]- DiffFlags "OPTIONS" "options to pass to diff"--changesFormat = concatOptions $- [DarcsMultipleChoiceOption [- DarcsNoArgOption [] ["context"]- GenContext "give output suitable for get --context" ],- xmloutput,- humanReadable,- DarcsMultipleChoiceOption [- DarcsNoArgOption [] ["number"] NumberPatches "number the changes",- DarcsNoArgOption [] ["count"] Count "output count of changes" ]- ]-changesReverse = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["reverse"] Reverse- "show changes in reverse order"- ,DarcsNoArgOption [] ["no-reverse"] Forward- "show changes in the usual order [DEFAULT]"]--onlyToFiles :: DarcsOption-onlyToFiles = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["only-to-files"] OnlyChangesToFiles- "show only changes to specified files",- DarcsNoArgOption [] ["no-only-to-files"] ChangesToAllFiles- "show changes to all files [DEFAULT]"]---humanReadable = DarcsSingleOption $- DarcsNoArgOption [] ["human-readable"] HumanReadable "give human-readable output"--machineReadable = DarcsSingleOption $- DarcsNoArgOption [] ["machine-readable"] MachineReadable "give machine-readable output"--pipe :: DarcsAtomicOption-pipe =- DarcsNoArgOption [] ["pipe"] Pipe "ask user interactively for the patch metadata"--interactive :: DarcsAtomicOption-interactive =- DarcsNoArgOption ['i'] ["interactive"] Interactive- "prompt user interactively"--allPatches :: DarcsAtomicOption-allPatches =- DarcsNoArgOption ['a'] ["all"] All "answer yes to all patches"--allInteractive = DarcsMultipleChoiceOption [allPatches, interactive]--allPipeInteractive- = DarcsMultipleChoiceOption [allPatches,pipe,interactive]--pipeInteractive =- DarcsMultipleChoiceOption [pipe, interactive]--repoCombinator =- DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["intersection"] Intersection- "take intersection of all repositories",- DarcsNoArgOption [] ["union"] Union- "take union of all repositories [DEFAULT]",- DarcsNoArgOption [] ["complement"] Complement- "take complement of repositories (in order listed)"]---- | Get a list of all non-boring files and directories in the working copy.-listFiles :: IO [String]-listFiles = do nonboring <- restrictBoring emptyTree- working <- expand =<< applyTreeFilter nonboring <$> readPlainTree "."- return $ map (anchorPath "" . fst) $ list working---- | 'listUnregisteredFiles' returns the list of all non-boring unregistered--- files in the repository.-listUnregisteredFiles :: IO [String]-listUnregisteredFiles =- do unregd <- listFiles- regd <- listRegisteredFiles- return $ unregd \\ regd -- (inefficient)---- | 'listRegisteredFiles' returns the list of all registered files in the repository.-listRegisteredFiles :: IO [String]-listRegisteredFiles =- do recorded <- expand =<< withRepository [] (RepoJob readRecordedAndPending)- return $ map (anchorPath "" . fst) $ list recorded--optionsLatex :: [DarcsOption] -> String-optionsLatex opts = "\\begin{tabular}{lll}\n"++- unlines (map optionListLatex opts)++- "\\end{tabular}\n"--latexHelp :: String -> String-latexHelp h- = "\\begin{minipage}{7cm}\n\\raggedright\n" ++ h ++ "\\end{minipage}\n"--optionListLatex :: DarcsOption -> String-optionListLatex (DarcsSingleOption o) = optionLatex o-optionListLatex (DarcsMultipleChoiceOption os) = unlines (map optionLatex os)-optionListLatex (DarcsMutuallyExclusive os _) = unlines (map optionLatex os)--optionLatex :: DarcsAtomicOption -> String-optionLatex (DarcsInternalOption _) = ""-optionLatex (DarcsNoArgOption a b _ h) =- showShortOptions a ++ showLongOptions b ++ latexHelp h ++ "\\\\"-optionLatex (DarcsArgOption a b _ arg h) =- showShortOptions a ++- showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\"-optionLatex (DarcsAbsPathOrStdOption a b _ arg h) =- showShortOptions a ++- showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\"-optionLatex (DarcsAbsPathOption a b _ arg h) =- showShortOptions a ++- showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\"-optionLatex (DarcsOptAbsPathOption a b _ _ arg h) =- showShortOptions a ++- showLongOptions (map (++("[="++arg++"]")) b) ++ latexHelp h ++ "\\\\"--showShortOptions :: [Char] -> String-showShortOptions [] = "&"-showShortOptions [c] = "\\verb!-"++[c]++"! &"-showShortOptions (c:cs) = "\\verb!-"++[c]++"!,"++showShortOptions cs--showLongOptions :: [String] -> String-showLongOptions [] = " &"-showLongOptions [s] = "\\verb!--" ++ s ++ "! &"-showLongOptions (s:ss)- = "\\verb!--" ++ s ++ "!,"++ showLongOptions ss--setScriptsExecutableOption :: DarcsOption-setScriptsExecutableOption = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["set-scripts-executable"] SetScriptsExecutable- "make scripts executable",- DarcsNoArgOption [] ["dont-set-scripts-executable","no-set-scripts-executable"] DontSetScriptsExecutable- "don't make scripts executable"]--bisect :: DarcsOption-bisect = DarcsSingleOption $ DarcsNoArgOption [] ["bisect"] Bisect- "binary instead of linear search"--relink, sibling :: DarcsOption-relink = DarcsSingleOption $ DarcsNoArgOption [] ["relink"] Relink- "relink random internal data to a sibling"--sibling = DarcsSingleOption $- DarcsAbsPathOption [] ["sibling"] Sibling "URL"- "specify a sibling directory"---- | 'flagsToSiblings' collects the contents of all @Sibling@ flags in a list of flags.-flagsToSiblings :: [DarcsFlag] -> [AbsolutePath]-flagsToSiblings ((Sibling s) : l) = s : (flagsToSiblings l)-flagsToSiblings (_ : l) = flagsToSiblings l-flagsToSiblings [] = []--reorderPatches :: DarcsOption-reorderPatches = DarcsSingleOption $ DarcsNoArgOption [] ["reorder-patches"] Reorder- "reorder the patches in the repository"--sendmailCmd = DarcsSingleOption $- DarcsArgOption [] ["sendmail-command"] SendmailCmd "COMMAND" "specify sendmail command"--environmentHelpSendmail :: ([String], [String])-environmentHelpSendmail = (["SENDMAIL"], [- "On Unix, the `darcs send' command relies on sendmail(8). The",- "`--sendmail-command' or $SENDMAIL environment variable can be used to",- "provide an explicit path to this program; otherwise the standard",- "locations /usr/sbin/sendmail and /usr/lib/sendmail will be tried."])--- FIXME: mention the following also:--- * sendmail(8) is not sendmail-specific;--- * nowadays, desktops often have no MTA or an unconfigured MTA ----- which is awful, because it accepts mail but doesn't relay it;--- * in this case, can be a sendmail(8)-emulating wrapper on top of an--- MUA that sends mail directly to a smarthost; and--- * on a multi-user system without an MTA and on which you haven't--- got root, can be msmtp.---- |'getSendmailCmd' takes a list of flags and returns the sendmail command--- to be used by @darcs send@. Looks for a command specified by--- @SendmailCmd \"command\"@ in that list of flags, if any.--- This flag is present if darcs was invoked with @--sendmail-command=COMMAND@--- Alternatively the user can set @$S@@ENDMAIL@ which will be used as a fallback if present.-getSendmailCmd :: [DarcsFlag] -> IO String-getSendmailCmd (SendmailCmd a:_) = return a-getSendmailCmd (_:flags) = getSendmailCmd flags-getSendmailCmd [] = do easy_sendmail <- firstJustIO [ maybeGetEnv "SENDMAIL" ]- case easy_sendmail of- Just a -> return a- Nothing -> return ""--files :: DarcsOption-files = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["files"] Files- "include files in output [DEFAULT]",- DarcsNoArgOption [] ["no-files"] NoFiles- "don't include files in output"]--directories :: DarcsOption-directories = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["directories"] Directories- "include directories in output [DEFAULT]",- DarcsNoArgOption [] ["no-directories"] NoDirectories- "don't include directories in output"]--pending :: DarcsOption-pending = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["pending"] Pending- "reflect pending patches in output [DEFAULT]",- DarcsNoArgOption [] ["no-pending"] NoPending- "only included recorded patches in output"]--nullFlag :: DarcsOption -- "null" is already taken-nullFlag = DarcsSingleOption $ DarcsNoArgOption ['0'] ["null"] NullFlag- "separate file names by NUL characters"---- | Set the DARCS_PATCHES and DARCS_PATCHES_XML environment variables--- with info about the given patches, for use in post-hooks.-setEnvDarcsPatches :: (RepoPatch p, ApplyState p ~ Tree) => FL (PatchInfoAnd p) C(x y) -> IO ()-#ifndef WIN32-setEnvDarcsPatches ps = do- let k = "Defining set of chosen patches"- beginTedious k- tediousSize k 3- finishedOneIO k "DARCS_PATCHES"- setEnvCautiously "DARCS_PATCHES" (renderString $ Darcs.Patch.summary ps)- finishedOneIO k "DARCS_PATCHES_XML"- setEnvCautiously "DARCS_PATCHES_XML"- (renderString $ text "<patches>" $$- vcat (mapFL (toXml . info) ps) $$- text "</patches>")- finishedOneIO k "DARCS_FILES"- setEnvCautiously "DARCS_FILES" (unlines$ listTouchedFiles ps)- endTedious k---- | Set some environment variable to the given value, unless said value--- is longer than 10K characters, in which case do nothing.-setEnvCautiously :: String -> String -> IO ()-setEnvCautiously e v | toobig (10*1024) v = return ()- | otherwise = setEnv e v True- where toobig :: Int -> [a] -> Bool- toobig 0 _ = True- toobig _ [] = False- toobig n (_:xs) = toobig (n-1) xs-#else-setEnvDarcsPatches _ = return ()-#endif---- | Set the DARCS_FILES environment variable to the files touched by the--- given patch, one per line, for use in post-hooks.-setEnvDarcsFiles :: Patchy p => p C(x y) -> IO ()-#ifndef WIN32-setEnvDarcsFiles ps = setEnvCautiously "DARCS_FILES" (unlines $ listTouchedFiles ps)-#else-setEnvDarcsFiles _ = return ()-#endif--posthookCmd :: DarcsOption-posthookCmd = DarcsMultipleChoiceOption- [DarcsArgOption [] ["posthook"] PosthookCmd- "COMMAND" "specify command to run after this darcs command",- DarcsNoArgOption [] ["no-posthook"] NoPosthook- "don't run posthook command"]--posthookPrompt :: DarcsOption-posthookPrompt = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["prompt-posthook"] AskPosthook- "prompt before running posthook [DEFAULT]",- DarcsNoArgOption [] ["run-posthook"] RunPosthook- "run posthook command without prompting"]---- | 'getPosthookCmd' takes a list of flags and returns the posthook command--- specified by @PosthookCmd a@ in that list of flags, if any.-getPosthookCmd :: [DarcsFlag] -> Maybe String-getPosthookCmd (PosthookCmd a:_) = Just a-getPosthookCmd (NoPosthook:_) = Nothing-getPosthookCmd (_:flags) = getPosthookCmd flags-getPosthookCmd [] = Nothing--prehookCmd :: DarcsOption-prehookCmd = DarcsMultipleChoiceOption- [DarcsArgOption [] ["prehook"] PrehookCmd- "COMMAND" "specify command to run before this darcs command",- DarcsNoArgOption [] ["no-prehook"] NoPrehook- "don't run prehook command"]--prehookPrompt :: DarcsOption-prehookPrompt = DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["prompt-prehook"] AskPrehook- "prompt before running prehook [DEFAULT]",- DarcsNoArgOption [] ["run-prehook"] RunPrehook- "run prehook command without prompting"]---- | 'getPrehookCmd' takes a list of flags and returns the prehook command--- specified by @PrehookCmd a@ in that list of flags, if any.-getPrehookCmd :: [DarcsFlag] -> Maybe String-getPrehookCmd (PrehookCmd a:_) = Just a-getPrehookCmd (NoPrehook:_) = Nothing-getPrehookCmd (_:flags) = getPrehookCmd flags-getPrehookCmd [] = Nothing--networkOptions :: [DarcsOption]-networkOptions =- [ DarcsMultipleChoiceOption- [ DarcsNoArgOption [] ["no-http-pipelining"] NoHTTPPipelining- "disable HTTP pipelining"- ]- , remoteDarcs ]--remoteDarcs :: DarcsOption-remoteDarcs = DarcsSingleOption $- DarcsArgOption [] ["remote-darcs"] RemoteDarcsOpt "COMMAND"- "name of the darcs executable on the remote server"--noCache :: DarcsOption-noCache = DarcsSingleOption $- DarcsNoArgOption [] ["no-cache"] NoCache- "don't use patch caches"--optimizePristine :: DarcsOption-optimizePristine = DarcsSingleOption $- DarcsNoArgOption [] ["pristine"] OptimizePristine- "optimize hashed pristine layout"--optimizeHTTP :: DarcsOption-optimizeHTTP = DarcsSingleOption $- DarcsNoArgOption [] ["http"] OptimizeHTTP- "optimize repository for getting over network"--usePacks :: DarcsOption-usePacks = DarcsMultipleChoiceOption- [ DarcsNoArgOption [] ["packs"] Packs "use repository packs [DEFAULT]"- , DarcsNoArgOption [] ["no-packs"] NoPacks- "don't use repository packs"- ]--umaskOption :: DarcsOption-umaskOption = DarcsSingleOption $- DarcsArgOption [] ["umask"] UMask "UMASK"- "specify umask to use when writing"--restrictPaths :: DarcsOption-restrictPaths =- DarcsMultipleChoiceOption- [DarcsNoArgOption [] ["restrict-paths"] RestrictPaths- "don't allow darcs to touch external files or repo metadata",- DarcsNoArgOption [] ["dont-restrict-paths","no-restrict-paths"] DontRestrictPaths- "allow darcs to modify any file or directory (unsafe)"]--allowUnrelatedRepos = DarcsSingleOption $- DarcsNoArgOption [] ["ignore-unrelated-repos"] AllowUnrelatedRepos- "do not check if repositories are unrelated"--justThisRepo :: DarcsOption-justThisRepo = DarcsSingleOption $- DarcsNoArgOption [] ["just-this-repo"] JustThisRepo- "Limit the check or repair to the current repo"--check, repair, checkOrRepair :: DarcsOption-check = DarcsSingleOption $- DarcsNoArgOption [] ["check"] Check- "Specify checking mode"-repair = DarcsSingleOption $- DarcsNoArgOption [] ["repair"] Repair- "Specify repair mode"-checkOrRepair = concatOptions [check, repair]---- | @'patchSelectFlag' f@ holds whenever @f@ is a way of selecting--- patches such as @PatchName n@.-patchSelectFlag :: DarcsFlag -> Bool-patchSelectFlag All = True-patchSelectFlag (PatchName _) = True-patchSelectFlag (OnePatch _) = True-patchSelectFlag (SeveralPatch _) = True-patchSelectFlag (AfterPatch _) = True-patchSelectFlag (UpToPatch _) = True-patchSelectFlag (TagName _) = True-patchSelectFlag (LastN _) = True-patchSelectFlag (OneTag _) = True-patchSelectFlag (AfterTag _) = True-patchSelectFlag (UpToTag _) = True-patchSelectFlag (OnePattern _) = True-patchSelectFlag (SeveralPattern _) = True-patchSelectFlag (AfterPattern _) = True-patchSelectFlag (UpToPattern _) = True-patchSelectFlag _ = False---- | The integer corresponding to a string, if it's only composed of digits.--- Otherwise, -1.-numberString :: String -> Int-numberString "" = -1-numberString s = if all isDigit s then read s else (-1)--makeScriptsExecutable :: Patchy p => [DarcsFlag] -> p C(x y) -> IO ()-makeScriptsExecutable opts p =- when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches p
− src/Darcs/Bug.hs
@@ -1,27 +0,0 @@--- Reporting bugs in darcs. See also impossible.h.-module Darcs.Bug ( _bug, _bugDoc, _impossible, _fromJust- ) where--import Printer ( Doc, errorDoc, text, ($$) )--type BugStuff = (String, Int, String, String)--_bug :: BugStuff -> String -> a-_bug bs s = _bugDoc bs (text s)--_bugDoc :: BugStuff -> Doc -> a-_bugDoc bs s = errorDoc $- text ("bug at " ++ _bugLoc bs) $$ s $$- text ("See http://wiki.darcs.net/BugTracker/Reporting " ++- "for help on bug reporting.")--_bugLoc :: BugStuff -> String-_bugLoc (file, line, date, time) = file++":"++show line++" compiled "++time++" "++date--_impossible :: BugStuff -> a-_impossible bs = _bug bs $ "Impossible case at "++_bugLoc bs--_fromJust :: BugStuff -> Maybe a -> a-_fromJust bs mx =- case mx of Nothing -> _bug bs $ "fromJust error at "++_bugLoc bs- Just x -> x
− src/Darcs/ColorPrinter.hs
@@ -1,285 +0,0 @@-{-# 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)-import Printer (Printer, Printers, Printers'(..), Printable(..), Color(..),- invisiblePrinter, (<>), (<?>), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat,- unsafeText, unsafePackedString,- renderStringWith, prefix )-import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr )-import Data.Bits ( bit, xor )-import System.Environment ( getEnv )-import qualified Data.ByteString.Char8 as BC (unpack, any, last, spanEnd)-import qualified Data.ByteString as B (null, init)-import System.IO.Unsafe ( unsafePerformIO )-import System.IO ( hIsTerminalDevice, Handle )-import Text.Printf ( printf )--dollar, cr :: Doc-dollar = unsafeBothText "$"-cr = unsafeBothText "\r"--errorDoc :: Doc -> a-errorDoc = error . show--traceDoc :: Doc -> a -> a-traceDoc d = trace (show d)--assertDoc :: Maybe Doc -> a -> a-assertDoc Nothing x = x-assertDoc (Just e) _ = errorDoc e--instance Show Doc where- show = renderStringWith (fancyPrinters stderr)---- policy--- | the 'Policy' type is a record containing the variables which control--- how 'Doc's will be rendered on some output.-data Policy = Policy { poColor :: Bool -- ^ overall use of color- , poEscape :: Bool -- ^ overall use of escaping- , poLineColor :: Bool -- ^ overall use of colored lines (only hunks for now)- , poAltColor :: Bool -- ^ alternative to color (bold, inverse)- , poIsprint :: Bool -- ^ don't escape isprints- , po8bit :: Bool -- ^ don't escape 8-bit chars- , poNoEscX :: String -- ^ extra chars to never escape- , poEscX :: String -- ^ extra chars to always escape- , poTrailing :: Bool -- ^ escape trailing spaces- , poCR :: Bool -- ^ ignore \r at end of lines- , poSpace :: Bool -- ^ escape spaces (used with poTrailing)- }--{-# NOINLINE getPolicy #-}--- | 'getPolicy' returns a suitable policy for a given handle.--- The policy is chosen according to environment variables, and to the--- type of terminal which the handle represents-getPolicy :: Handle -> Policy-getPolicy handle = unsafePerformIO $- do isTerminal <- hIsTerminalDevice handle- nColors <- if isTerminal then getTermNColors else return 0-- envDontEscapeAnything <- getEnvBool "DARCS_DONT_ESCAPE_ANYTHING"- envDontEscapeIsprint <- getEnvBool "DARCS_DONT_ESCAPE_ISPRINT"- envUseIsprint <- getEnvBool "DARCS_USE_ISPRINT" -- for backwards-compatibility- envDontEscape8bit <- getEnvBool "DARCS_DONT_ESCAPE_8BIT"-- envDontEscapeExtra <- getEnvString "DARCS_DONT_ESCAPE_EXTRA"- envEscapeExtra <- getEnvString "DARCS_ESCAPE_EXTRA"-- envDontEscapeTrailingSpace <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_SPACES"- envDontEscapeTrailingCR <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_CR"-- envDontColor <- getEnvBool "DARCS_DONT_COLOR"- envAlwaysColor <- getEnvBool "DARCS_ALWAYS_COLOR"- envAlternativeColor <- getEnvBool "DARCS_ALTERNATIVE_COLOR"- envDoColorLines <- getEnvBool "DARCS_DO_COLOR_LINES"-- let haveColor = envAlwaysColor || (isTerminal && (nColors > 4))- doColor = not envDontColor && haveColor-- return Policy { poColor = doColor,- poEscape = not envDontEscapeAnything,- poLineColor= doColor && envDoColorLines,- poIsprint = envDontEscapeIsprint || envUseIsprint,- po8bit = envDontEscape8bit,- poNoEscX = envDontEscapeExtra,- poEscX = envEscapeExtra,- poTrailing = not envDontEscapeTrailingSpace,- poCR = envDontEscapeTrailingCR,- poAltColor = haveColor && envAlternativeColor,-- poSpace = False- }- where- getEnvBool s = safeGetEnv s >>= return.(/= "0")- safeGetEnv s = getEnv s `catch` \(_ :: IOException) -> return "0"- getEnvString s = getEnv s `catch` \(_ :: IOException) -> return ""----- printers---- | @'fancyPrinters' h@ returns a set of printers suitable for outputting--- to @h@-fancyPrinters :: Printers-fancyPrinters h = let policy = getPolicy h in- Printers { colorP = colorPrinter policy,- invisibleP = invisiblePrinter,- hiddenP = colorPrinter policy Green,- userchunkP = userchunkPrinter policy,- defP = escapePrinter policy,- lineColorT = lineColorTrans policy,- lineColorS = lineColorSuffix policy- }---- | @'lineColorTrans' policy@ tries to color a Doc, according to policy po.--- That is, if @policy@ has @poLineColor@ set, then colors the line, otherwise--- does nothing.-lineColorTrans :: Policy -> Color -> Doc -> Doc-lineColorTrans po | poLineColor po = \c d -> prefix (setColor c) d <?> unsafeBothText resetColor- | otherwise = const id--lineColorSuffix :: Policy -> [Printable] -> [Printable]-lineColorSuffix po | poLineColor po = \d -> S resetColor : d- | otherwise = id--colorPrinter :: Policy -> Color -> Printer-colorPrinter po | poColor po = \c -> unDoc . color po c . Doc . escapePrinter po{poColor=False}- | otherwise = const $ escapePrinter po--userchunkPrinter :: Policy -> Printer-userchunkPrinter po p- | not (poEscape po) = simplePrinter p- | not (poTrailing po) = escapePrinter po p- | otherwise = unDoc $ pr p- where- pr (S s) = prString s- pr (Both _ ps) = prPS ps- pr (PS ps) = prPS ps-- prPS ps = let (leadPS, trailPS) = BC.spanEnd isSpace ps- in if B.null trailPS- then Doc $ escapePrinter po p- else Doc (escapePrinter po (PS leadPS))- <> Doc (escapePrinter po{poSpace=True} (PS trailPS))- <> markEscape po dollar-- prString s = let (trail',lead') = span isSpace (reverse s)- lead = reverse lead'- trail = reverse trail'- in if (not.null) trail- then Doc (escapePrinter po (S lead))- <> Doc (escapePrinter po{poSpace=True} (S trail))- <> markEscape po dollar- else Doc (escapePrinter po p)--escapePrinter :: Policy -> Printer-escapePrinter po- | (not.poEscape) po = simplePrinter- | otherwise = unDoc . crepr- where- crepr p | poCR po && isEndCR p = epr (initPR p) <> cr- | otherwise = epr p-- epr (S s) = escape po s- epr (PS ps) = if BC.any (not.noEscape po) ps- then escape po (BC.unpack ps)- else unsafePackedString ps- epr (Both s _) = escape po s-- isEndCR (S s) = not (null s) && last s == '\r'- isEndCR (PS ps) = not (B.null ps) && BC.last ps == '\r'- isEndCR (Both _ ps) = not (B.null ps) && BC.last ps == '\r'-- initPR (S s) = S $ init s- initPR (PS ps) = PS $ B.init ps- initPR (Both s ps) = Both (init s) (B.init ps)----- | @'escape' policy string@ escapes @string@ according to the rules--- defined in 'policy', turning it into a 'Doc'.-escape :: Policy -> String -> Doc-escape _ "" = unsafeText ""-escape po s = hcat $ escape' s- where- escape' "" = []- escape' s'@(c:_) | mundane c =- let (printables, rest) = span mundane s' in- (unsafeText printables):(escape' rest)- escape' (c:rest) = (emph . unsafeText $ quoteChar c):(escape' rest)- mundane c = (noEscape po c) || (c == ' ')- emph = (markEscape po)----- | @'noEscape' policy c@ tells wether @c@ will be left as-is--- when escaping according to @policy@-noEscape :: Policy -> Char -> Bool-noEscape po c | poSpace po && isSpace c = False-noEscape po c | c `elem` poEscX po = False-noEscape po c | c `elem` poNoEscX po = True-noEscape _ '\t' = True -- tabs will likely be converted to spaces-noEscape _ '\n' = True-noEscape po c = if (poIsprint po) then isPrint c- else isPrintableAscii c- || c >= '\x80' && po8bit po---- | 'isPrintableAscii' tells wether a character is a printable character--- of the ascii range.-isPrintableAscii :: Char -> Bool-isPrintableAscii c = isAscii c && isPrint c----- | 'quoteChar' represents a special character as a string.--- * @quoteChar '^c'@ (where @^c@ is a control character) is @"^c"@--- * Otherwise, @quoteChar@ returns "\hex", where 'hex' is the--- hexadecimal number of the character.-quoteChar :: Char -> String-quoteChar c- | isControl c && isPrintableAscii cHat = ['^', cHat]- | otherwise = sHex- where- cHat = chr $ (bit 6 `xor`) $ ord c- sHex = "<U+" ++ printf "%04X" c ++ ">"----- make colors and highlightings---- | @'markEscape' policy doc@ marks @doc@ with the appropriate--- marking for escaped characters according to @policy@-markEscape :: Policy -> Doc -> Doc-markEscape po | poAltColor po = makeInvert- | poColor po = makeColor Red- | otherwise = makeAsciiart---- | @'color' policy color doc@ colors @doc@ with color @color@ if--- @policy@ is not set to use an alternative to color. In that case,--- it makes the text bold instead.-color :: Policy -> Color -> Doc -> Doc-color po | poAltColor po = \_ -> makeBold- | otherwise = makeColor--makeColor, makeColor' :: Color -> Doc -> Doc--makeColor' = withColor . setColor---- memoized version of makeColor'-makeColor Blue = makeColor' Blue-makeColor Red = makeColor' Red-makeColor Green = makeColor' Green-makeColor Cyan = makeColor' Cyan-makeColor Magenta = makeColor' Magenta--setColor :: Color -> String-setColor Blue = "\x1B[01;34m" -- bold blue-setColor Red = "\x1B[01;31m" -- bold red-setColor Green = "\x1B[01;32m" -- bold green-setColor Cyan = "\x1B[36m" -- light cyan-setColor Magenta = "\x1B[35m" -- light magenta---- | @'makeAsciiart' doc@ tries to make @doc@ (usually a--- single escaped char) stand out with the help of only plain--- ascii, i.e., no color or font style.-makeAsciiart :: Doc -> Doc-makeAsciiart x = unsafeBothText "[_" <> x <> unsafeBothText "_]"---- | the string to reset the terminal's color.-resetColor :: String-resetColor = "\x1B[00m"---- | @'withColor' color doc@ returns a colorized version of @doc@.--- @color@ is a string that represents a color, given by 'setColor'-withColor :: String -> Doc -> Doc-withColor c =- let c' = unsafeBothText c- r' = unsafeBothText resetColor- in \x -> c' <> x <> r'----- | 'makeBold' boldens a doc.-makeBold :: Doc -> Doc--- | 'makeInvert' returns an invert video version of a doc.-makeInvert :: Doc -> Doc-makeBold = withColor "\x1B[01m"-makeInvert = withColor "\x1B[07m"
− src/Darcs/Commands.hs
@@ -1,242 +0,0 @@--- Copyright (C) 2002,2003,2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Commands ( CommandControl( CommandData, HiddenCommand, GroupName ),- DarcsCommand( DarcsCommand, commandProgramName, commandName,- commandHelp, commandDescription,- commandBasicOptions, commandAdvancedOptions,- commandCommand,- commandPrereq,- commandExtraArgHelp,- commandExtraArgs,- commandArgdefaults,- commandGetArgPossibilities,- SuperCommand,- commandSubCommands ),- commandAlias, commandStub,- commandOptions, commandAlloptions,- disambiguateCommands, CommandArgs(..),- getCommandHelp, getCommandMiniHelp,- getSubcommands,- usage, usageHelper, subusage, chompNewline,- extractCommands,- superName,- nodefaults,- putInfo, putVerbose, putWarning, abortRun- ) where--import System.Console.GetOpt( OptDescr, usageInfo )-import Control.Monad (when, unless)--import Data.List ( sort, isPrefixOf )-import Darcs.Arguments ( DarcsFlag(Quiet,Verbose, DryRun), DarcsOption, disable, help,- anyVerbosity, noCache, posthookCmd, posthookPrompt,- prehookCmd, prehookPrompt, optionFromDarcsOption )-import Darcs.RepoPath ( AbsolutePath, rootDirectory )-import Printer ( Doc, putDocLn, hPutDocLn, text, (<+>), errorDoc )-import System.IO ( stderr )--extractCommands, extractHiddenCommands :: [CommandControl] -> [DarcsCommand]-extractCommands cs = concatMap (\x -> case x of { CommandData cmd_d -> [cmd_d]; _ -> []}) cs-extractHiddenCommands cs = concatMap (\x -> case x of { HiddenCommand cmd_d -> [cmd_d]; _ -> []}) cs--data CommandControl = CommandData DarcsCommand- | HiddenCommand DarcsCommand- | GroupName String--data DarcsCommand =- DarcsCommand {commandProgramName, commandName, commandHelp, commandDescription :: String,- commandExtraArgs :: Int,- commandExtraArgHelp :: [String],- commandCommand :: [DarcsFlag] -> [String] -> IO (),- commandPrereq :: [DarcsFlag] -> IO (Either String ()),- commandGetArgPossibilities :: IO [String],- commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String],- commandBasicOptions :: [DarcsOption],- commandAdvancedOptions :: [DarcsOption]}- | SuperCommand {commandProgramName, commandName, commandHelp, commandDescription :: String,- commandPrereq :: [DarcsFlag] -> IO (Either String ()),- commandSubCommands :: [CommandControl]}--commandAlloptions :: DarcsCommand -> ([DarcsOption], [DarcsOption])-commandAlloptions DarcsCommand { commandBasicOptions = opts1- , commandAdvancedOptions = opts2 }- = (opts1 ++ [disable, help],- anyVerbosity ++ opts2 ++- [noCache- ,posthookCmd, posthookPrompt- ,prehookCmd, prehookPrompt])---- Supercommands cannot be disabled.-commandAlloptions SuperCommand { } = ([help],[])---- Obtain options suitable as input to--- System.Console.Getopt, including the --disable option (which is--- not listed explicitly in the DarcsCommand definitions).-commandOptions :: AbsolutePath -> DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag])-commandOptions cwd c = (convert basic, convert advanced)- where (basic, advanced) = commandAlloptions c- convert = concatMap (optionFromDarcsOption cwd)--nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]-nodefaults _ _ xs = return xs--getSubcommands :: DarcsCommand -> [CommandControl]-getSubcommands c@(SuperCommand {}) = commandSubCommands c-getSubcommands _ = []--commandAlias :: String -> Maybe DarcsCommand -> DarcsCommand -> DarcsCommand-commandAlias n msuper c =- c { commandName = n- , commandDescription = "Alias for `" ++ commandProgramName c ++ " " ++ cmdName ++ "'."- , commandHelp = "The `" ++ commandProgramName c ++ " " ++ n ++ "' command is an alias for " ++- "`" ++ commandProgramName c ++ " " ++ cmdName ++ "'.\n" ++- commandHelp c- }- where- cmdName = unwords . map commandName . maybe id (:) msuper $ [ c ]--commandStub :: String -> String -> String -> DarcsCommand -> DarcsCommand-commandStub n h d c =- c { commandName = n- , commandHelp = h- , commandDescription = d- , commandCommand = \_ _ -> putStr h- }--usage :: [CommandControl] -> String-usage cs = "Usage: darcs COMMAND ...\n\nCommands:\n" ++- usageHelper cs ++ "\n" ++- "Use 'darcs COMMAND --help' for help on a single command.\n" ++- "Use 'darcs --version' to see the darcs version number.\n" ++- "Use 'darcs --exact-version' to get the exact version of this darcs instance.\n" ++- "Use 'darcs help patterns' for help on patch matching.\n" ++- "Use 'darcs help environment' for help on environment variables.\n" ++- "\n" ++- "Check bug reports at http://bugs.darcs.net/\n"--subusage :: DarcsCommand -> String-subusage super =- (usageInfo- ("Usage: " ++ commandProgramName super ++ " "++commandName super++" SUBCOMMAND ... " ++- "\n\n"++ commandDescription super++- "\n\nSubcommands:\n" ++ usageHelper (getSubcommands super) ++ "\nOptions:")- (optionFromDarcsOption rootDirectory help))- ++ "\n" ++ commandHelp super--usageHelper :: [CommandControl] -> String-usageHelper [] = ""-usageHelper (HiddenCommand _:cs) = usageHelper cs-usageHelper ((CommandData c):cs) = " "++padSpaces (commandName c) 15 ++- chompNewline (commandDescription c)++"\n"++usageHelper cs-usageHelper ((GroupName n):cs) = "\n" ++ n ++ "\n" ++ usageHelper cs--chompNewline :: String -> String-chompNewline "" = ""-chompNewline s = if last s == '\n' then init s else s--padSpaces :: String -> Int -> String-padSpaces s n = s ++ replicate (n - length s) ' '--superName :: Maybe DarcsCommand -> String-superName Nothing = ""-superName (Just x) = commandName x ++ " "--getCommandMiniHelp :: Maybe DarcsCommand -> DarcsCommand -> String-getCommandMiniHelp msuper cmd =- getCommandHelpCore msuper cmd ++- "\n\nSee " ++ commandProgramName cmd ++ " help "- ++ (maybe "" (\c -> commandName c ++ " ") msuper)- ++ commandName cmd ++ " for details."--getCommandHelp :: Maybe DarcsCommand -> DarcsCommand -> String-getCommandHelp msuper cmd =- unlines (reverse basicR)- ++ (if null advanced then ""- else "\nAdvanced options:\n" ++ unlines (reverse advancedR))- ++ "\n" ++ commandHelp cmd- where -- we could just call usageInfo twice, but then the advanced- -- options might not line up with the basic ones (no short flags)- (advancedR, basicR) =- splitAt (length advanced) $ reverse $ lines combinedUsage- combinedUsage = usageInfo- (getCommandHelpCore msuper cmd ++ subcommands ++ "\n\nOptions:")- (basic ++ advanced)- (basic, advanced) = commandOptions rootDirectory cmd- subcommands =- case msuper of- Nothing -> case getSubcommands cmd of- [] -> []- s -> "\n\nSubcommands:\n" ++ (usageHelper s)- -- we don't want to list subcommands if we're already specifying them- Just _ -> ""--getCommandHelpCore :: Maybe DarcsCommand -> DarcsCommand -> String-getCommandHelpCore msuper cmd =- "Usage: " ++ commandProgramName cmd ++ " "++superName msuper++commandName cmd++- " [OPTION]... " ++ unwords args_help ++- "\n"++ commandDescription cmd- where args_help = case cmd of- (DarcsCommand {}) ->- commandExtraArgHelp cmd- _ -> []--data CommandArgs = CommandOnly DarcsCommand- | SuperCommandOnly DarcsCommand- | SuperCommandSub DarcsCommand DarcsCommand---- Parses a darcs command line with potentially abbreviated commands-disambiguateCommands :: [CommandControl] -> String -> [String]- -> Either String (CommandArgs, [String])-disambiguateCommands allcs cmd args =- do c <- extract cmd allcs- case (getSubcommands c, args) of- ([], _) -> return (CommandOnly c, args)- (_ ,[]) -> return (SuperCommandOnly c, args)- (subcs, (a:as)) -> case extract a subcs of- Left _ -> return (SuperCommandOnly c, args)- Right sc -> return (SuperCommandSub c sc, as)--extract :: String -> [CommandControl] -> Either String DarcsCommand-extract cmd cs =- case [ c | c <- extractCommands cs, cmd `isPrefixOf` commandName c ] ++- [ h | h <- extractHiddenCommands cs, cmd == commandName h ] of- [] -> Left $ "No such command '" ++ cmd ++ "'\n"- [c] -> Right c- cs' -> Left $ "Ambiguous command...\n\n" ++- "The command '"++cmd++"' could mean one of:\n" ++- unwords (sort $ map commandName cs')--amVerbose :: [DarcsFlag] -> Bool-amVerbose = elem Verbose--amQuiet :: [DarcsFlag] -> Bool-amQuiet = elem Quiet--putVerbose :: [DarcsFlag] -> Doc -> IO ()-putVerbose opts = when (amVerbose opts) . putDocLn--putInfo :: [DarcsFlag] -> Doc -> IO ()-putInfo opts = unless (amQuiet opts) . putDocLn--putWarning :: [DarcsFlag] -> Doc -> IO ()-putWarning opts = unless (amQuiet opts) . hPutDocLn stderr--abortRun :: [DarcsFlag] -> Doc -> IO ()-abortRun opts msg = if DryRun `elem` opts- then putInfo opts $ text "NOTE:" <+> msg- else errorDoc msg
− src/Darcs/Commands/Add.hs
@@ -1,341 +0,0 @@--- Copyright (C) 2002-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- |--- Module : Darcs.Commands.Add--- Copyright : 2002-2004 David Roundy--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module Darcs.Commands.Add- (- add- , expandDirs- ) where---#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 )-import Printer ( text )-import Storage.Hashed.Tree ( Tree, findTree, expand )-import Storage.Hashed.AnchoredPath ( floatPath, anchorPath, parents )-import System.FilePath.Posix ( takeDirectory, (</>) )-import System.Posix.Files ( isRegularFile, isDirectory, isSymbolicLink )-import System.Directory ( getPermissions, readable )--import qualified System.FilePath.Windows as WindowsFilePath--import Darcs.Arguments ( noskipBoring, allowProblematicFilenames,- recursive, workingRepoDir, dryRunNoxml, umaskOption,- listFiles, listUnregisteredFiles,- DarcsFlag ( Recursive, DryRun, Verbose, Quiet ),- fixSubPaths,- )-import Darcs.Commands ( DarcsCommand(..), putVerbose, putWarning, nodefaults)-import Darcs.Flags ( includeBoring, doAllowCaseOnly, doAllowWindowsReserved )-import Darcs.Patch ( Patchy, PrimPatch, applyToTree, addfile, adddir )-import Darcs.Patch.Apply ( ApplyState )-import Darcs.RepoPath ( SubPath, toFilePath, simpleSubPath, toPath )-import Darcs.Repository.State ( readRecordedAndPending )-import Darcs.Repository ( amInHashedRepository, withRepoLock, RepoJob(..), addToPending )-import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter )-import Darcs.Utils ( treeHas, treeHasDir, treeHasAnycase, getFileStatus, withCurrentDirectory, nubsort )-import Darcs.Witnesses.Ordered ( FL(..), (+>+), nullFL )-import Darcs.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )---addDescription :: String-addDescription = "Add one or more new files or directories."---addHelp :: String-addHelp =- "Generally a repository contains both files that should be version\n" ++- "controlled (such as source code) and files that Darcs should ignore\n" ++- "(such as executables compiled from the source code). The `darcs add'\n" ++- "command is used to tell Darcs which files to version control.\n" ++- "\n" ++- "When an existing project is first imported into a Darcs repository, it\n" ++- "is common to run `darcs add -r *' or `darcs record -l' to add all\n" ++- "initial source files into darcs.\n"++- "\n" ++- "Adding symbolic links (symlinks) is not supported.\n\n"---addHelp' :: String-addHelp' =- "Darcs will ignore all files and folders that look `boring'. The\n" ++- "--boring option overrides this behaviour.\n" ++- "\n" ++- "Darcs will not add file if another file in the same folder has the\n" ++- "same name, except for case. The --case-ok option overrides this\n" ++- "behaviour. Windows and OS X usually use filesystems that do not allow\n" ++- "files a folder to have the same name except for case (for example,\n" ++- "`ReadMe' and `README'). If --case-ok is used, the repository might be\n" ++- "unusable on those systems!\n\n"---add :: DarcsCommand-add = DarcsCommand- {- commandProgramName = "darcs"- , commandName = "add"- , commandHelp = addHelp ++ addHelp'- , commandDescription = addDescription- , commandExtraArgs = -1- , commandExtraArgHelp = [ "<FILE or DIRECTORY> ..." ]- , commandCommand = addCmd- , commandPrereq = amInHashedRepository- , commandGetArgPossibilities = listUnregisteredFiles- , commandArgdefaults = nodefaults- , commandAdvancedOptions = [umaskOption]- , commandBasicOptions =- [- noskipBoring- , allowProblematicFilenames- , recursive "add contents of subdirectories"- , workingRepoDir- , dryRunNoxml- ]- }---addCmd :: [DarcsFlag]- -> [String]- -> IO ()-addCmd opts args- | null args = putStrLn $ "Nothing specified, nothing added." ++- "Maybe you wanted to say `darcs add --recursive .'?"- | otherwise = do- fs <- fixSubPaths opts args- case fs of- [] -> fail "No valid arguments were given"- _ -> addFiles opts fs---addFiles :: [DarcsFlag] -- ^ Command options- -> [SubPath]- -> IO ()-addFiles opts origfiles = withRepoLock opts $ RepoJob $ \repository -> do- -- TODO do not expand here, and use findM/findIO or such later- -- (needs adding to hashed-storage first though)- cur <- expand =<< readRecordedAndPending repository- let parlist = getParents cur (map toFilePath origfiles)- flist' <- if Recursive `elem` opts- then expandDirs origfiles- else return origfiles- let flist = nubsort (parlist ++ toFilePath `map` flist')- -- refuse to add boring files recursively:- nboring <- if includeBoring opts- then return darcsdirFilter- else boringFileFilter- let fixedOpts = if DryRun `elem` opts then Verbose:opts else opts- mapM_ (putWarning fixedOpts . text . ((msgSkipping msgs ++ " boring file ")++)) $- flist \\ nboring flist- Sealed ps <- fmap unFreeLeft $ addp msgs fixedOpts cur $ nboring flist- when (nullFL ps && not (null origfiles) && not (Quiet `elem` opts)) $- fail "No files were added"- unless gotDryRun $ addToPending repository ps- where- gotDryRun = DryRun `elem` opts- msgs- | gotDryRun = dryRunMessages- | otherwise = normalMessages---addp :: forall prim . (Patchy prim, PrimPatch prim, ApplyState prim ~ Tree)- => AddMessages- -> [DarcsFlag]- -> Tree IO- -> [FilePath]- -> IO (FreeLeft (FL prim))-addp msgs opts cur0 files = do- (ps, dups) <-- foldr- (\f rest cur accPS accDups -> do- addResult <- addp' cur f- case addResult of- -- If a single file fails to add, stop further processing.- (_, Nothing, Nothing) -> return ([], [])- (cur', mp, mdup) -> rest cur' (maybeToList mp ++ accPS) (maybeToList mdup ++ accDups))- (\_ ps dups -> return (reverse ps, dups))- files- cur0 [] []- let uniq_dups = nub dups- caseMsg =- if gotAllowCaseOnly then ":"- else ";\nnote that to ensure portability we don't allow\n" ++- "files that differ only in case. Use --case-ok to override this:"- unless (null dups) $ do- dupMsg <-- case uniq_dups of- [f] -> do- isDir <- doesDirectoryReallyExist f- if isDir- then return $- "The following directory " ++- msgIs msgs ++ " already in the repository"- else return $- "The following file " ++- msgIs msgs ++ " already in the repository"- fs -> do- areDirs <- mapM doesDirectoryReallyExist fs- if and areDirs- then return $- "The following directories " ++- msgAre msgs ++ " already in the repository"- else- (if or areDirs- then return $- "The following files and directories " ++- msgAre msgs ++ " already in the repository"- else return $- "The following files " ++- msgAre msgs ++ " already in the repository")- putWarning opts . text $ dupMsg ++ caseMsg- mapM_ (putWarning opts . text) uniq_dups- return $ foldr (joinGap (+>+)) (emptyGap NilFL) ps- where- addp' :: Tree IO- -> FilePath- -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)- addp' cur f = do- already_has <- (if gotAllowCaseOnly then treeHas else treeHasAnycase) cur f- mstatus <- getFileStatus f- case (already_has, is_badfilename, mstatus) of- (True, _, _) -> return (cur, Nothing, Just f)- (_, True, _) -> do- putWarning opts . text $- "The filename " ++ f ++ " is invalid under Windows.\n" ++- "Use --reserved-ok to allow it."- return add_failure- (_, _, Just s)- | isDirectory s -> trypatch $ freeGap (adddir f :>: NilFL)- | isRegularFile s -> trypatch $ freeGap (addfile f :>: NilFL)- | isSymbolicLink s -> do- putWarning opts . text $- "Sorry, file " ++ f ++- " is a symbolic link, which is unsupported by darcs."- return add_failure- _ -> do- putWarning opts . text $ "File "++ f ++" does not exist!"- return add_failure- where- is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)- add_failure = (cur, Nothing, Nothing)- trypatch :: FreeLeft (FL prim)- -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)- trypatch p = do- perms <- getPermissions f- if not $ readable perms- then do- putWarning opts . text $- msgSkipping msgs ++ " '" ++ f ++ "': permission denied "- return (cur, Nothing, Nothing)- else trypatch' p- trypatch' p = do- Sealed p' <- return $ unFreeLeft p- ok <- treeHasDir cur parentdir- if ok- then do- tree <- applyToTree p' cur- putVerbose opts . text $- msgAdding msgs ++ " '" ++ f ++ "'"- return (tree, Just p, Nothing)- else do- putWarning opts . text $- msgSkipping msgs ++ " '" ++ f ++- "' ... couldn't add parent directory '" ++- parentdir ++ "' to repository"- return (cur, Nothing, Nothing)- `catch` \(e :: IOException) -> do- putWarning opts . text $- msgSkipping msgs ++ " '" ++ f ++ "' ... " ++ show e- return (cur, Nothing, Nothing)- parentdir = takeDirectory f- gotAllowCaseOnly = doAllowCaseOnly opts- gotAllowWindowsReserved = doAllowWindowsReserved opts---data AddMessages = AddMessages- {- msgSkipping :: String- , msgAdding :: String- , msgIs :: String- , msgAre :: String- }---normalMessages :: AddMessages-normalMessages = AddMessages- {- msgSkipping = "Skipping"- , msgAdding = "Adding"- , msgIs = "is"- , msgAre = "are"- }---dryRunMessages :: AddMessages-dryRunMessages = AddMessages- {- msgSkipping = "Would skip"- , msgAdding = "Would add"- , msgIs = "would be"- , msgAre = "would be"- }---doesDirectoryReallyExist :: FilePath -> IO Bool-doesDirectoryReallyExist f = maybe False isDirectory `fmap` getFileStatus f---expandDirs :: [SubPath]- -> IO [SubPath]-expandDirs fs =- liftM (map (fromJust . simpleSubPath)) $- concat `fmap` mapM (expandOne . toPath) fs---expandOne :: FilePath- -> IO [FilePath]-expandOne "" = listFiles-expandOne f = do- isdir <- doesDirectoryReallyExist f- if not isdir- then return [f]- else do- fs <- withCurrentDirectory f listFiles- return $ f: map (f </>) fs---getParents :: Tree IO- -> [FilePath]- -> [FilePath]-getParents cur = map (anchorPath "") . go . map floatPath- where- go fs = filter (isNothing . findTree cur) $ concatMap parents fs-
− src/Darcs/Commands/AmendRecord.hs
@@ -1,332 +0,0 @@--- Copyright (C) 2004,2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- |--- Module : Darcs.Commands.AmendRecord--- Copyright : 2004, 2007 David Roundy--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module Darcs.Commands.AmendRecord- (- amendrecord- , amendunrecord- ) where---#include "gadts.h"--import Data.Maybe ( isJust, isNothing )-import Data.List ( intersect )-import Control.Applicative ( (<$>) )-import Control.Monad ( when, unless )-import System.Directory ( removeFile )-import System.Exit ( ExitCode(..), exitWith )--import Darcs.Arguments ( DarcsFlag ( All, AmendUnrecord, Unified ),- fixSubPaths, setEnvDarcsFiles,- allInteractive, ignoretimes,- askLongComment, askdeps, keepDate, author, patchnameOption,- leaveTestDir, nocompress, lookforadds,- workingRepoDir,- matchOneNontag, umaskOption,- test, listRegisteredFiles,- getEasyAuthor, setScriptsExecutableOption, amendUnrecord- , unified- )-import Darcs.Commands ( DarcsCommand(..), commandAlias, nodefaults )-import Darcs.Commands.Record ( getDate, getLog, askAboutDepends )-import Darcs.Commands.Util ( announceFiles )-import Darcs.Flags ( DarcsFlag(Author, LogFile, PatchName, AskDeps,- EditLongComment, PromptLongComment, KeepDate)- , isInteractive- , diffingOpts, compression, removeFromAmended )-import Darcs.Lock ( worldReadableTemp )-import Darcs.Patch ( RepoPatch, description, PrimOf, fromPrims,- infopatch, getdeps, adddeps, effect, invertFL- )-import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Info ( piAuthor, piName, piLog, piDateString,- PatchInfo, patchinfo, isInverted, isTag, invertName,- )-import Darcs.Patch.Prim ( canonizeFL )-import Darcs.Patch.Split ( primSplitter )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully, info, patchDesc )-import Darcs.RepoPath ( toFilePath, SubPath() )-import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), withGutsOf,- tentativelyRemovePatches, tentativelyAddPatch, finalizeRepositoryChanges,- amInHashedRepository- , invalidateIndex, unrecordedChanges- , testTentative- , readRecorded- )-import Darcs.Repository.Prefs ( globalPrefsDirDoc )-import Darcs.SelectChanges ( selectChanges, WhichChanges(..),- selectionContextPrim,- runSelection,- withSelectedPatchFromRepo )-import Darcs.Utils ( askUser, clarifyErrors, PromptConfig(..), promptChar )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+), nullFL, reverseRL )--import Printer ( putDocLn )-import Storage.Hashed.Tree( Tree )---amendrecordDescription :: String-amendrecordDescription = "Improve a patch before it leaves your repository."---amendrecordHelp :: String-amendrecordHelp =- "Amend-record updates a `draft' patch with additions or improvements,\n" ++- "resulting in a single `finished' patch. This is better than recording\n" ++- "the additions and improvements as separate patches, because then\n" ++- "whenever the `draft' patch is copied between repositories, you would\n" ++- "need to make sure all the extra patches are copied, too.\n" ++- "\n" ++- "Do not copy draft patches between repositories, because a finished\n" ++- "patch cannot be copied into a repository that contains a draft of the\n" ++- "same patch. If this has already happened, `darcs obliterate' can be\n" ++- "used to remove the draft patch.\n" ++- "\n" ++- -- FIXME: is the following still true in Darcs 2.1? --twb- "Do not run amend-record in repository that other developers can pull\n" ++- "from, because if they pull while an amend-record is in progress, their\n" ++- "repository may be corrupted.\n" ++- "\n" ++- "When recording a draft patch, it is a good idea to start the name with\n" ++- "`DRAFT:' so that other developers know it is not finished. When\n" ++- "finished, remove it with `darcs amend-record --edit-long-comment'.\n" ++- "To change the patch name without starting an editor, use --patch-name.\n" ++- "\n" ++- "Like `darcs record', if you call amend-record with files as arguments,\n" ++- "you will only be asked about changes to those files. So to amend a\n" ++- "patch to foo.c with improvements in bar.c, you would run:\n" ++- "\n" ++- " darcs amend-record --match 'touch foo.c' bar.c\n" ++- "\n" ++- "It is usually a bad idea to amend another developer's patch. To make\n" ++- "amend-record only ask about your own patches by default, you can add\n" ++- "something like `amend-record match David Roundy' to " ++ globalPrefsDirDoc ++- "defaults, \n" ++- "where `David Roundy' is your name.\n"---amendrecord :: DarcsCommand-amendrecord = DarcsCommand- {- commandProgramName = "darcs"- , commandName = "amend-record"- , commandHelp = amendrecordHelp- , commandDescription = amendrecordDescription- , commandExtraArgs = -1- , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]- , commandCommand = amendrecordCmd- , commandPrereq = amInHashedRepository- , commandGetArgPossibilities = listRegisteredFiles- , commandArgdefaults = nodefaults- , commandAdvancedOptions =- [- nocompress- , ignoretimes- , umaskOption- , setScriptsExecutableOption- ]- , commandBasicOptions =- [- matchOneNontag- , test- , leaveTestDir- , allInteractive- , author- , patchnameOption- , askdeps- , askLongComment- , keepDate- , lookforadds- , workingRepoDir- , amendUnrecord- , unified- ]- }---amendunrecord :: DarcsCommand-amendunrecord = (commandAlias "amend-unrecord" Nothing amendrecord)- { commandCommand = \fs -> commandCommand amendrecord (AmendUnrecord : fs)- , commandDescription = "Alias for `darcs " ++ commandName amendrecord ++- " --unrecord '.\n" ++- "This allows changes already recorded in the patch to be removed."- }---amendrecordCmd :: [DarcsFlag]- -> [String]- -> IO ()-amendrecordCmd opts [] = doAmendRecord opts Nothing-amendrecordCmd opts args = do- files <- fixSubPaths opts args- if null files- then fail "No valid arguments were given, nothing to do."- else doAmendRecord opts $ Just files---doAmendRecord :: [DarcsFlag] -> Maybe [SubPath] -> IO ()-doAmendRecord opts files =- withRepoLock opts $ RepoJob $ \(repository :: Repository p C(r u r)) -> do- withSelectedPatchFromRepo "amend" repository opts $ \ (_ :> oldp) -> do- announceFiles files "Amending changes in"- -- auxiliary function needed because the witness types differ for the isTag case- pristine <- readRecorded repository- let go :: FORALL(u1) FL (PrimOf p) C(r u1) -> IO ()- go NilFL | not (hasEditMetadata opts) = putStrLn "No changes!"- go ch =- do let context = selectionContextPrim "add"- (intersect [All,Unified] opts)- (Just primSplitter)- (map toFilePath <$> files)- (Just pristine)- (chosenPatches :> _) <- runSelection (selectChanges First ch) context- addChangesToPatch opts repository oldp chosenPatches- if not (isTag (info oldp))- -- amending a normal patch- then if removeFromAmended opts- then do let sel = selectChanges Last (effect oldp)- context = selectionContextPrim "unrecord"- (intersect [All,Unified] opts)- (Just primSplitter)- (map toFilePath <$> files)- (Just pristine)- (_ :> chosenPrims) <- runSelection sel context- let invPrims = reverseRL (invertFL chosenPrims)- addChangesToPatch opts repository oldp invPrims- else go =<< unrecordedChanges (diffingOpts opts) repository files- -- amending a tag- else if hasEditMetadata opts && isNothing files- -- the user is not trying to add new changes to the tag so there is- -- no reason to warn.- then go NilFL- -- the user is trying to add new changes to a tag.- else do if hasEditMetadata opts- -- the user already knows that it is possible to edit tag metadata,- -- note that s/he is providing editing options!- then putStrLn "You cannot add new changes to a tag."- -- the user may not be aware that s/he can edit tag metadata.- else putStrLn "You cannot add new changes to a tag, but you are allowed to edit tag's metadata (see darcs help amend-record)."- go NilFL---addChangesToPatch :: forall p C(r u t x y) . (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag]- -> Repository p C(r u t)- -> PatchInfoAnd p C(x t)- -> FL (PrimOf p) C(t y)- -> IO ()-addChangesToPatch opts repository oldp chs =- if (nullFL chs && not (hasEditMetadata opts))- then putStrLn "You don't want to record anything!"- else do- invalidateIndex repository- withGutsOf repository $ do- repository' <- tentativelyRemovePatches repository (compression opts)- (oldp :>: NilFL)- (mlogf, newp) <- updatePatchHeader opts repository' oldp chs- setEnvDarcsFiles newp- repository'' <- tentativelyAddPatch repository' (compression opts) newp- let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf- rc <- testTentative repository- when (rc /= ExitSuccess) $ do- when (not $ isInteractive opts) $ exitWith rc `clarifyErrors` failmsg- putStrLn $ "Looks like you have a bad patch: '" ++ patchDesc newp ++ "'"- let prompt = "Shall I amend it anyway?"- yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])- case yn of- 'y' -> return ()- _ -> exitWith rc `clarifyErrors` failmsg- finalizeRepositoryChanges repository'' `clarifyErrors` failmsg- maybe (return ()) removeFile mlogf- putStrLn "Finished amending patch:"- putDocLn $ description newp---updatePatchHeader :: forall p C(x y r u t) . (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag]- -> Repository p C(r u t)- -> PatchInfoAnd p C(t x)- -> FL (PrimOf p) C(x y)- -> IO (Maybe String, PatchInfoAnd p C(t y))-updatePatchHeader opts repository oldp chs = do-- let newchs = canonizeFL (effect oldp +>+ chs)-- let old_pdeps = getdeps $ hopefully oldp- newdeps <- if AskDeps `elem` opts- then askAboutDepends repository newchs opts old_pdeps- else return old_pdeps-- let old_pinf = info oldp- prior = (piName old_pinf, piLog old_pinf)- make_log = worldReadableTemp "darcs-amend-record"- old_author = piAuthor old_pinf- date <- if KeepDate `elem` opts then return (piDateString old_pinf) else getDate opts- warnIfHijacking opts old_author- (new_name, new_log, mlogf) <- getLog opts (Just prior) make_log chs- let new_author = case getAuthor opts of- Just a -> a- Nothing -> piAuthor old_pinf- maybe_invert = if isInverted old_pinf then invertName else id- new_pinf <- maybe_invert `fmap` patchinfo date new_name- new_author new_log-- let newp = n2pia (adddeps (infopatch new_pinf (fromPrims newchs)) newdeps)-- return (mlogf, newp)---warnIfHijacking :: [DarcsFlag]- -> String- -> IO ()-warnIfHijacking opts old_author = do- authors_here <- getEasyAuthor- let edit_author = isJust (getAuthor opts)- unless (edit_author || any (== old_author) authors_here) $ do- yorn <- askUser $- "You're not " ++ old_author ++"! Amend anyway? "- case yorn of ('y':_) -> return ()- _ -> exitWith ExitSuccess---hasEditMetadata :: [DarcsFlag]- -> Bool-hasEditMetadata [] = False-hasEditMetadata (Author _:_) = True-hasEditMetadata (LogFile _:_) = True-hasEditMetadata (PatchName _:_) = True-hasEditMetadata (EditLongComment:_) = True-hasEditMetadata (PromptLongComment:_) = True-hasEditMetadata (AskDeps:_) = True-hasEditMetadata (_:fs) = hasEditMetadata fs---getAuthor :: [DarcsFlag]- -> Maybe String-getAuthor (Author a:_) = Just a-getAuthor (_:as) = getAuthor as-getAuthor [] = Nothing-
− src/Darcs/Commands/Annotate.hs
@@ -1,151 +0,0 @@--- Copyright (C) 2003 David Roundy, 2010-2011 Petr Rockai------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.-{-# LANGUAGE CPP, OverloadedStrings #-}-{-# OPTIONS_GHC -cpp #-}--module Darcs.Commands.Annotate ( annotate ) where--import Control.Monad ( when )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag(..), workingRepoDir,- summary, unified, machineReadable,- creatorhash,- fixSubPaths,- listRegisteredFiles,- matchOne,- )-import Darcs.Flags ( isUnified )-import Storage.Hashed.Plain( readPlainTree )-import Darcs.Repository.State ( readRecorded )-import Darcs.Repository ( Repository, amInHashedRepository, withRepository, RepoJob(..), readRepo )-import Darcs.Patch.Set ( newset2RL )-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 )-import Data.ByteString.Lazy ( toChunks )-import Darcs.PrintPatch ( printPatch, contextualPrintPatch )-import Darcs.Patch.ApplyMonad( withFileNames )-import Darcs.Patch.FileName( fp2fn )-import System.FilePath( (</>) )-import Darcs.RepoPath( toFilePath )-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 )-import qualified Darcs.Annotate as A-import Printer ( putDocLn, Doc )--import Storage.Hashed.Tree( Tree, TreeItem(..), readBlob, list, expand )-import Storage.Hashed.Monad( findM, virtualTreeIO )-import Storage.Hashed.AnchoredPath( floatPath, anchorPath )-#include "gadts.h"-#include "impossible.h"--annotateDescription :: String-annotateDescription = "Display which patch last modified something."--annotateHelp :: String-annotateHelp =- "The `darcs annotate' command provides two unrelated operations. When\n" ++- "called on a file, it will find the patch that last modified each line\n" ++- "in that file. When called on a patch (e.g. using --patch), it will\n" ++- "print the internal representation of that patch.\n" ++- "\n" ++- "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 --machine-readable\n" ++- "option can be used to generate output for machine postprocessing.\n"--annotate :: DarcsCommand-annotate = DarcsCommand {commandProgramName = "darcs",- commandName = "annotate",- commandHelp = annotateHelp,- commandDescription = annotateDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["[FILE or DIRECTORY]..."],- commandCommand = annotateCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = listRegisteredFiles,- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [summary,unified,- machineReadable,- matchOne, creatorhash,- workingRepoDir]}--annotateCmd :: [DarcsFlag] -> [String] -> IO ()-annotateCmd opts files = withRepository opts (RepoJob (annotate' opts files))--annotate' :: (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> [String] -> Repository p C(r u r) -> IO ()--annotate' opts [] repository = do- when (not $ haveNonrangeMatch opts) $- fail $ "Annotate requires either a patch pattern or a " ++- "file or directory argument."- Sealed2 p <- matchPatch opts `fmap` readRepo repository- if Summary `elem` opts- then do putDocLn $ showpi $ patch2patchinfo p- putDocLn $ show_summary p- else if isUnified opts- then withTempDir "context" $ \_ ->- do getFirstMatch repository opts- c <- readPlainTree "."- contextualPrintPatch c p- else printPatch p- where showpi | MachineReadable `elem` opts = showPatchInfo- | otherwise = humanFriendly- show_summary :: RepoPatch p => Named p C(x y) -> Doc- show_summary = Darcs.Patch.summary--annotate' opts [""] repository = annotate' opts [] repository-annotate' opts args@[_] repository = do- r <- readRepo repository- (origpath:_) <- fixSubPaths opts args- recorded <- readRecorded repository-- (Sealed patches, initial, path) <-- if haveNonrangeMatch opts- then do Sealed x <- getOnePatchset repository opts- let fn = [fp2fn $ toFilePath origpath]- nonRangeMatch = getNonrangeMatchS opts r- (_, [path], _) = withFileNames Nothing fn nonRangeMatch- initial <- snd `fmap` virtualTreeIO (getNonrangeMatchS opts r) recorded- return $ (seal $ newset2RL x, initial, toFilePath path)- else return $ (seal $ newset2RL r, recorded, toFilePath origpath)-- found <- findM initial (floatPath $ toFilePath path)- -- TODO need to decide about the --machine flag- let fmt = if MachineReadable `elem` opts then A.machineFormat else A.format- case found of- Nothing -> fail $ "No such file or directory: " ++ toFilePath path- Just (SubTree s) -> do- s' <- expand s- let subs = map (fp2fn . (path </>) . anchorPath "" . fst) $ list s'- showPath (n, File _) = BC.pack (path </> n)- showPath (n, _) = BC.concat [BC.pack (path </> n), "/"]- putStrLn $ fmt (BC.intercalate "\n" $ map showPath $- map (\(x,y) -> (anchorPath "" x, y)) $ list s') $- A.annotateDirectory (invertRL patches) (fp2fn $ "./" ++ path) subs- Just (File b) -> do con <- BC.concat `fmap` toChunks `fmap` readBlob b- putStrLn $ fmt con $ A.annotate (invertRL patches) (fp2fn $ "./" ++ path) con- Just (Stub _ _) -> impossible--annotate' _ _ _ = fail "annotate accepts at most one argument"
− src/Darcs/Commands/Apply.hs
@@ -1,395 +0,0 @@--- Copyright (C) 2003-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, PatternGuards #-}--module Darcs.Commands.Apply ( apply, getPatchBundle ) where-import System.Exit ( ExitCode(..), exitWith )-import Prelude hiding ( catch )-import System.IO ( hClose, stdout, stderr )-import Control.Exception.Extensible- ( catch, fromException, SomeException, throwIO )-import Control.Monad ( when )--import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefullyM, info )-import Darcs.SignalHandler ( withSignalsBlocked )-import Darcs.Commands ( DarcsCommand(..), putVerbose )-import Darcs.CommandsAux ( checkPaths )-import Darcs.Arguments- ( DarcsFlag( All, Interactive, Reply )- , allInteractive- , applyConflictOptions- , changesReverse- , dryRun- , fixFilePathOrStd- , getCc- , getSendmailCmd- , happyForwarding- , ignoretimes- , leaveTestDir- , listFiles- , makeScriptsExecutable- , matchSeveral- , nocompress- , notest- , pauseForGui- , printDryRunMessageAndExit- , reply- , restrictPaths- , sendmailCmd- , setEnvDarcsPatches- , setScriptsExecutableOption- , umaskOption- , useExternalMerge- , verify- , workingRepoDir- )-import Darcs.Flags(doHappyForwarding, doReverse, isInteractive)--import qualified Darcs.Arguments as DarcsArguments ( ccApply )-import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd )-import Darcs.Repository ( Repository, SealedPatchSet, withRepoLock, RepoJob(..), amInHashedRepository,- tentativelyMergePatches,- readRepo,- finalizeRepositoryChanges,- testTentative,- applyToWorking, invalidateIndex- )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Patch.Set ( newset2RL )-import Darcs.Patch ( RepoPatch, description, PrimOf )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Info ( PatchInfo, humanFriendly )-import Darcs.Utils ( PromptConfig(..), promptChar )-import Darcs.Witnesses.Ordered ( FL, RL(..), (:\/:)(..), (:>)(..),- mapFL, mapRL, nullFL, reverseFL )-import ByteStringUtils ( linesPS, unlinesPS, gzReadFilePS, gzReadStdin )-import Data.List( (\\) )-import qualified Data.ByteString as B (ByteString, null, init, take, drop)-import qualified Data.ByteString.Char8 as BC (unpack, last, pack)--import Darcs.External ( sendEmail, sendEmailDoc, resendEmail,- verifyPS )-import Darcs.Email ( readEmail )-import Darcs.Lock ( withStdoutTemp, readBinFile )-import Darcs.Patch.Depends ( findUncommon, findCommonWithThem )-import Darcs.SelectChanges ( selectChanges, WhichChanges(..),- runSelection, selectionContext,- filterOutConflicts )-import Darcs.Patch.Bundle ( scanBundle )-import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-import Printer ( packedString, vcat, text, empty, renderString )-import Storage.Hashed.Tree( Tree )--#include "impossible.h"--#include "gadts.h"--applyDescription :: String-applyDescription = "Apply a patch bundle created by `darcs send'."--applyHelp :: String-applyHelp =- "The `darcs apply' command takes a patch bundle and attempts to insert\n" ++- "it into the current repository. In addition to invoking it directly\n" ++- "on bundles created by `darcs send', it is used internally by `darcs\n" ++- "push' and `darcs put' on the remote end of an SSH connection.\n" ++- "\n" ++- "If no file is supplied, the bundle is read from standard input.\n" ++- "\n" ++- "If given an email instead of a patch bundle, Darcs will look for the\n" ++- "bundle as a MIME attachment to that email. Currently this will fail\n" ++- "if the MIME boundary is rewritten, such as in Courier and Mail.app.\n" ++- "\n" ++- "If the `--reply noreply@example.net' option is used, and the bundle is\n" ++- "attached to an email, Darcs will send a report (indicating success or\n" ++- "failure) to the sender of the bundle (the To field). The argument to\n" ++- "noreply is the address the report will appear to originate FROM.\n" ++- "\n" ++- "The --cc option will cause the report to be CC'd to another address,\n" ++- "for example `--cc reports@lists.example.net,admin@lists.example.net'.\n" ++- "Using --cc without --reply is undefined.\n" ++- "\n" ++- "If gpg(1) is installed, you can use `--verify pubring.gpg' to reject\n" ++- "bundles that aren't signed by a key in pubring.gpg.\n" ++- "\n" ++- "If --test is supplied and a test is defined (see `darcs setpref'), the\n" ++- "bundle will be rejected if the test fails after applying it. In that\n" ++- "case, the rejection email from --reply will include the test output.\n"--stdindefault :: a -> [String] -> IO [String]-stdindefault _ [] = return ["-"]-stdindefault _ x = return x-apply :: DarcsCommand-apply = DarcsCommand {commandProgramName = "darcs",- commandName = "apply",- commandHelp = applyHelp ++ "\n" ++ applyHelp',- commandDescription = applyDescription,- commandExtraArgs = 1,- commandExtraArgHelp = ["<PATCHFILE>"],- commandCommand = applyCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = listFiles,- commandArgdefaults = const stdindefault,- commandAdvancedOptions =- [ reply- , DarcsArguments.ccApply- , happyForwarding- , sendmailCmd- , ignoretimes- , nocompress- , setScriptsExecutableOption- , umaskOption- , restrictPaths- , changesReverse- , pauseForGui- ],- commandBasicOptions = [verify,- allInteractive]++dryRun++- [matchSeveral,- applyConflictOptions,- useExternalMerge,- notest,- leaveTestDir,- workingRepoDir]}--applyCmd :: [DarcsFlag] -> [String] -> IO ()-applyCmd _ [""] = fail "Empty filename argument given to apply!"-applyCmd opts [unfixed_patchesfile] = withRepoLock opts $ RepoJob $ \repository -> do- when (unfixed_patchesfile == "-") $ do - -- for darcs users who try out 'darcs apply' without any arguments- putVerbose opts $ text "reading patch bundle from stdin..."- patchesfile <- fixFilePathOrStd opts unfixed_patchesfile- ps <- useAbsoluteOrStd (gzReadFilePS . toFilePath) gzReadStdin patchesfile- let from_whom = getFrom ps- us <- readRepo repository- either_them <- getPatchBundle opts ps- Sealed them- <- case either_them of- Right t -> return t- Left er -> do forwarded <- considerForwarding opts ps- if forwarded- then exitWith ExitSuccess- else fail er- common :> _ <- return $ findCommonWithThem us them-- -- all patches that are in "them" and not in "common" need to be available; check that- let common_i = mapRL info $ newset2RL common- them_i = mapRL info $ newset2RL them- required = them_i \\ common_i -- FIXME quadratic?- check :: RL (PatchInfoAnd p) C(x y) -> [PatchInfo] -> IO ()- check (p :<: ps') bad = case hopefullyM p of- Nothing | info p `elem` required -> check ps' (info p : bad)- _ -> check ps' bad- check NilRL [] = return ()- check NilRL bad = fail . renderString $ vcat $ map humanFriendly bad ++- [ text "\nFATAL: Cannot apply this bundle. We are missing the above patches." ]-- check (newset2RL them) []-- (us':\/:them') <- return $ findUncommon us them- (hadConflicts, Sealed their_ps) <- filterOutConflicts opts (reverseFL us') repository them'- when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."- when (nullFL their_ps) $- do putStr $ "All these patches have already been applied. " ++- "Nothing to do.\n"- exitWith ExitSuccess- let context = selectionContext "apply" fixed_opts Nothing Nothing- selector = selectChanges $ if doReverse opts- then FirstReversed- else First- (to_be_applied :> _) <- runSelection (selector their_ps) context- applyItNow opts from_whom repository us' to_be_applied- where fixed_opts = if Interactive `elem` opts- then opts- else All : opts-applyCmd _ _ = impossible--applyItNow :: FORALL(p r u t x z) (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)- => [DarcsFlag] -> String -> Repository p C(r u t)- -> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x z) -> IO ()-applyItNow opts from_whom repository us' to_be_applied = do- printDryRunMessageAndExit "apply" opts to_be_applied- when (nullFL to_be_applied) $- do putStrLn "You don't want to apply any patches, so I'm exiting!"- exitWith ExitSuccess- checkPaths opts to_be_applied- redirectOutput opts from_whom $ do- putVerbose opts $ text "Will apply the following patches:"- putVerbose opts . vcat $ mapFL description to_be_applied- setEnvDarcsPatches to_be_applied- Sealed pw <- tentativelyMergePatches repository "apply" opts us' to_be_applied- invalidateIndex repository- rc <- testTentative repository- when (rc /= ExitSuccess) $ do- when (not $ isInteractive opts) $ exitWith rc- putStrLn $ "Looks like those patches do not pass the tests."- let prompt = "Shall I apply them anyway?"- yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])- case yn of- 'y' -> return ()- _ -> exitWith rc- withSignalsBlocked $ do finalizeRepositoryChanges repository- _ <- applyToWorking repository opts pw `catch` \(e :: SomeException) ->- fail ("Error applying patch to working dir:\n" ++ show e)- makeScriptsExecutable opts pw- return ()- putStrLn "Finished applying..."--getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString- -> IO (Either String (SealedPatchSet p C(Origin)))-getPatchBundle opts fps = do- mps <- verifyPS opts $ readEmail fps- mops <- verifyPS opts fps- case (mps, mops) of- (Nothing, Nothing) ->- return $ Left "Patch bundle not properly signed, or gpg failed."- (Just ps, Nothing) -> return $ scanBundle ps- (Nothing, Just ps) -> return $ scanBundle ps- -- We use careful_scan_bundle only below because in either of the two- -- above case we know the patch was signed, so it really shouldn't- -- need stripping of CRs.- (Just ps1, Just ps2) -> case careful_scan_bundle ps1 of- Left _ -> return $ careful_scan_bundle ps2- Right x -> return $ Right x- where careful_scan_bundle ps =- case scanBundle ps of- Left e -> case scanBundle $ stripCrPS ps of- Right x -> Right x- _ -> Left e- x -> x- stripCrPS :: B.ByteString -> B.ByteString- stripCrPS ps = unlinesPS $ map stripline $ linesPS ps- stripline p | B.null p = p- | BC.last p == '\r' = B.init p- | otherwise = p--applyHelp' :: String-applyHelp' =- "A patch bundle may introduce unresolved conflicts with existing\n" ++- "patches or with the working tree. By default, Darcs will add conflict\n" ++- "markers (see `darcs mark-conflicts').\n" ++- "\n" ++- "The --external-merge option lets you resolve these conflicts\n" ++- "using an external merge tool. In the option, '%a' is replaced with\n" ++- "the common ancestor (merge base), '%1' with the first version, '%2'\n" ++- "with the second version, and '%o' with the path where your resolved\n" ++- "content should go. For example, to use the xxdiff visual merge tool\n" ++- "you'd specify: --external-merge='xxdiff -m -O -M %o %1 %a %2'\n" ++- "\n" ++- "The --allow-conflicts option will skip conflict marking; this is\n" ++- "useful when you want to treat a repository as just a bunch of patches,\n" ++- "such as using `darcs pull --union' to download of your co-workers\n" ++- "patches before going offline.\n" ++- "\n" ++- "This can mess up unrecorded changes in the working tree, forcing you\n" ++- "to resolve the conflict immediately. To simply reject bundles that\n" ++- "introduce unresolved conflicts, using the --dont-allow-conflicts\n" ++- "option. Making this the default in push-based workflows is strongly\n" ++- "recommended.\n" ++- "\n" ++- "Unlike most Darcs commands, `darcs apply' defaults to --all. Use the\n" ++- "--interactive option to pick which patches to apply from a bundle.\n"--getFrom :: B.ByteString -> String-getFrom ps = readFrom $ linesPS ps- where readFrom [] = ""- readFrom (x:xs)- | B.take 5 x == fromStart = BC.unpack $ B.drop 5 x- | otherwise = readFrom xs--redirectOutput :: forall a . [DarcsFlag] -> String -> IO a -> IO a-redirectOutput opts to doit = ro opts- where- cc = getCc opts- ro [] = doit- ro (Reply f:_) =- withStdoutTemp $ \tempf-> do {a <- doit;- hClose stdout;- hClose stderr;- return a;- } `catch` (sendit tempf)- where sendit :: FilePath -> SomeException -> IO a- sendit tempf e | Just ExitSuccess <- fromException e =- do sendSanitizedEmail opts f to "Patch applied" cc tempf- throwIO e- sendit tempf e | Just (_ :: ExitCode) <- fromException e =- do sendSanitizedEmail opts f to "Patch failed!" cc tempf- throwIO ExitSuccess- sendit tempf e =- do sendSanitizedEmail opts f to "Darcs error applying patch!" cc $- tempf ++ "\n\nCaught exception:\n"++- show e++"\n"- throwIO ExitSuccess- ro (_:fs) = ro fs---- |sendSanitizedEmail sends a sanitized email using the given sendmailcmd--- It takes @DacrsFlag@ options a file with the mail contents,--- To:, Subject:, CC:, and mail body-sendSanitizedEmail :: [DarcsFlag] -> String -> String -> String -> String -> String -> IO ()-sendSanitizedEmail opts file to subject cc mailtext =- do scmd <- getSendmailCmd opts- body <- sanitizeFile mailtext- sendEmail file to subject cc scmd body---- sanitizeFile is used to clean up the stdout/stderr before sticking it in--- an email.--sanitizeFile :: FilePath -> IO String-sanitizeFile f = sanitize `fmap` readBinFile f- where sanitize s = wash $ remove_backspaces "" s- wash ('\000':s) = "\\NUL" ++ wash s- wash ('\026':s) = "\\EOF" ++ wash s- wash (c:cs) = c : wash cs- wash [] = []- remove_backspaces rev_sofar "" = reverse rev_sofar- remove_backspaces (_:rs) ('\008':s) = remove_backspaces rs s- remove_backspaces "" ('\008':s) = remove_backspaces "" s- remove_backspaces rs (s:ss) = remove_backspaces (s:rs) ss--forwardingMessage :: B.ByteString-forwardingMessage = BC.pack $- "The following patch was either unsigned, or signed by a non-allowed\n"++- "key, or there was a GPG failure.\n"--considerForwarding :: [DarcsFlag] -> B.ByteString -> IO Bool-considerForwarding opts m = cf opts (getCc opts)- where cf [] _ = return False- cf (Reply t:_) cc =- case break is_from (linesPS m) of- (m1, f:m2) ->- let m_lines = forwardingMessage:m1 ++ m2- m' = unlinesPS m_lines- f' = BC.unpack (B.drop 5 f) in- if t == f' || t == init f'- then return False -- Refuse possible email loop.- else do- scmd <- getSendmailCmd opts- if doHappyForwarding opts- then resendEmail t scmd m- else sendEmailDoc f' t "A forwarded darcs patch" cc- scmd (Just (empty,empty))- (packedString m')- return True- _ -> return False -- Don't forward emails lacking headers!- cf (_:fs) cc = cf fs cc- is_from l = B.take 5 l == fromStart--fromStart :: B.ByteString-fromStart = BC.pack "From:"
− src/Darcs/Commands/Changes.hs
@@ -1,362 +0,0 @@--- Copyright (C) 2003-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, PatternGuards #-}--#include "gadts.h"--module Darcs.Commands.Changes ( changes, log ) where-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 ((<$>))--import Darcs.Patch.PatchInfoAnd ( hopefullyM, info )-import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )-import Darcs.Arguments ( DarcsFlag(GenContext, HumanReadable, MachineReadable,- Interactive, Count,- NumberPatches, XMLOutput, Summary,- Verbose, Debug),- fixSubPaths, changesFormat,- possiblyRemoteRepoDir, getRepourl,- workingRepoDir, onlyToFiles,- summary, changesReverse,- matchSeveralOrRange,- matchMaxcount, maxCount,- allInteractive, showFriendly,- networkOptions- )-import Darcs.Flags ( doReverse, showChangesOnlyToFiles, UseIndex(..), ScanKnown(..) )-import Darcs.RepoPath ( SubPath(), toFilePath )-import Darcs.Patch.FileName ( fp2fn, fn2fp, normPath )-import Darcs.Repository ( PatchSet, PatchInfoAnd,- withRepositoryDirectory, RepoJob(..), findRepository,- readRepo, unrecordedChanges )-import Darcs.Patch.Set ( PatchSet(..), newset2RL )-import Darcs.Patch.Info ( toXml, showPatchInfo, escapeXML, PatchInfo )-import Darcs.Patch.Depends ( findCommonWithThem )-import Darcs.Patch.Bundle( contextPatches )-import Darcs.Patch.TouchesFiles ( lookTouch )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch ( RepoPatch, invert, xmlSummary, description,- effectOnFilePaths, listTouchedFiles, effect )-import Darcs.Witnesses.Eq ( EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(NilFL), RL(..), filterFLFL, filterRL,- reverseFL, (:>)(..), mapRL )-import Darcs.Match ( firstMatch, secondMatch,- matchAPatchread, haveNonrangeMatch,- matchFirstPatchset, matchSecondPatchset,- )-import Printer ( Doc, putDocLnWith, simplePrinters, (<+>), prefix, text, vcat,- vsep, (<>), ($$), errorDoc, insertBeforeLastline )-import Darcs.ColorPrinter ( fancyPrinters )-import Progress ( setProgressMode, debugMessage )-import Darcs.SelectChanges ( viewChanges )-import Darcs.Witnesses.Sealed ( Sealed2(..), unseal2, Sealed(..), seal2 )-import Storage.Hashed.Tree( Tree )--changesDescription :: String-changesDescription = "List patches in the repository."--changesHelp :: String-changesHelp =- "The `darcs changes' command lists the patches that constitute the\n" ++- "current repository or, with --repo, a remote repository. Without\n" ++- "options or arguments, ALL patches will be listed.\n" ++- "\n" ++ changesHelp' ++- "\n" ++ changesHelp''--changes :: DarcsCommand-changes = DarcsCommand {commandProgramName = "darcs",- commandName = "changes",- commandHelp = changesHelp,- commandDescription = changesDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["[FILE or DIRECTORY]..."],- commandGetArgPossibilities = return [],- commandCommand = changesCmd,- commandPrereq = findRepository,- commandArgdefaults = nodefaults,- commandAdvancedOptions = networkOptions,- commandBasicOptions = [matchSeveralOrRange,- matchMaxcount,- onlyToFiles,- changesFormat,- summary,- changesReverse,- possiblyRemoteRepoDir,- workingRepoDir,- allInteractive]}--changesCmd :: [DarcsFlag] -> [String] -> IO ()-changesCmd opts args- | GenContext `elem` opts = if not . null $ args- then fail "changes --context cannot accept other arguments"- else changesContext opts- | null args = showChanges opts Nothing- | otherwise = do- fs <- fixSubPaths opts args- case fs of- [] -> putStrLn "No valid arguments were given, nothing to do."- _ -> showChanges opts . Just . nub $ sort fs--showChanges :: [DarcsFlag] -> Maybe [SubPath] -> IO ()-showChanges opts files =- let repodir = fromMaybe "." (getRepourl opts) in- withRepositoryDirectory opts repodir $ RepoJob $ \repository -> do- unless (Debug `elem` opts) $ setProgressMode False- Sealed unrec <- case files of- Nothing -> return $ Sealed NilFL- Just _ -> Sealed `fmap` unrecordedChanges (UseIndex, ScanKnown) repository files- `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- filtered_changes p = maybe_reverse $ getChangesInfo opts recFiles p- debugMessage "About to read the repository..."- patches <- readRepo repository- debugMessage "Done reading the repository."- if Interactive `elem` opts- then do let (fp_and_fs, _, _) = filtered_changes patches- fp = map fst fp_and_fs- viewChanges opts fp- else do when (isJust files && not (XMLOutput `elem` opts)) $- putStrLn $ "Changes to "++unwords (fromJust recFiles)++":\n"- debugMessage "About to print the changes..."- let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters- ps <- readRepo repository -- read repo again to prevent holding onto- -- values forced by filtered_changes- putDocLnWith printers $ changelog opts ps $ filtered_changes patches- where maybe_reverse (xs,b,c) = if doReverse opts- then (reverse xs, b, c)- else (xs, b, c)----- FIXME: this prose is unreadable. --twb, 2009-08-changesHelp' :: String-changesHelp' =- "When given one or more files or directories as arguments, only\n" ++- "patches which affect those files or directories are listed. This\n" ++- "includes changes that happened to files before they were moved or\n" ++- "renamed.\n" ++- "\n" ++- "When given a --from-tag, --from-patch or --from-match, only changes\n" ++- "since that tag or patch are listed. Similarly, the --to-tag,\n" ++- "--to-patch and --to-match options restrict the list to older patches.\n" ++- "\n" ++- "The --last and --max-count options both limit the number of patches\n" ++- "listed. The former applies BEFORE other filters, whereas the latter\n" ++- "applies AFTER other filters. For example `darcs changes foo.c\n" ++- "--max-count 3' will print the last three patches that affect foo.c,\n" ++- "whereas `darcs changes --last 3 foo.c' will, of the last three\n" ++- "patches, print only those that affect foo.c.\n"--getChangesInfo :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Maybe [FilePath]- -> PatchSet p C(x y)- -> ( [(Sealed2 (PatchInfoAnd p), [FilePath])]- , [(FilePath, FilePath)]- , Maybe Doc )-getChangesInfo opts plain_fs ps =- case (sp1s, sp2s) of- (Sealed p1s, Sealed p2s) ->- case findCommonWithThem p2s p1s of- _ :> us ->- let ps' = filterRL pf (reverseFL us) in- case plain_fs of- Nothing -> foldr (\x xs -> (x, []) -:- xs) ([], [], Nothing) $- maybe id take (maxCount opts) ps'- Just fs -> let fs' = map (\x -> "./" ++ x) fs in- filterPatchesByNames (maxCount opts) fs' ps'- where sp1s = if firstMatch opts- then matchFirstPatchset opts ps- else Sealed $ PatchSet NilRL NilRL- sp2s = if secondMatch opts- then matchSecondPatchset opts ps- else Sealed $ ps- pf = if haveNonrangeMatch opts- then matchAPatchread opts- else \_ -> True---- | Take a list of filenames and patches and produce a list of patches that--- actually touch the given files with a list of touched file names, a list of--- original-to-current filepath mappings, indicating the original names of the--- affected files and possibly an error. Additionaly, the function takes a--- "depth limit" -- maxcount, that could be Nothing (return everything) or--- "Just n" -- returns at most n patches touching the file (starting from the--- beginning of the patch list).-filterPatchesByNames :: (RepoPatch p, ApplyState p ~ Tree) =>- Maybe Int -- ^ maxcount- -> [FilePath] -- ^ filenames- -> [Sealed2 (PatchInfoAnd p)] -- ^ patchlist- -> ([(Sealed2 (PatchInfoAnd p),[FilePath])], [(FilePath, FilePath)], Maybe Doc)-filterPatchesByNames maxcount fns patches = removeNonRenames $- evalState (filterPatchesByNames' fns patches) (maxcount, initRenames) where- removeNonRenames (ps, renames, doc) = (ps, removeIds renames, doc)- removeIds = filter (\(a, b) -> a /= b)- initRenames = map (\x -> (x, x)) fns- returnFinal = (\renames -> ([], renames, Nothing)) <$> gets snd- filterPatchesByNames' [] _ = returnFinal- filterPatchesByNames' _ [] = returnFinal- filterPatchesByNames' fs (s2hp@(Sealed2 hp) : ps) = do- (count, renames) <- get- let stopNow = case count of- Nothing -> False- Just c -> c <= 0- if stopNow- then returnFinal- else case hopefullyM hp of- Nothing -> do- let err = text "Can't find changes prior to:"- $$ description hp- return ([], renames, Just err)- Just p ->- case lookTouch (Just renames) fs (invert p) of- (True, affected, [], renames') -> do- return ([(s2hp, affected)], renames', Nothing)- (True, affected, fs', renames') -> do- let sub1Mb c = (subtract 1) <$> c- modify $ \(c, _) -> (sub1Mb c, renames')- rest <- filterPatchesByNames' fs' ps- return $ (s2hp, affected) -:- rest- (False, _, fs', renames') -> do- modify $ second (const renames')- filterPatchesByNames' fs' ps---- | Note, lazy pattern matching is required to make functions like--- filterPatchesByNames lazy in case you are only not interested in--- the first element. E.g.:------ let (fs, _, _) = filterPatchesByNames ...-(-:-) :: a -> ([a],b,c) -> ([a],b,c)-x -:- ~(xs,y,z) = (x:xs,y,z)--changelog :: forall p C(start x)- . (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> PatchSet p C(start x)- -> ([(Sealed2 (PatchInfoAnd p), [FilePath])], [(FilePath, FilePath)], Maybe Doc)- -> Doc-changelog opts patchset (pis_and_fs, createdAsFs, mbErr)- | Count `elem` opts = text $ show $ length pis_and_fs- | MachineReadable `elem` opts =- maybe (vsep $ map (unseal2 (showPatchInfo.info)) pis) errorDoc mbErr- | XMLOutput `elem` opts =- text "<changelog>"- $$ vcat created_as_xml- $$ vcat actual_xml_changes- $$ text "</changelog>"- | Summary `elem` opts || Verbose `elem` opts =- mbAppendErr $ vsep (map (number_patch change_with_summary) pis_and_fs)- | otherwise = mbAppendErr $ vsep (map (number_patch description') pis_and_fs)- where mbAppendErr = maybe id (\err -> ($$ err)) mbErr- change_with_summary :: (Sealed2 (PatchInfoAnd p), [FilePath]) -> Doc- change_with_summary (Sealed2 hp, fs)- | Just p <- hopefullyM hp = if showChangesOnlyToFiles opts- then description hp $$ text "" $$- indent (showFriendly opts (filterFLFL xx $ effect p))- else showFriendly opts p- | otherwise = description hp- $$ indent (text "[this patch is unavailable]")- where xx x = case listTouchedFiles x of- ys | null $ ys `intersect` fs -> unsafeCoerce IsEq- -- in that case, the change does not affect the patches we are- -- looking at, so we ignore the difference between the two states.- -- It's all read-only anyway.- _ -> NotEq- xml_with_summary (Sealed2 hp)- | Just p <- hopefullyM hp = insertBeforeLastline- (toXml $ info hp) (indent $ xmlSummary p)- xml_with_summary (Sealed2 hp) = toXml (info hp)- indent = prefix " "- actual_xml_changes = if Summary `elem` opts- then map xml_with_summary pis- else map (toXml . (unseal2 info)) pis-- created_as_xml = map create createdAsFs where- create rename@(_, as) = createdAsXml (first_change_of as) rename- -- We need to reorder the patches when they haven't been reversed- -- already, so that we find the *first* patch that modifies a given- -- file, not the last (by default, the list is oldest->newest).- reorderer = if not (doReverse opts) then reverse else id- oldest_first_pis_and_fs = reorderer pis_and_fs- couldnt_find fn = error $ "Couldn't find first patch affecting " ++- fn ++ " in pis_and_fs"- mb_first_change_of fn = find ((fn `elem`) . snd) oldest_first_pis_and_fs- find_first_change_of fn = fromMaybe (couldnt_find fn)- (mb_first_change_of fn)- first_change_of = unseal2 info . fst . find_first_change_of- number_patch f x = if NumberPatches `elem` opts- then case get_number (fst x) of- Just n -> text (show n++":") <+> f x- Nothing -> f x- else f x- get_number :: Sealed2 (PatchInfoAnd p) -> Maybe Int- get_number (Sealed2 y) = gn 1 (newset2RL patchset)- where iy = info y- gn :: Int -> RL (PatchInfoAnd p) C(start y) -> Maybe Int- gn n (b:<:bs) | seq n (info b) == iy = Just n- | otherwise = gn (n+1) bs- gn _ NilRL = Nothing- pis = map fst pis_and_fs- description' = unseal2 description . fst---- FIXME: this prose is unreadable. --twb, 2009-08-changesHelp'' :: String-changesHelp'' =- "Three output formats exist. The default is --human-readable. You can\n" ++- "also select --context, which is the internal format (as seen in patch\n" ++- "bundles) that can be re-read by Darcs (e.g. `darcs get --context').\n" ++- "\n" ++- "Finally, there is --xml-output, which emits valid XML... unless a the\n" ++- "patch metadata (author, name or description) contains a non-ASCII\n" ++- "character and was recorded in a non-UTF8 locale.\n" ++- "\n" ++- -- FIXME: can't we just disallow the following usage?- "Note that while the --context flag may be used in conjunction with\n" ++- "--xml-output or --human-readable, in neither case will darcs get be\n" ++- "able to read the output. On the other hand, sufficient information\n" ++- "WILL be output for a knowledgeable human to recreate the current state\n" ++- "of the repository.\n"--changesContext :: [DarcsFlag] -> IO ()-changesContext opts = do- let repodir = fromMaybe "." $ getRepourl opts- withRepositoryDirectory opts repodir $ RepoJob $ \repository -> do- (_ :> ps') <- contextPatches `fmap` readRepo repository- let ps = mapRL (\p -> (seal2 p, [])) ps'- unless fancy $ putStrLn "\nContext:\n"- putDocLnWith simplePrinters $ changelog opts' emptyset (ps, [], Nothing)- where opts' = if fancy then opts else MachineReadable : opts- fancy = HumanReadable `elem` opts || XMLOutput `elem` opts- emptyset = PatchSet NilRL NilRL--log :: DarcsCommand-log = commandAlias "log" Nothing changes--createdAsXml :: PatchInfo -> (String, String) -> Doc-createdAsXml pinfo (current, createdAs) =- text "<created_as current_name='"- <> escapeXML current- <> text "' original_name='"- <> escapeXML createdAs- <> text "'>"- $$ toXml pinfo- $$ text "</created_as>"
− src/Darcs/Commands/Check.hs
@@ -1,167 +0,0 @@--- Copyright (C) 2002-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- 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 )--import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo )-import Darcs.Arguments ( DarcsFlag(Quiet),- test, umaskOption,- leaveTestDir, workingRepoDir, ignoretimes- )-import Darcs.Flags(willIgnoreTimes)-import Darcs.Repository.Repair( replayRepository, checkIndex,- replayRepositoryInTemp,- RepositoryConsistency(..) )-import Darcs.Repository ( Repository, amInHashedRepository, withRepository,- testRecorded, readRecorded, RepoJob(..),- withRepoLock, replacePristine, writePatchSet )-import Darcs.Patch ( RepoPatch, showPatch, PrimOf )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Witnesses.Ordered ( FL(..) )-import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft )-import Darcs.Repository.Prefs ( filetypeFunction )-import Darcs.Diff( treeDiff )-import Printer ( text, ($$), (<+>) )-import Storage.Hashed.Tree( Tree )--#include "gadts.h"--checkDescription :: String-checkDescription = "Check the repository for consistency."--checkHelp :: String-checkHelp =- "This command verifies that the patches in the repository, when applied\n" ++- "successively to an empty tree, result in the pristine tree. If not,\n" ++- "the differences are printed and Darcs exits unsucessfully (with a\n" ++- "non-zero exit status).\n" ++- "\n" ++- "If a regression test is defined (see `darcs setpref') it will be run\n" ++- "by `darcs check'. Use the --no-test option to disable this.\n"--check :: DarcsCommand-check = DarcsCommand {commandProgramName = "darcs",- commandName = "check",- commandHelp = checkHelp,- commandDescription = checkDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = checkCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [ test,- leaveTestDir,- workingRepoDir,- ignoretimes- ]}--checkCmd :: [DarcsFlag] -> [String] -> IO ()-checkCmd opts _ = withRepository opts (RepoJob (check' opts))--check'- :: forall p C(r u t) . (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> Repository p C(r u t) -> IO ()-check' opts repository = do- state <- replayRepositoryInTemp repository opts- failed <-- case state of- RepositoryConsistent -> do- putInfo opts $ text "The repository is consistent!"- rc <- testRecorded repository- when (rc /= ExitSuccess) $ exitWith rc- return False- BrokenPristine newpris -> do- brokenPristine newpris- return True- BrokenPatches newpris _ -> do- brokenPristine newpris- putInfo opts $ text "Found broken patches."- return True- bad_index <- case willIgnoreTimes opts of- False -> not <$> checkIndex repository (Quiet `elem` opts)- True -> return False- when bad_index $ putInfo opts $ text "Bad index."- exitWith $ if failed || bad_index then ExitFailure 1 else ExitSuccess- where- brokenPristine newpris = do- putInfo opts $ text "Looks like we have a difference..."- 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"- return ()- Just mc -> do- ftf <- filetypeFunction- Sealed (diff :: FL (PrimOf p) C(r r2)) <- unFreeLeft `fmap` treeDiff ftf newpris mc :: IO (Sealed (FL (PrimOf p) C(r)))- putInfo opts $ case diff of- NilFL -> text "Nothing"- patch -> text "Difference: " <+> showPatch patch- putInfo opts $ text ""- $$ text "Inconsistent repository!"---repairDescription :: String-repairDescription = "Repair a corrupted repository."--repairHelp :: String-repairHelp =- "The `darcs repair' command attempts to fix corruption in the current\n" ++- "repository. Currently it can only repair damage to the pristine tree,\n" ++- "which is where most corruption occurs.\n"--repair :: DarcsCommand-repair = DarcsCommand {commandProgramName = "darcs",- commandName = "repair",- commandHelp = repairHelp,- commandDescription = repairDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = repairCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [umaskOption],- commandBasicOptions = [workingRepoDir]}--repairCmd :: [DarcsFlag] -> [String] -> IO ()-repairCmd opts _ = withRepoLock opts $ RepoJob $ \repository -> do- replayRepository repository opts $ \state ->- case state of- RepositoryConsistent ->- putStrLn "The repository is already consistent, no changes made."- BrokenPristine tree -> do- putStrLn "Fixing pristine tree..."- replacePristine repository tree- BrokenPatches tree newps -> do- putStrLn "Writing out repaired patches..."- _ <- writePatchSet newps opts- putStrLn "Fixing pristine tree..."- replacePristine repository tree- index_ok <- checkIndex repository (Quiet `elem` opts)- unless index_ok $ do renameFile "_darcs/index" "_darcs/index.bad"- putStrLn "Bad index discarded."-
− src/Darcs/Commands/Convert.hs
@@ -1,261 +0,0 @@--- Copyright (C) 2002-2005,2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, MagicHash #-}--#include "gadts.h"--module Darcs.Commands.Convert ( convert ) where--import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,- createDirectory )-import Workaround ( getCurrentDirectory )-import Control.Monad ( when )-import GHC.Base ( unsafeCoerce# )-import Data.Maybe ( catMaybes )-import qualified Data.ByteString as B--import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, info, hopefully )-import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo )-import Darcs.Arguments- ( DarcsFlag- ( AllowConflicts, NewRepo, SetScriptsExecutable, UseFormat2- , NoUpdateWorking- )- , reponame- , setScriptsExecutableOption- , networkOptions- )-import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), withRepositoryDirectory, readRepo,- createRepository, invalidateIndex,- optimizeInventory,- tentativelyMergePatches, patchSetToPatches,- createPristineDirectoryTree,- revertRepositoryChanges, finalizeRepositoryChanges,- applyToWorking, setScriptsExecutable )-import Darcs.Global ( darcsdir )-import Darcs.Patch ( Named, showPatch, patch2patchinfo, fromPrim, fromPrims,- infopatch, adddeps, getdeps, effect, patchcontents )-import Darcs.Witnesses.Eq ( EqCheck(..), (=/\=) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapFL_FL,- concatFL, mapRL )-import Darcs.Patch.Info ( piRename, piTag, isTag, PatchInfo )-import Darcs.Patch.V1 ( Patch )-import Darcs.Patch.V2 ( RealPatch )-import Darcs.Patch.V1.Commute ( publicUnravel )-import Darcs.Patch.V1.Core ( Patch(PP), isMerger )-import Darcs.Patch.V2.Real ( mergeUnravelled )-import Darcs.Patch.Prim.V1 ( Prim )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2RL )-import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )-import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2))-import Darcs.Repository.Motd ( showMotd )-import Darcs.Utils ( clarifyErrors, askUser, catchall )-import Darcs.ProgressPatches ( progressFL )-import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(..) )-import Printer ( text, ($$) )-import Darcs.ColorPrinter ( traceDoc )-import Darcs.Lock ( writeBinFile )-import Darcs.External ( fetchFilePS, Cachable(Uncachable) )-import System.FilePath.Posix--#include "gadts.h"-#include "impossible.h"--convertDescription :: String-convertDescription = "Convert a repository from a legacy format."--convertHelp :: String-convertHelp =- "The current repository format is called `darcs-2'. It was introduced\n" ++- "in Darcs 2.0 and became the default for new projects in Darcs 2.2.\n" ++- "The `darcs convert' command allows existing projects to migrate to\n" ++- "this format from the older `darcs-1' format.\n" ++- "\n" ++- "This command DOES NOT modify the source repository; a new destination\n" ++- "repository is created. It is safe to run this command more than once\n" ++- "on a repository (e.g. for testing), before the final conversion.\n" ++- "\n" ++- convertHelp' ++- "\n" ++- "Due to this limitation, migrating a multi-branch project is a little\n" ++- "awkward. Sorry! Here is the recommended process:\n" ++- "\n" ++- " 1. for each branch `foo', tag that branch with `foo-final';\n" ++- " 2. merge all branches together (--allow-conflicts may help);\n" ++- " 3. run `darcs optimize --reorder' on the result;\n" ++- " 4. run `darcs convert' to create a merged darcs-2 repository;\n" ++- " 5. re-create each branch by calling `darcs get --tag foo-final' on\n" ++- " the darcs-2 repository; and finally\n" ++- " 6. use `darcs obliterate' to delete the foo-final tags.\n"---- | This part of the help is split out because it is used twice: in--- the help string, and in the prompt for confirmation.-convertHelp' :: String-convertHelp' =- "WARNING: the repository produced by this command is not understood by\n" ++- "Darcs 1.x, and patches cannot be exchanged between repositories in\n" ++- "darcs-1 and darcs-2 formats.\n" ++- "\n" ++- "Furthermore, darcs 2 repositories created by different invocations of\n" ++- "this command SHOULD NOT exchange patches, unless those repositories\n" ++- "had no patches in common when they were converted. (That is, within a\n" ++- "set of repos that exchange patches, no patch should be converted more\n" ++- "than once.)\n"--convert :: DarcsCommand-convert = DarcsCommand {commandProgramName = "darcs",- commandName = "convert",- commandHelp = convertHelp,- commandDescription = convertDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["<SOURCE>", "[<DESTINATION>]"],- commandCommand = convertCmd,- commandPrereq = \_ -> return $ Right (),- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = networkOptions,- commandBasicOptions = [reponame,setScriptsExecutableOption]}--convertCmd :: [DarcsFlag] -> [String] -> IO ()-convertCmd opts [inrepodir, outname] = convertCmd (NewRepo outname:opts) [inrepodir]-convertCmd orig_opts [inrepodir] = do-- typed_repodir <- ioAbsoluteOrRemote inrepodir- let repodir = toPath typed_repodir-- --test for converting darcs-2 repository- format <- identifyRepoFormat repodir- when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format."-- putStrLn convertHelp'- let vow = "I understand the consequences of my action"- putStrLn "Please confirm that you have read and understood the above"- vow' <- askUser ("by typing `" ++ vow ++ "': ")- when (vow' /= vow) $ fail "User didn't understand the consequences."-- let opts = UseFormat2:orig_opts- showMotd opts repodir- mysimplename <- makeRepoName opts repodir- createDirectory mysimplename- setCurrentDirectory mysimplename- createRepository opts- writeBinFile (darcsdir++"/hashed_inventory") ""- withRepoLock (NoUpdateWorking:opts) $ V2Job $ \repository ->- withRepositoryDirectory opts repodir $ V1Job $ \themrepo -> do- theirstuff <- readRepo themrepo- let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff- inOrderTags = iot theirstuff- where iot :: PatchSet p C(s x) -> [PatchInfo]- iot (PatchSet _ ts) = iot_ ts- iot_ :: RL(Tagged t1) C(t y) -> [PatchInfo]- iot_ (Tagged t _ _ :<: ts) = info t : iot_ ts- iot_ NilRL = []- outOfOrderTags = catMaybes $ mapRL oot $ newset2RL theirstuff- where oot t = if isTag (info t) && not (info t `elem` inOrderTags)- then Just (info t, getdeps $ hopefully t)- else Nothing- fixDep p = case lookup p outOfOrderTags of- Just d -> p : concatMap fixDep d- Nothing -> [p]- convertOne :: Patch Prim C(x y) -> FL (RealPatch Prim) C(x y)- convertOne x | isMerger x = case mergeUnravelled $ publicUnravel x of- Just (FlippedSeal y) ->- case effect y =/\= effect x of- IsEq -> y :>: NilFL- NotEq ->- traceDoc (text "lossy conversion:" $$- showPatch x)- fromPrims (effect x)- Nothing -> traceDoc (text- "lossy conversion of complicated conflict:" $$- showPatch x)- fromPrims (effect x)- convertOne (PP x) = fromPrim x :>: NilFL- convertOne _ = impossible- convertFL :: FL (Patch Prim) C(x y) -> FL (RealPatch Prim) C(x y)- convertFL = concatFL . mapFL_FL convertOne- convertNamed :: Named (Patch Prim) C(x y) -> PatchInfoAnd (RealPatch Prim) C(x y)- convertNamed n = n2pia $- adddeps (infopatch (convertInfo $ patch2patchinfo n) $- convertFL $ patchcontents n)- (map convertInfo $ concatMap fixDep $ getdeps n)- convertInfo n | n `elem` inOrderTags = n- | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n- applySome xs = do -- TODO this unsafeCoerce hack is because we don't keep track of the repository state properly- -- Really sequence_ $ mapFL applySome below should instead be a repeated add operation -- -- there doesn't seem to be any reason we need to do a merge here.- let repository2 = unsafeCoerce# repository :: Repository (RealPatch Prim) C(a b a)- Sealed pw <- tentativelyMergePatches repository2 "convert" (AllowConflicts:opts) NilFL xs- finalizeRepositoryChanges repository2 -- this is to clean out pristine.hashed- revertRepositoryChanges repository2- _ <- revertable $ applyToWorking repository2 opts pw- invalidateIndex repository2- sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches- invalidateIndex repository- revertable $ createPristineDirectoryTree repository "."- when (SetScriptsExecutable `elem` opts) $ setScriptsExecutable-- -- Copy over the prefs file- let prefsRelPath = darcsdir </> "prefs" </> "prefs"- (fetchFilePS (repodir </> prefsRelPath) Uncachable >>= B.writeFile prefsRelPath)- `catchall` return ()-- optimizeInventory repository- putInfo opts $ text "Finished converting."- where revertable x = x `clarifyErrors` unlines- ["An error may have left your new working directory an inconsistent",- "but recoverable state. You should be able to make the new",- "repository consistent again by running darcs revert -a."]--convertCmd _ _ = fail "You must provide 'convert' with either one or two arguments."--makeRepoName :: [DarcsFlag] -> FilePath -> IO String-makeRepoName (NewRepo n:_) _ =- do exists <- doesDirectoryExist n- file_exists <- doesFileExist n- if exists || file_exists- then fail $ "Directory or file named '" ++ n ++ "' already exists."- else return n-makeRepoName (_:as) d = makeRepoName as d-makeRepoName [] d =- case dropWhile (=='.') $ reverse $- takeWhile (\c -> c /= '/' && c /= ':') $- dropWhile (=='/') $ reverse d of- "" -> modifyRepoName "anonymous_repo"- base -> modifyRepoName base--modifyRepoName :: String -> IO String-modifyRepoName name =- if head name == '/'- then mrn name (-1)- else do cwd <- getCurrentDirectory- mrn (cwd ++ "/" ++ name) (-1)- where- mrn :: String -> Int -> IO String- mrn n i = do- exists <- doesDirectoryExist thename- file_exists <- doesFileExist thename- if not exists && not file_exists- then do when (i /= -1) $- putStrLn $ "Directory '"++ n ++- "' already exists, creating repository as '"++- thename ++"'"- return thename- else mrn n $ i+1- where thename = if i == -1 then n else n++"_"++show i-
− src/Darcs/Commands/Diff.hs
@@ -1,214 +0,0 @@--- Copyright (C) 2003-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Diff ( diffCommand ) where--import System.FilePath.Posix ( takeFileName )-import Workaround ( getCurrentDirectory )-import Darcs.Utils ( askEnter, withCurrentDirectory )-import Control.Monad ( when )-import Data.List ( (\\) )--import Storage.Hashed.Plain( writePlainTree )--import Darcs.External( diffProgram )-import CommandLine ( parseCmd )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments- ( DarcsFlag(AfterPatch, DiffCmd, DiffFlags, LastN)- , diffCmdFlag- , diffflags- , fixSubPaths- , matchRange- , pauseForGui- , storeInMemory- , unidiff- , workingRepoDir- )-import Darcs.Flags ( isNotUnified, wantGuiPause )-import Darcs.Patch.PatchInfoAnd ( info )-import Darcs.RepoPath ( AbsolutePath, SubPath, toFilePath, sp2fn )-import Darcs.Match ( getPartialFirstMatch, getPartialSecondMatch,- firstMatch, secondMatch,- matchFirstPatchset, matchSecondPatchset )-import Darcs.Repository ( withRepository, RepoJob(..), readRepo,- amInHashedRepository,- createPristineDirectoryTree,- createPartialsPristineDirectoryTree )-import Darcs.Patch.Set ( PatchSet, newset2RL )-import Darcs.Repository.State ( readUnrecorded )-import Darcs.Patch ( RepoPatch )-import Darcs.Witnesses.Ordered ( mapRL )-import Darcs.Patch.Info ( PatchInfo, humanFriendly )-import Darcs.External ( execPipeIgnoreError )-import Darcs.Lock ( withTempDir )-import Darcs.Witnesses.Sealed ( unseal )-import Printer ( Doc, putDoc, vcat, empty, ($$) )-#include "impossible.h"--#include "gadts.h"--diffDescription :: String-diffDescription = "Create a diff between two versions of the repository."--diffHelp :: String-diffHelp =- "The `darcs diff' command compares two versions of the working tree of\n" ++- "the current repository. Without options, the pristine (recorded) and\n" ++- "unrecorded working trees are compared. This is lower-level than\n" ++- "the `darcs whatsnew' command, since it outputs a line-by-line diff,\n" ++- "and it is also slower. As with `darcs whatsnew', if you specify\n" ++- "files or directories, changes to other files are not listed.\n" ++- "The command always uses an external diff utility.\n" ++- "\n" ++- "With the --patch option, the comparison will be made between working\n" ++- "trees with and without that patch. Patches `after' the selected patch\n" ++- "are not present in either of the compared working trees. The\n" ++- "--from-patch and --to-patch options allow the set of patches in the\n" ++- "`old' and `new' working trees to be specified separately.\n" ++- "\n" ++- "The associated tag and match options are also understood, e.g. `darcs\n" ++- "diff --from-tag 1.0 --to-tag 1.1'. All these options assume an\n" ++- "ordering of the patch set, so results may be affected by operations\n" ++- "such as `darcs optimize --reorder'.\n" ++- "\n" ++- "diff(1) is called with the arguments -rN. The --unified option causes\n" ++- "-u to be passed to diff(1). An additional argument can be passed\n" ++- "using --diff-opts, such as --diff-opts=-ud or --diff-opts=-wU9.\n" ++- "\n" ++- "The --diff-command option can be used to specify an alternative\n" ++- "utility, such as meld (GNOME) or opendiff (OS X). Arguments may be\n" ++- "included, separated by whitespace. The value is not interpreted by a\n" ++- "shell, so shell constructs cannot be used. The arguments %1 and %2\n" ++- "MUST be included, these are substituted for the two working trees\n" ++- "being compared. If this option is used, --diff-opts is ignored.\n"--diffCommand :: DarcsCommand-diffCommand = DarcsCommand {commandProgramName = "darcs",- commandName = "diff",- commandHelp = diffHelp,- commandDescription = diffDescription,- commandExtraArgs = -1,- commandExtraArgHelp- = ["[FILE or DIRECTORY]..."],- commandCommand = diffCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions =- [ pauseForGui- ],- commandBasicOptions =- [ matchRange- , diffCmdFlag- , diffflags- , unidiff- , workingRepoDir- , storeInMemory- ]- }--getDiffOpts :: [DarcsFlag] -> [String]-getDiffOpts opts | isNotUnified opts = get_nonU_diff_opts opts- | otherwise = "-u" : get_nonU_diff_opts opts- where get_nonU_diff_opts (DiffFlags f:fs) = f : get_nonU_diff_opts fs- get_nonU_diff_opts (_:fs) = get_nonU_diff_opts fs- get_nonU_diff_opts [] = []---- | Returns the command we should use for diff as a tuple (command, arguments).--- This will either be whatever the user specified via --diff-command or the--- default 'diffProgram'. Note that this potentially involves parsing the--- user's diff-command, hence the possibility for failure with an exception.-getDiffCmdAndArgs :: String -> [DarcsFlag] -> String -> String- -> Either String (String, [String])-getDiffCmdAndArgs cmd opts f1 f2 = helper opts where- helper (DiffCmd c:_) =- case parseCmd [ ('1', f1) , ('2', f2) ] c of- Left err -> Left $ show err- Right ([],_) -> bug $ "parseCmd should never return empty list"- Right ((h:t),_) -> Right (h,t)- helper [] = -- if no command specified, use 'diff'- Right (cmd, ("-rN":getDiffOpts opts++[f1,f2]))- helper (_:t) = helper t--diffCmd :: [DarcsFlag] -> [String] -> IO ()-diffCmd opts args- | not (null [i | LastN i <- opts]) &&- not (null [p | AfterPatch p <- opts]) =- fail $ "using --patch and --last at the same time with the 'diff'" ++- " command doesn't make sense. Use --from-patch to create a diff" ++- " from this patch to the present, or use just '--patch' to view" ++- " this specific patch."- | null args = doDiff opts Nothing- | otherwise = doDiff opts . Just =<< fixSubPaths opts args--doDiff :: [DarcsFlag] -> Maybe [SubPath] -> IO ()-doDiff opts sps = withRepository opts $ RepoJob $ \repository -> do- let pathList = map sp2fn `fmap` sps- formerdir <- getCurrentDirectory- withTempDirs (takeFileName formerdir) $ \odir ndir -> do- if firstMatch opts- then withCurrentDirectory odir $ getPartialFirstMatch repository opts pathList- else case pathList of- Nothing -> createPristineDirectoryTree repository $ toFilePath odir- Just pl -> createPartialsPristineDirectoryTree repository pl $ toFilePath odir- if secondMatch opts- then withCurrentDirectory ndir $ getPartialSecondMatch repository opts pathList- else withCurrentDirectory formerdir $- readUnrecorded repository sps >>= (flip writePlainTree (toFilePath ndir))- thediff <- withCurrentDirectory (toFilePath odir ++ "/..") $- case pathList of- Nothing -> rundiff (takeFileName $ toFilePath odir) (takeFileName $ toFilePath ndir)- Just fs -> vcat `fmap`- mapM (\f -> rundiff- (takeFileName (toFilePath odir) ++ "/" ++ toFilePath f)- (takeFileName (toFilePath ndir) ++ "/" ++ toFilePath f)) fs- morepatches <- readRepo repository- putDoc $ changelog (getDiffInfo opts morepatches)- $$ thediff- where rundiff :: String -> String -> IO Doc- rundiff f1 f2 = do- cmd <- diffProgram- case getDiffCmdAndArgs cmd opts f1 f2 of- Left err -> fail err- Right (d_cmd, d_args) ->- let pausingForGui = wantGuiPause opts in- do when pausingForGui $ putStrLn $- "Running command '" ++ unwords (d_cmd:d_args) ++ "'"- output <- execPipeIgnoreError d_cmd d_args empty- when pausingForGui $- askEnter "Hit return to move on..."- return output-- withTempDirs :: String -> (AbsolutePath -> AbsolutePath -> IO a) -> IO a- withTempDirs x f = withTempDir ("old-" ++ x) $ \odir ->- withTempDir ("new-" ++ x) $ \ndir -> f odir ndir--getDiffInfo :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> [PatchInfo]-getDiffInfo opts ps =- let infos = mapRL info . newset2RL- handle (match_cond, do_match)- | match_cond opts = unseal infos (do_match opts ps)- | otherwise = infos ps- in handle (secondMatch, matchSecondPatchset)- \\ handle (firstMatch, matchFirstPatchset)--changelog :: [PatchInfo] -> Doc-changelog pis = vcat $ map humanFriendly pis-
− src/Darcs/Commands/Dist.hs
@@ -1,172 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- |--- Module : Darcs.Commands.Dist--- Copyright : 2003 David Roundy--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module Darcs.Commands.Dist- (- dist- ) where--import Prelude hiding ( writeFile )--import Data.ByteString.Lazy ( writeFile )-import Data.Char ( isAlphaNum )-import Control.Monad ( when )-import System.Directory ( setCurrentDirectory )-import System.Cmd ( system )-import System.Exit ( ExitCode(..), exitWith )-import System.FilePath.Posix ( takeFileName, (</>) )--import Workaround ( getCurrentDirectory )-import Codec.Archive.Tar ( pack, write )-import Codec.Archive.Tar.Entry ( entryPath )-import Codec.Compression.GZip ( compress )--import Darcs.Arguments ( DarcsFlag(Verbose, Quiet, DistName, SetScriptsExecutable), distnameOption,- workingRepoDir, matchOne, storeInMemory,- setScriptsExecutableOption )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Lock ( withTempDir )-import Darcs.Match ( getNonrangeMatch, haveNonrangeMatch, firstMatch, getFirstMatch )-import Darcs.Repository ( amInHashedRepository, withRepoReadLock, RepoJob(..),- setScriptsExecutable,- createPartialsPristineDirectoryTree )-import Darcs.Repository.Prefs ( getPrefval )-import Darcs.RepoPath ( AbsolutePath, toFilePath )-import Darcs.Utils ( withCurrentDirectory )---distDescription :: String-distDescription = "Create a distribution tarball."---distHelp :: String-distHelp =- "The `darcs dist' command creates a compressed archive (a `tarball') in\n" ++- "the repository's root directory, containing the recorded state of the\n" ++- "working tree (unrecorded changes and the _darcs directory are\n" ++- "excluded).\n" ++- "\n" ++- "If a predist command is set (see `darcs setpref'), that command will\n" ++- "be run on the tarball contents prior to archiving. For example,\n" ++- "autotools projects would set it to `autoconf && automake'.\n" ++- "\n" ++- "By default, the tarball (and the top-level directory within the\n" ++- "tarball) has the same name as the repository, but this can be\n" ++- "overridden with the --dist-name option.\n"-- -- FIXME: this is tedious and ugly.- {-- ++ "\n" ++- "Suppose you use a version numbering scheme `major.minor.patch', and\n" ++- "you tag each release `major.minor'. You can then calculate the\n" ++- "version number by taking the newest tag and appending a dot and the\n" ++- "number of patches since that tag. If you use the directory name as\n" ++- "the project name, you can make tarballs of the form name-version.tgz\n" ++- "using the following shell script:\n" ++- "\n" ++- " major_minor=$(darcs show tags | head -1) &&\n" ++- " patch_level=$(($(darcs changes --count --from-tag .) - 1)) &&\n" ++- " version=$major_minor.$patch_level &&\n" ++- " project=${PWD##*/} &&\n" ++- " darcs dist --dist-name \"$project\"-\"$version\".tar.gz\n"- -}---dist :: DarcsCommand-dist = DarcsCommand- {- commandProgramName = "darcs"- , commandName = "dist"- , commandHelp = distHelp- , commandDescription = distDescription- , commandExtraArgs = 0- , commandExtraArgHelp = []- , commandCommand = distCmd- , commandPrereq = amInHashedRepository- , commandGetArgPossibilities = return []- , commandArgdefaults = nodefaults- , commandAdvancedOptions = []- , commandBasicOptions =- [- distnameOption- , workingRepoDir- , matchOne- , setScriptsExecutableOption- , storeInMemory- ]- }---distCmd :: [DarcsFlag]- -> [String]- -> IO ()-distCmd opts _ = withRepoReadLock opts $ RepoJob $ \repository -> do- formerdir <- getCurrentDirectory- let distname = getDistName formerdir [x | DistName x <- opts]- predist <- getPrefval "predist"- let resultfile = formerdir </> distname ++ ".tar.gz"- withTempDir "darcsdist" $ \tempdir -> do- setCurrentDirectory formerdir- withTempDir (toFilePath tempdir </> takeFileName distname) $ \ddir -> do- if haveNonrangeMatch opts- then- if firstMatch opts- then withCurrentDirectory ddir $ getFirstMatch repository opts- else withCurrentDirectory ddir $ getNonrangeMatch repository opts- else createPartialsPristineDirectoryTree repository [""] (toFilePath ddir)- ec <- case predist of Nothing -> return ExitSuccess- Just pd -> system pd- if ec == ExitSuccess- then- do- withCurrentDirectory ddir $- when (SetScriptsExecutable `elem` opts) setScriptsExecutable- doDist opts tempdir ddir resultfile- else- do- putStrLn "Dist aborted due to predist failure"- exitWith ec----- | This function performs the actual distribution action itself.--- NB - it does /not/ perform the pre-dist, that should already--- have completed successfully before this is invoked.-doDist :: [DarcsFlag] -> AbsolutePath -> AbsolutePath -> FilePath -> IO ()-doDist opts tempdir ddir resultfile = do- setCurrentDirectory (toFilePath tempdir)- let safeddir = safename $ takeFileName $ toFilePath ddir- entries <- pack "." [safeddir]- when (Verbose `elem` opts) $ putStr $ unlines $ map entryPath entries- writeFile resultfile $ compress $ write entries- when (Quiet `notElem` opts) $ putStrLn $ "Created dist as " ++ resultfile- where- safename n@(c:_) | isAlphaNum c = n- safename n = "./" ++ n---getDistName :: FilePath -> [String] -> FilePath-getDistName _ (dn:_) = dn-getDistName currentDirectory _ = takeFileName currentDirectory-
− src/Darcs/Commands/GZCRCs.hs
@@ -1,185 +0,0 @@--- Copyright (C) 2009 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.--{-# LANGUAGE CPP #-}-module Darcs.Commands.GZCRCs ( gzcrcs, doCRCWarnings ) where--import Control.Arrow ( first )-import Control.Monad ( when, unless )-import Control.Monad.Trans ( liftIO )-import Control.Monad.Writer ( runWriterT, tell )-import Data.List ( intercalate )-import Data.Monoid ( Any(..), Sum(..) )--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL--import System.Directory ( getDirectoryContents, doesFileExist, doesDirectoryExist )-import System.Exit ( ExitCode(..), exitWith )-import System.IO ( hPutStr, hPutStrLn, stderr )-import Data.IORef ( newIORef, readIORef, writeIORef )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, Check, Repair, JustThisRepo ),- checkOrRepair, workingRepoDir, justThisRepo- )-import Darcs.Repository ( Repository, amInRepository, withRepository, RepoJob(..) )-import Darcs.Patch ( RepoPatch )-import Printer ( putDocLn, text )-import ByteStringUtils ( isGZFile )-import Darcs.Lock ( gzWriteAtomicFilePSs )---- This command needs access beyond the normal repository APIs (to--- get at the caches and inspect them directly)--- Could move the relevant code into Darcs.Repository modules--- but it doesn't really seem worth it.-import Darcs.Repository.InternalTypes ( extractCache )-import Darcs.Repository.Cache ( Cache(..), writable, isthisrepo, hashedFilePath, allHashedDirs )---import Darcs.Global ( getCRCWarnings, resetCRCWarnings )-import ByteStringUtils ( gzDecompress )--#include "gadts.h"--gzcrcsDescription :: String-gzcrcsDescription = "Check or repair the CRCs of compressed files in the repository."--gzcrcsHelp :: String-gzcrcsHelp = formatText- [- "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed files " ++- "with bad CRCs (but valid data) to be written out. CRCs were not checked on " ++- "reading, so this bug wasn't noticed.",- "This command inspects your repository for this corruption and optionally repairs it.",- "By default it also does this for any caches you have configured and any other " ++- "local repositories listed as sources of patches for this one, perhaps because of a " ++- "lazy get. You can limit the scope to just the current repo with the --just-this-repo " ++- "flag.",- "Note that readonly caches, or other repositories listed as sources, " ++- "will be checked but not repaired. Also, this command will abort if it encounters " ++- "any non-CRC corruption in compressed files.",- "You may wish to also run 'darcs check --complete' before repairing the corruption. " ++- "This is not done automatically because it might result in needing to fetch extra " ++- "patches if the repository is lazy.",- "If there are any other problems with your repository, you can still repair the CRCs, " ++- "but you are advised to first make a backup copy in case the CRC errors are actually " ++- "caused by bad data and the old CRCs might be useful in recovering that data.",- "If you were warned about CRC errors during an operation involving another repository, " ++- "then it is possible that the other repository contains the corrupt CRCs, so you " ++- "should arrange for that repository to also be checked/repaired."- ]--formatText :: [String] -> String-formatText = unlines . intercalate [""] . map (map unwords . para 80 . words)---- |Take a list of words and split it up so that each chunk fits into the specified width--- when spaces are included. Any words longer than the specified width end up in a chunk--- of their own.-para :: Int -> [[a]] -> [[[a]]]-para w = para'- where para' [] = []- para' xs = uncurry (:) $ para'' w xs- para'' r (x:xs) | w == r || length x < r = first (x:) $ para'' (r - length x - 1) xs- para'' _ xs = ([], para' xs)---- |This is designed for use in an atexit handler, e.g. in Darcs.RunCommand-doCRCWarnings :: Bool -> IO ()-doCRCWarnings verbose = do- files <- getCRCWarnings- resetCRCWarnings- when (not . null $ files) $ do- hPutStr stderr . formatText $- ["",- "Warning: CRC errors found. These are probably harmless but should " ++- "be repaired. See 'darcs gzcrcs --help' for more information.",- ""]- when verbose $ hPutStrLn stderr $ unlines ("The following corrupt files were found:":files)--gzcrcs :: DarcsCommand-gzcrcs = DarcsCommand {commandProgramName = "darcs",- commandName = "gzcrcs",- commandHelp = gzcrcsHelp,- commandDescription = gzcrcsDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = gzcrcsCmd,- commandPrereq = amInRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [checkOrRepair,- justThisRepo,- workingRepoDir- ]}--gzcrcsCmd :: [DarcsFlag] -> [String] -> IO ()-gzcrcsCmd opts _ | Check `elem` opts || Repair `elem` opts = withRepository opts (RepoJob (gzcrcs' opts))-gzcrcsCmd _ _ = error "You must specify --check or --repair for gzcrcs"--gzcrcs'- :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t) -> IO ()-gzcrcs' opts repo = do- let Ca locs = extractCache repo- -- Somewhat ugly IORef use here because it's convenient, would be nicer- -- to pre-filter the list of locs to check and then decide whether to- -- print the message up front.- warnRelatedRepos <- newIORef (JustThisRepo `notElem` opts)- ((), Any checkFailed) <- runWriterT $ flip mapM_ locs $ \loc -> do- unless (JustThisRepo `elem` opts && not (isthisrepo loc)) $ do- let w = writable loc- flip mapM_ allHashedDirs $ \hdir -> do- let dir = hashedFilePath loc hdir ""- exists <- liftIO $ doesDirectoryExist dir- when exists $ do- liftIO $ do- warn <- readIORef warnRelatedRepos- when (warn && not (isthisrepo loc)) $ do- writeIORef warnRelatedRepos False- putInfo $ text "Also checking related repos and caches; use --just-this-repo to disable."- liftIO $ putInfo $ text $ "Checking " ++ dir ++ (if w then "" else " (readonly)")- files <- liftIO $ getDirectoryContents dir- ((), Sum count) <- runWriterT $ flip mapM_ files $ \file -> do- let fn = dir ++ file- isfile <- liftIO $ doesFileExist fn- when isfile $ do- gz <- liftIO $ isGZFile fn- case gz of- Nothing -> return ()- Just len -> do- contents <- liftIO $ B.readFile fn- let (uncompressed, isCorrupt) = gzDecompress (Just len) . BL.fromChunks $ [contents]- when isCorrupt $ do- tell (Sum 1) -- count of files in current directory- liftIO $ putVerbose $ text $ "Corrupt: " ++ fn- when (w && Repair `elem` opts) $ liftIO $ gzWriteAtomicFilePSs fn uncompressed- when (count > (0 :: Int)) $ do- liftIO $ putInfo $ text $- "Found " ++ show count ++ " corrupt file" ++ (if count > 1 then "s" else "") ++- (if Repair `elem` opts then (if w then " (repaired)" else " (not repaired") else "")- tell (Any True) -- something corrupt somewhere- when (Check `elem` opts && checkFailed) $ exitWith $ ExitFailure 1-- where- putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s- putVerbose s = when (Verbose `elem` opts) $ putDocLn s-
− src/Darcs/Commands/Get.hs
@@ -1,269 +0,0 @@--- Copyright (C) 2002-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--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 )-import Darcs.Flags( compression )-import Darcs.Arguments ( DarcsFlag( NewRepo, Lazy,- UseFormat2,- UseHashedInventory, UseNoWorkingDir,- SetScriptsExecutable, OnePattern ),- getContext, useWorkingDir,- partial, reponame,- matchOneContext, setDefault, setScriptsExecutableOption,- networkOptions, makeScriptsExecutable, usePacks )-import Darcs.Repository ( Repository, withRepository, RepoJob(..), withRepoLock, identifyRepositoryFor, readRepo,- tentativelyRemovePatches, patchSetToRepository,- copyRepository, tentativelyAddToPending,- finalizeRepositoryChanges, setScriptsExecutable- , invalidateIndex, createRepository )-import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat,- RepoProperty ( Darcs2, HashedInventory ), formatHas )-import Darcs.Patch ( RepoPatch, apply, invert, effect, PrimOf )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Witnesses.Ordered ( lengthFL, mapFL_FL, (:>)(..) )-import Darcs.Patch.PatchInfoAnd ( hopefully )-import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )-import Darcs.Repository.Prefs ( setDefaultrepo )-import Darcs.Repository.Motd ( showMotd )-import Darcs.Match ( havePatchsetMatch, getOnePatchset )-import Progress ( debugMessage )-import Printer ( text, errorDoc, ($$) )-import Darcs.Lock ( writeBinFile )-import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote)-import Darcs.Witnesses.Sealed ( Sealed(..) )-import Darcs.Global ( darcsdir )-import English ( englishNum, Noun(..) )-import Storage.Hashed.Tree( Tree )-#include "gadts.h"--getDescription :: String-getDescription = "Create a local copy of a repository."--getHelp :: String-getHelp =- "Get creates a local copy of a repository. The optional second\n" ++- "argument specifies a destination directory for the new copy; if\n" ++- "omitted, it is inferred from the source location.\n" ++- "\n" ++- "By default Darcs will copy every patch from the original repository.\n" ++- "This means the copy is completely independent of the original; you can\n" ++- "operate on the new repository even when the original is inaccessible.\n" ++- "If you expect the original repository to remain accessible, you can\n" ++- "use --lazy to avoid copying patches until they are needed (`copy on\n" ++- "demand'). This is particularly useful when copying a remote\n" ++- "repository with a long history that you don't care about.\n" ++- "\n" ++- "The --lazy option isn't as useful for local copies, because Darcs will\n" ++- "automatically use `hard linking' where possible. As well as saving\n" ++- "time and space, you can move or delete the original repository without\n" ++- "affecting a complete, hard-linked copy. Hard linking requires that\n" ++- "the copy be on the same filesystem and the original repository, and\n" ++- "that the filesystem support hard linking. This includes NTFS, HFS+\n" ++- "and all general-purpose Unix filesystems (such as ext3, UFS and ZFS).\n" ++- "FAT does not support hard links.\n" ++- "\n" ++- "Darcs get will not copy unrecorded changes to the source repository's\n" ++- "working tree.\n" ++- "\n" ++- getHelpTag--get :: DarcsCommand-get = DarcsCommand {commandProgramName = "darcs",- commandName = "get",- commandHelp = getHelp,- commandDescription = getDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["<REPOSITORY>", "[<DIRECTORY>]"],- commandCommand = getCmd,- commandPrereq = contextExists,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = usePacks:networkOptions,- commandBasicOptions = [reponame,- partial,- matchOneContext,- setDefault True,- setScriptsExecutableOption,- useWorkingDir]- }--clone :: DarcsCommand-clone = commandAlias "clone" Nothing get--getCmd :: [DarcsFlag] -> [String] -> IO ()-getCmd opts [inrepodir, outname] = getCmd (NewRepo outname:opts) [inrepodir]-getCmd opts [inrepodir] = do- debugMessage "Starting work on get..."- typed_repodir <- ioAbsoluteOrRemote inrepodir- let repodir = toPath typed_repodir- showMotd opts repodir- rfsource <- identifyRepoFormat repodir- debugMessage $ "Found the format of "++repodir++"..."- mysimplename <- makeRepoName opts repodir- createDirectory mysimplename- setCurrentDirectory mysimplename- let opts' = if formatHas Darcs2 rfsource- then UseFormat2:opts- else UseHashedInventory:filter (/= UseFormat2) opts- createRepository opts'- debugMessage "Finished initializing new directory."- setDefaultrepo repodir opts-- writeBinFile (darcsdir++"/hashed_inventory") ""-- if not (null [p | OnePattern p <- opts]) -- --to-match given- && Lazy `notElem` opts- then withRepository opts $ RepoJob $ \repository -> do- debugMessage "Using economical get --to-match handling"- fromrepo <- identifyRepositoryFor repository repodir- Sealed patches_to_get <- getOnePatchset fromrepo opts--- Warning: A do-notation statement discarded a result of type Repository p ghc-prim- _ <- patchSetToRepository fromrepo patches_to_get opts- debugMessage "Finished converting selected patch set to new repository"- else copyRepoAndGoToChosenVersion opts repodir rfsource-getCmd _ _ = fail "You must provide 'get' with either one or two arguments."---- | called by getCmd--- assumes that the target repo of the get is the current directory, and that an inventory in the--- right format has already been created.-copyRepoAndGoToChosenVersion :: [DarcsFlag] -> String -> RepoFormat -> IO ()-copyRepoAndGoToChosenVersion opts repodir rfsource = do- copyRepo- withRepository opts ((RepoJob $ \repository -> goToChosenVersion repository opts) :: RepoJob ())- putInfo opts $ text "Finished getting."- where copyRepo :: IO ()- copyRepo =- withRepository opts $ RepoJob $ \repository ->- if formatHas HashedInventory rfsource- then do- debugMessage "Identifying and copying repository..."- copyRepoHashed repository- else do- putInfo opts $ text "***********************************************************************"- $$ text " _______ Sorry for the wait! The repository you are fetching is"- $$ text " | | using the DEPRECATED 'old-fashioned' format. I'm getting a"- $$ text " | O O | hashed copy instead, but this may take a while."- $$ text " | ___ |"- $$ text " | / \\ | We recommend that the maintainer upgrade the remote copy"- $$ text " |_______| as well. See http://wiki.darcs.net/OF for more information."- $$ text ""- $$ text "***********************************************************************"- copyRepoHashed repository- copyRepoHashed repository =- do identifyRepositoryFor repository repodir >>= flip copyRepository (UseNoWorkingDir `notElem` opts)- when (SetScriptsExecutable `elem` opts) setScriptsExecutable--makeRepoName :: [DarcsFlag] -> FilePath -> IO String-makeRepoName (NewRepo n:_) _ =- do exists <- doesDirectoryExist n- file_exists <- doesFileExist n- if exists || file_exists- then fail $ "Directory or file named '" ++ n ++ "' already exists."- else return n-makeRepoName (_:as) d = makeRepoName as d-makeRepoName [] d =- case dropWhile (=='.') $ reverse $- takeWhile (\c -> c /= '/' && c /= ':') $- dropWhile (=='/') $ reverse d of- "" -> modifyRepoName "anonymous_repo"- base -> modifyRepoName base--modifyRepoName :: String -> IO String-modifyRepoName name =- if head name == '/'- then mrn name (-1)- else do cwd <- getCurrentDirectory- mrn (cwd ++ "/" ++ name) (-1)- where- mrn :: String -> Int -> IO String- mrn n i = do- exists <- doesDirectoryExist thename- file_exists <- doesFileExist thename- if not exists && not file_exists- then do when (i /= -1) $- putStrLn $ "Directory '"++ n ++- "' already exists, creating repository as '"++- thename ++"'"- return thename- else mrn n $ i+1- where thename = if i == -1 then n else n++"_"++show i--getHelpTag :: String-getHelpTag =- "It is often desirable to make a copy of a repository that excludes\n" ++- "some patches. For example, if releases are tagged then `darcs get\n" ++- "--tag .' would make a copy of the repository as at the latest release.\n" ++- "\n" ++- "An untagged repository state can still be identified unambiguously by\n" ++- "a context file, as generated by `darcs changes --context'. Given the\n" ++- "name of such a file, the --context option will create a repository\n" ++- "that includes only the patches from that context. When a user reports\n" ++- "a bug in an unreleased version of your project, the recommended way to\n" ++- "find out exactly what version they were running is to have them\n" ++- "include a context file in the bug report.\n" ++- "\n" ++- "You can also make a copy of an untagged state using the --to-patch or\n" ++- "--to-match options, which exclude patches `after' the first matching\n" ++- "patch. Because these options treat the set of patches as an ordered\n" ++- "sequence, you may get different results after reordering with `darcs\n" ++- "optimize', so tagging is preferred.\n"--contextExists :: [DarcsFlag] -> IO (Either String ())-contextExists opts =- case getContext opts of- Nothing -> return $ Right ()- Just f -> do exists <- doesFileExist $ toFilePath f- return $ if exists- then Right ()- else Left $ "Context file "++toFilePath f++" does not exist"--goToChosenVersion :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)- => Repository p C(r u r)- -> [DarcsFlag] -> IO ()-goToChosenVersion repository opts =- when (havePatchsetMatch opts) $ do- debugMessage "Going to specified version..."- patches <- readRepo repository- Sealed context <- getOnePatchset repository opts- when (snd (countUsThem patches context) > 0) $- errorDoc $ text "Missing patches from context!" -- FIXME : - (- _ :> us' <- return $ findCommonWithThem patches context- let ps = mapFL_FL hopefully us'- putInfo opts $ text $ "Unapplying " ++ show (lengthFL ps) ++ " " ++- englishNum (lengthFL ps) (Noun "patch") ""- invalidateIndex repository- withRepoLock opts $ RepoJob $ \_ ->--- Warning: A do-notation statement discarded a result of type Repository p r u z.- do _ <- tentativelyRemovePatches repository (compression opts) us'- tentativelyAddToPending repository opts $ invert $ effect us'- finalizeRepositoryChanges repository- apply (invert $ effect ps) `catch` \(e :: IOException) ->- fail ("Couldn't undo patch in working dir.\n" ++ show e)- makeScriptsExecutable opts (invert $ effect ps)-
− src/Darcs/Commands/Help.hs
@@ -1,295 +0,0 @@--- Copyright (C) 2002-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Commands.Help (- helpCmd,- commandControlList, environmentHelp, -- these are for preproc.hs- printVersion,- listAvailableCommands ) where--import Darcs.Arguments ( DarcsFlag(..), environmentHelpEmail, environmentHelpSendmail )-import Darcs.Commands (- CommandArgs(..), CommandControl(..), DarcsCommand(..),- disambiguateCommands, extractCommands, getCommandHelp, nodefaults, usage )-import Darcs.External ( viewDoc )-import Darcs.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir )-import Darcs.Patch.Match ( helpOnMatchers )-import Darcs.Repository.Prefs ( boringFileHelp, binariesFileHelp, environmentHelpHome )-import Darcs.Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort )-import Darcs.Utils ( withCurrentDirectory, environmentHelpEditor, environmentHelpPager )-import Data.Char ( isAlphaNum, toLower, toUpper )-import Data.List ( groupBy, isPrefixOf, intercalate, nub )-import English ( andClauses )-import Printer (text, vcat, vsep, ($$))-import System.Exit ( ExitCode(..), exitWith )-import Version ( version )-import URL (environmentHelpProxy, environmentHelpProxyPassword)-import Workaround ( getCurrentDirectory )-import qualified Darcs.TheCommands as TheCommands--helpDescription :: String-helpDescription = "Display help about darcs and darcs commands."--helpHelp :: String-helpHelp =- "Without arguments, `darcs help' prints a categorized list of darcs\n" ++- "commands and a short description of each one. With an extra argument,\n" ++- "`darcs help foo' prints detailed help about the darcs command foo.\n"--help :: DarcsCommand-help = DarcsCommand {commandProgramName = "darcs",- commandName = "help",- commandHelp = helpHelp,- commandDescription = helpDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["[<DARCS_COMMAND> [DARCS_SUBCOMMAND]] "],- commandCommand = \ x y -> helpCmd x y >> exitWith ExitSuccess,- commandPrereq = \_ -> return $ Right (),- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = []}--helpCmd :: [DarcsFlag] -> [String] -> IO ()-helpCmd _ ["manpage"] = putStr $ unlines manpageLines-helpCmd _ ["patterns"] = viewDoc $ text $ helpOnMatchers-helpCmd _ ("environment":vs_) =- viewDoc . vsep $- if null vs- then header : map render environmentHelp- else map render known ++ [footer]- where header = vcat [ text "Environment Variables"- , text "====================="- ]- footer = text ("Unknown environment variables: " ++ intercalate ", " unknown)- render (ks, ds) = text (andClauses ks ++ ":") $$- vcat [text (" " ++ d) | d <- ds]- lookupEnv v = [ e | e@(ks,_) <- environmentHelp, v `elem` ks ]- unknown = [ v | v <- vs, null (lookupEnv v) ]- known = nub (concatMap lookupEnv vs)- vs = map (map toUpper) vs_--helpCmd _ [] = viewDoc $ text $ usage commandControlList--helpCmd _ (cmd:args) =- let disambiguated = disambiguateCommands commandControlList cmd args- in case disambiguated of- Left err -> fail err- Right (cmds,_) ->- let msg = case cmds of- CommandOnly c -> getCommandHelp Nothing c- SuperCommandOnly c -> getCommandHelp Nothing c- SuperCommandSub c s -> getCommandHelp (Just c) s- in viewDoc $ text msg--listAvailableCommands :: IO ()-listAvailableCommands =- do here <- getCurrentDirectory- is_valid <- mapM- (\c-> withCurrentDirectory here $ (commandPrereq c) [])- (extractCommands commandControlList)- putStr $ unlines $ map (commandName . fst) $- filter (isRight.snd) $- zip (extractCommands commandControlList) is_valid- putStrLn "--help"- putStrLn "--version"- putStrLn "--exact-version"- putStrLn "--overview"- where isRight (Right _) = True- isRight _ = False--printVersion :: IO ()-printVersion = putStrLn $ "darcs version " ++ version---- avoiding a module import cycle between Help and TheCommands-commandControlList :: [CommandControl]-commandControlList =- CommandData help : TheCommands.commandControlList---- FIXME: the "grouping" comments below should made subsections in the--- manpage, as we already do for DarcsCommand groups. --twb, 2009---- | Help on each environment variable in which Darcs is interested.-environmentHelp :: [([String], [String])]-environmentHelp = [- -- General-purpose- environmentHelpHome,- environmentHelpEditor,- environmentHelpPager,- environmentHelpTmpdir,- environmentHelpKeepTmpdir,- environmentHelpEmail,- environmentHelpSendmail,- -- Remote Repositories- environmentHelpSsh,- environmentHelpScp,- environmentHelpSshPort,- environmentHelpProxy,- environmentHelpProxyPassword]---- | This module is responsible for emitting a darcs "man-page", a--- reference document used widely on Unix-like systems. Manpages are--- primarily used as a quick reference, or "memory jogger", so the--- output should be terser than the user manual.------ Before modifying the output, please be sure to read the man(7) and--- man-pages(7) manpages, as these respectively describe the relevant--- syntax and conventions.---- | The lines of the manpage to be printed.-manpageLines :: [String]-manpageLines = [- ".TH DARCS 1 \"" ++ version ++ "\"",- ".SH NAME",- "darcs \\- an advanced revision control system",- ".SH SYNOPSIS",- ".B darcs", ".I command", ".RI < arguments |[ options ]>...",- "",- "Where the", ".I commands", "and their respective", ".I arguments", "are",- "",- unlines synopsis,- ".SH DESCRIPTION",- -- FIXME: this is copy-and-pasted from darcs.cabal, so- -- it'll get out of date as people forget to maintain- -- both in sync.- "Darcs is a free, open source revision control",- "system. It is:",- ".TP 3", "\\(bu",- "Distributed: Every user has access to the full",- "command set, removing boundaries between server and",- "client or committer and non\\(hycommitters.",- ".TP", "\\(bu",- "Interactive: Darcs is easy to learn and efficient to",- "use because it asks you questions in response to",- "simple commands, giving you choices in your work",- "flow. You can choose to record one change in a file,",- "while ignoring another. As you update from upstream,",- "you can review each patch name, even the full `diff'",- "for interesting patches.",- ".TP", "\\(bu",- "Smart: Originally developed by physicist David",- "Roundy, darcs is based on a unique algebra of",- "patches.",- "This smartness lets you respond to changing demands",- "in ways that would otherwise not be possible. Learn",- "more about spontaneous branches with darcs.",- ".SH OPTIONS",- "Different options are accepted by different Darcs commands.",- "Each command's most important options are listed in the",- ".B COMMANDS",- "section. For a full list of all options accepted by",- "a particular command, run `darcs", ".I command", "\\-\\-help'.",- ".SS " ++ escape helpOnMatchers, -- FIXME: this is a kludge.- ".SH COMMANDS",- unlines commands,- unlines environment,- ".SH FILES",- ".SS \"_darcs/prefs/binaries\"",- escape $ unlines binariesFileHelp,- ".SS \"_darcs/prefs/boring\"",- escape $ unlines boringFileHelp,- ".SH BUGS",- "At http://bugs.darcs.net/ you can find a list of known",- "bugs in Darcs. Unknown bugs can be reported at that",- "site (after creating an account) or by emailing the",- "report to bugs@darcs.net.",- -- ".SH EXAMPLE",- -- FIXME:- -- new project: init, rec -la;- -- track upstream project: get, pull -a;- -- contribute to project: add, rec, push/send.- ".SH SEE ALSO",- "A user manual is included with Darcs, in PDF and HTML",- "form. It can also be found at http://darcs.net/manual/.",- ".SH LICENSE",- "Darcs is free software; you can redistribute it and/or modify",- "it under the terms of the GNU General Public License as published by",- "the Free Software Foundation; either version 2, or (at your option)",- "any later version." ]- where- -- | A synopsis line for each command. Uses 'foldl' because it is- -- necessary to avoid blank lines from Hidden_commands, as groff- -- translates them into annoying vertical padding (unlike TeX).- synopsis :: [String]- synopsis = foldl iter [] commandControlList- where iter :: [String] -> CommandControl -> [String]- iter acc (GroupName _) = acc- iter acc (HiddenCommand _) = acc- iter acc (CommandData c@SuperCommand {}) =- acc ++ concatMap- (render (commandName c ++ " "))- (extractCommands (commandSubCommands c))- iter acc (CommandData c) = acc ++ render "" c- render :: String -> DarcsCommand -> [String]- render prefix c =- [".B darcs " ++ prefix ++ commandName c] ++- (map mangle_args $ commandExtraArgHelp c) ++- -- In the output, we want each command to be on its own- -- line, but we don't want blank lines between them.- -- AFAICT this can only be achieved with the .br- -- directive, which is probably a GNUism.- [".br"]-- -- | As 'synopsis', but make each group a subsection (.SS), and- -- include the help text for each command.- commands :: [String]- commands = foldl iter [] commandControlList- where iter :: [String] -> CommandControl -> [String]- iter acc (GroupName x) = acc ++ [".SS \"" ++ x ++ "\""]- iter acc (HiddenCommand _) = acc- iter acc (CommandData c@SuperCommand {}) =- acc ++ concatMap- (render (commandName c ++ " "))- (extractCommands (commandSubCommands c))- iter acc (CommandData c) = acc ++ render "" c- render :: String -> DarcsCommand -> [String]- render prefix c =- [".B darcs " ++ prefix ++ commandName c] ++- (map mangle_args $ commandExtraArgHelp c) ++- [".RS 4", escape $ commandHelp c, ".RE"]-- -- | Now I'm showing off: mangle the extra arguments of Darcs commands- -- so as to use the ideal format for manpages, italic words and roman- -- punctuation.- mangle_args :: String -> String- mangle_args s =- ".RI " ++ (unwords $ map show (groupBy cmp $ map toLower $ gank s))- where cmp x y = not $ xor (isAlphaNum x) (isAlphaNum y)- xor x y = (x && not y) || (y && not x)- gank (' ':'o':'r':' ':xs) = '|' : gank xs- gank (x:xs) = x : gank xs- gank [] = []-- environment :: [String]- environment = ".SH ENVIRONMENT" : concat- [(".SS \"" ++ andClauses ks ++ "\"") : map escape ds- | (ks, ds) <- environmentHelp]-- -- | Copied from Preproc.escape_latex_specials.- escape :: String -> String- escape = minus . bs -- Order is important- where- minus = replace "-" "\\-"- bs = replace "\\" "\\\\"-- replace :: Eq a => [a] -> [a] -> [a] -> [a]- replace _ _ [] = []- replace find repl s =- if find `isPrefixOf` s- then repl ++ (replace find repl (drop (length find) s))- else [head s] ++ replace find repl (tail s)-
− src/Darcs/Commands/Init.hs
@@ -1,63 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Commands.Init ( initialize, initializeCmd ) where-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, workingRepoDir,- patchFormatChoices, useWorkingDir )-import Darcs.Repository ( amNotInRepository, createRepository )--initializeDescription :: String-initializeDescription = "Make the current directory a repository."--initializeHelp :: String-initializeHelp =- "The `darcs initialize' command turns the current directory into a\n" ++- "Darcs repository. Any existing files and subdirectories become\n" ++- "UNSAVED changes: record them with `darcs record --look-for-adds'.\n" ++- "\n" ++- "This command creates the `_darcs' directory, which stores version\n" ++- "control metadata. It also contains per-repository settings in\n" ++- "_darcs/prefs/, which you can read about in the user manual.\n" ++- "\n" ++- "By default, patches of the new repository are in the darcs-2 semantics.\n" ++- "However it is possible to create a repository in darcs-1 semantics with\n" ++- "the flag `--hashed', althought this is not recommended except for sharing\n" ++- "patches with a project that uses patches in the darcs-1 semantics.\n" ++- "\n" ++- "Initialize is commonly abbreviated to `init'.\n"--initialize :: DarcsCommand-initialize = DarcsCommand {commandProgramName = "darcs",- commandName = "initialize",- commandHelp = initializeHelp,- commandDescription = initializeDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandPrereq = amNotInRepository,- commandCommand = initializeCmd,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],-- commandBasicOptions = [patchFormatChoices,- useWorkingDir,- workingRepoDir]}--initializeCmd :: [DarcsFlag] -> [String] -> IO ()-initializeCmd opts _ = createRepository opts-
− src/Darcs/Commands/MarkConflicts.hs
@@ -1,113 +0,0 @@--- Copyright (C) 2002-2003,2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# 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 )-import Darcs.Flags ( diffingOpts )-import Darcs.Repository ( withRepoLock, RepoJob(..), amInHashedRepository, addToPending,- applyToWorking,- readRepo, unrecordedChanges, Repository- )-import Darcs.Patch ( invert, PrimOf )-import Darcs.Witnesses.Ordered ( FL(..) )-import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-import Darcs.Resolution ( patchsetConflictResolutions )-import Darcs.Utils ( promptYorn )-#include "impossible.h"-#include "gadts.h"--markconflictsDescription :: String-markconflictsDescription =- "Mark unresolved conflicts in working tree, for manual resolution."--markconflictsHelp :: String-markconflictsHelp =- "Darcs requires human guidance to unify changes to the same part of a\n" ++- "source file. When a conflict first occurs, darcs will add the\n" ++- "initial state and both choices to the working tree, delimited by the\n" ++- "markers `v v v', `=====', `* * *' and `^ ^ ^', as follows:\n" ++- "\n" ++- "v v v v v v v\n" ++- "Initial state.\n" ++- "=============\n" ++- "First choice.\n" ++- "*************\n" ++- "Second choice.\n" ++- "^ ^ ^ ^ ^ ^ ^\n" ++- "\n" ++- "However, you might revert or manually delete these markers without\n" ++- "actually resolving the conflict. In this case, `darcs mark-conflicts'\n" ++- "is useful to show where any unresolved conflicts. It is also useful\n" ++- "if `darcs apply' is called with --apply-conflicts, where conflicts\n" ++- "aren't marked initially.\n" ++- "\n" ++- "Any unrecorded changes to the working tree WILL be lost forever when\n" ++- "you run this command! You will be prompted for confirmation before\n" ++- "this takes place.\n"--markconflicts :: DarcsCommand-markconflicts = DarcsCommand {commandProgramName = "darcs",- commandName = "mark-conflicts",- commandHelp = markconflictsHelp,- commandDescription = markconflictsDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = markconflictsCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [umaskOption],- commandBasicOptions = [ignoretimes,- workingRepoDir]}--markconflictsCmd :: [DarcsFlag] -> [String] -> IO ()-markconflictsCmd opts [] = withRepoLock opts $ RepoJob $ \(repository :: Repository p C(r u r)) -> do- pend <- unrecordedChanges (diffingOpts opts) repository Nothing- r <- readRepo repository- Sealed res <- return $ patchsetConflictResolutions r- (case res of NilFL -> do putStrLn "No conflicts to mark."- exitWith ExitSuccess- _ -> return ()) :: IO ()- let undoUnrec :: FL (PrimOf p) C(r u) -> IO (Repository p C(r r r))- undoUnrec NilFL = return repository- undoUnrec pend' =- do putStrLn ("This will trash any unrecorded changes"++- " in the working directory.")- confirmed <- promptYorn "Are you sure? "- unless confirmed $ exitWith ExitSuccess- 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 :: IOException) ->- bug ("Problem marking conflicts in mark-conflicts!" ++ show e)- return ()- putStrLn "Finished marking conflicts."-markconflictsCmd _ _ = impossible-
− src/Darcs/Commands/Move.hs
@@ -1,260 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Move ( move, mv ) where-import Control.Applicative ( (<$>) )-import Control.Monad ( when, unless, zipWithM_ )-import Data.Maybe ( catMaybes )-import Darcs.SignalHandler ( withSignalsBlocked )--import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )-import Darcs.Arguments ( DarcsFlag(), maybeFixSubPaths,- fixSubPaths, workingRepoDir,- listFiles, allowProblematicFilenames, umaskOption,- )-import Darcs.Flags ( doAllowCaseOnly, doAllowWindowsReserved )-import Darcs.RepoPath ( SubPath(), toFilePath )-import System.FilePath.Posix ( (</>), takeFileName )-import System.Directory ( renameDirectory )-import Workaround ( renameFile )-import Darcs.Repository.State ( readRecordedAndPending, readRecorded )-import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), amInHashedRepository, addToPending )-import Darcs.Witnesses.Ordered ( FL(..), toFL )-import Darcs.Witnesses.Sealed ( Sealed(..), unseal, freeGap, FreeLeft, unFreeLeft )-import Darcs.Global ( debugMessage )-import qualified Darcs.Patch-import Darcs.Patch ( RepoPatch, PrimPatch )-import Darcs.Patch.FileName ( fp2fn, fn2fp, superName )-import Darcs.Patch.Apply( ApplyState )-import Data.List ( nub, sort )-import qualified System.FilePath.Windows as WindowsFilePath--import Darcs.Utils( treeHas, treeHasDir, treeHasAnycase, treeHasFile )-import Storage.Hashed.Tree( Tree, modifyTree )-import Storage.Hashed.Plain( readPlainTree )-import Storage.Hashed.AnchoredPath( floatPath )--#include "gadts.h"--moveDescription :: String-moveDescription = "Move or rename files."--moveHelp :: String-moveHelp =- "Darcs cannot reliably distinguish between a file being deleted and a\n" ++- "new one added, and a file being moved. Therefore Darcs always assumes\n" ++- "the former, and provides the `darcs mv' command to let Darcs know when\n" ++- "you want the latter. This command will also move the file in the\n" ++- "working tree (unlike `darcs remove'), unless it has already been moved.\n" ++- "\n" ++- -- Note that this paragraph is very similar to one in ./Add.lhs.- "Darcs will not rename a file if another file in the same folder has\n" ++- "the same name, except for case. The --case-ok option overrides this\n" ++- "behaviour. Windows and OS X usually use filesystems that do not allow\n" ++- "files a folder to have the same name except for case (for example,\n" ++- "`ReadMe' and `README'). If --case-ok is used, the repository might be\n" ++- "unusable on those systems!\n"--move :: DarcsCommand-move = DarcsCommand {commandProgramName = "darcs",- commandName = "move",- commandHelp = moveHelp,- commandDescription = moveDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["<SOURCE> ... <DESTINATION>"],- commandCommand = moveCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = listFiles,- commandArgdefaults = nodefaults,- commandAdvancedOptions = [umaskOption],- commandBasicOptions = [allowProblematicFilenames, workingRepoDir]}--moveCmd :: [DarcsFlag] -> [String] -> IO ()-moveCmd opts args- | length args < 2 =- fail $ "The `darcs move' command requires at least two arguments."- | length args == 2 = do- xs <- maybeFixSubPaths opts args- case xs of- [Just from, Just to]- | from == to -> fail "Cannot rename a file or directory onto itself!"- | toFilePath from == "" -> fail "Cannot move the root of the repository"- | otherwise -> moveFile opts from to- _ -> fail "Both source and destination must be valid."- | otherwise = let (froms, to) = (init args, last args) in do- x <- head <$> maybeFixSubPaths opts [to]- case x of- Nothing -> fail "Invalid destination directory."- Just to' -> do- xs <- nub . sort <$> fixSubPaths opts froms- if to' `elem` xs- then fail "Cannot rename a file or directory onto itself!"- else case xs of- [] -> fail "Nothing to move."- froms' -> moveFilesToDir opts froms' to'--data FileKind = Dir | File- deriving (Show, Eq)--data FileStatus =- Nonexistant- | Unadded FileKind- | Shadow FileKind -- ^ known to darcs, but absent in working copy- | Known FileKind- deriving Show--fileStatus :: Tree IO -> Tree IO -> Tree IO ->- FilePath -> IO FileStatus-fileStatus work cur rec fp = do- exists_in_cur <- treeHas cur fp- exists_in_rec <- treeHas rec fp- exists_in_work <- treeHas work fp- case (exists_in_rec, exists_in_cur, exists_in_work) of- (_, True, True) -> do- isDirCur <- treeHasDir cur fp- isDirWork <- treeHasDir work fp- unless (isDirCur == isDirWork) . fail $ "don't know what to do with " ++ fp- return . Known $ if isDirCur then Dir else File-- (_, False, True) -> do- isDir <- treeHasDir work fp- if isDir- then return $ Unadded Dir- else return $ Unadded File- (False, False, False) -> return Nonexistant- (_, _, False) -> do- isDir <- treeHasDir cur fp- if isDir- then return $ Shadow Dir- else return $ Shadow File---- | Takes two filenames (as 'Subpath'), and tries to move the first--- into/onto the second. Needs to guess what that means: renaming or moving--- into a directory, and whether it is a post-hoc move.-moveFile :: [DarcsFlag] -> SubPath -> SubPath -> IO ()-moveFile opts old new = withRepoLock opts $ RepoJob $ \repository -> do- work <- readPlainTree "."- cur <- readRecordedAndPending repository- rec <- readRecorded repository- let old_fp = toFilePath old- new_fp = toFilePath new- new_fs <- fileStatus work cur rec new_fp- old_fs <- fileStatus work cur rec old_fp- case (old_fs, new_fs) of- (Nonexistant, _) -> fail $ old_fp ++ " is inexistant."- (Unadded k, _) -> fail $ show k ++ " " ++ old_fp ++ " is unadded."- (Known _, Nonexistant) -> simpleMove repository opts cur work old_fp new_fp- (Known _, Shadow _) -> simpleMove repository opts cur work old_fp new_fp- (_, Nonexistant) -> fail $ old_fp ++ " is not in the repository."- (Known _, Known Dir) -> moveToDir repository opts [old_fp] new_fp- (Known _, Unadded Dir) -> fail $ new_fp ++ " is not known to darcs; please add it to the repository."- (Known _, _) -> fail $ new_fp ++ " already exists."- (Shadow k, Unadded k') | k == k' -> simpleMove repository opts cur work old_fp new_fp- (Shadow _, Known Dir) -> moveToDir repository opts [old_fp] new_fp- (Shadow k, _) -> fail $ "cannot move " ++ show k ++ " " ++ old_fp ++ " into " ++ new_fp ++ " : " ++- "did you already move it elsewhere?"--simpleMove :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t)- -> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath- -> IO ()-simpleMove repository opts cur work old_fp new_fp = do- addpatch <- checkNewAndOldFilenames opts cur work (old_fp,new_fp)- withSignalsBlocked $ do- case unFreeLeft <$> addpatch of- Nothing -> addToPending repository (Darcs.Patch.move old_fp new_fp :>: NilFL)- Just (Sealed p) -> addToPending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL)- moveFileOrDir work old_fp new_fp--moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO ()-moveFilesToDir opts froms to = withRepoLock opts $ RepoJob $ \repo ->- moveToDir repo opts (map toFilePath froms) $ toFilePath to--moveToDir :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> [DarcsFlag] -> [FilePath] -> FilePath -> IO ()-moveToDir repository opts moved finaldir =- let movefns = map takeFileName moved- movetargets = map (finaldir </>) movefns- movepatches = zipWith (\a b -> freeGap (Darcs.Patch.move a b)) moved movetargets- in do- cur <- readRecordedAndPending repository- work <- readPlainTree "."- addpatches <- mapM (checkNewAndOldFilenames opts cur work) $ zip moved movetargets- withSignalsBlocked $ do- unseal (addToPending repository) $ toFL $ catMaybes addpatches ++ movepatches- zipWithM_ (moveFileOrDir work) moved movetargets--checkNewAndOldFilenames- :: PrimPatch prim => [DarcsFlag] -> Tree IO -> Tree IO -> (FilePath, FilePath) -> IO (Maybe (FreeLeft prim))-checkNewAndOldFilenames opts cur work (old,new) = do- unless (doAllowWindowsReserved opts || WindowsFilePath.isValid new) $- fail $ "The filename " ++ new ++ " is not valid under Windows.\n" ++- "Use --reserved-ok to allow such filenames."- has_work <- treeHas work old- maybe_add_file_thats_been_moved <-- if has_work -- We need to move the object- then do has_target <- treeHasDir work (fn2fp $ superName $ fp2fn new)- unless has_target $- fail $ "The target directory " ++- (fn2fp $ superName $ fp2fn new)++- " isn't known in working directory, did you forget to add it?"- has_new <- it_has work- when has_new $ fail $ already_exists "working directory"- return Nothing- else do- has_new <- treeHas work new- has_cur_dir <- treeHasDir cur old- unless has_new $ fail $ doesnt_exist "working directory"- let add_patch = if has_cur_dir- then Darcs.Patch.adddir old- else Darcs.Patch.addfile old- return (Just (freeGap (add_patch)))- has_target <- treeHasDir cur (fn2fp $ superName $ fp2fn new)- unless has_target $- fail $ "The target directory " ++- (fn2fp $ superName $ fp2fn new)++- " isn't known in working directory, did you forget to add it?"- has_new <- it_has cur- when has_new $ fail $ already_exists "repository"- return maybe_add_file_thats_been_moved- where it_has s = treeHas_case (modifyTree s (floatPath old) Nothing) new- treeHas_case = if doAllowCaseOnly opts then treeHas else treeHasAnycase- already_exists what_slurpy =- if doAllowCaseOnly opts- then "A file or dir named "++new++" already exists in "- ++ what_slurpy ++ "."- else "A file or dir named "++new++" (or perhaps differing"++- " only in case)\nalready exists in "++- what_slurpy ++ ".\n"++- "Use --case-ok to allow files differing only in case."- doesnt_exist what_slurpy =- "There is no file or dir named " ++ old ++- " in the "++ what_slurpy ++ "."--moveFileOrDir :: Tree IO -> FilePath -> FilePath -> IO ()-moveFileOrDir work old new = do- has_file <- treeHasFile work old- has_dir <- treeHasDir work old- when has_file $ do debugMessage $ unwords ["renameFile",old,new]- renameFile old new- when has_dir $ do debugMessage $ unwords ["renameDirectory",old,new]- renameDirectory old new--mv :: DarcsCommand-mv = commandAlias "mv" Nothing move-
− src/Darcs/Commands/Optimize.hs
@@ -1,372 +0,0 @@--- Copyright (C) 2003-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Optimize ( optimize ) where-import Control.Applicative ( (<$>) )-import Control.Exception ( finally )-import Control.Monad ( when, unless )-import Data.Maybe ( isJust )-import Data.List ( sort )-import System.Directory ( getDirectoryContents, doesDirectoryExist,- doesFileExist, renameFile, getModificationTime )-import System.IO.Unsafe ( unsafeInterleaveIO )-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy as BL--import Storage.Hashed.Darcs( decodeDarcsSize )--import Darcs.Patch.PatchInfoAnd ( info, extractHash )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag( UpgradeFormat, UseHashedInventory,- Compress, UnCompress,- NoCompress, Reorder,- Relink, OptimizePristine,- OptimizeHTTP ),- reorderPatches,- uncompressNocompress,- relink, sibling,- flagsToSiblings,- upgradeFormat,- workingRepoDir, umaskOption, optimizePristine,- optimizeHTTP- )-import Darcs.Repository.Prefs ( getPreflist )-import Darcs.Repository ( Repository,- withRepoLock, RepoJob(..), withGutsOf,- readRepo, optimizeInventory,- tentativelyReplacePatches, cleanRepository,- amInRepository, finalizeRepositoryChanges, replacePristine )-import Darcs.Repository.Old ( oldRepoFailMsg )-import Darcs.Witnesses.Ordered ( (+<+), reverseRL, mapRL, (:>)(..)- , mapFL, bunchFL, lengthRL )-import Darcs.Patch.Info ( isTag )-import Darcs.Patch ( RepoPatch )-import Darcs.Patch.Set ( PatchSet(..), newset2RL, newset2FL, progressPatchSet )-import Darcs.Patch.Apply( ApplyState )-import ByteStringUtils ( gzReadFilePS )-import Darcs.Patch.Depends ( splitOnTag )-import Darcs.Lock ( maybeRelink, gzWriteAtomicFilePS, writeAtomicFilePS )-import Darcs.RepoPath ( toFilePath )-import Darcs.Utils ( withCurrentDirectory )-import Progress ( debugMessage )-import Darcs.Global ( darcsdir )---- imports for optimize --upgrade; to be tidied-import System.Directory ( createDirectoryIfMissing, removeFile )-import System.FilePath.Posix ( takeExtension, (</>), (<.>), takeFileName )--import Progress ( beginTedious, endTedious, tediousSize )-import Darcs.Flags ( compression )-import Darcs.Lock ( rmRecursive )-import Darcs.ProgressPatches ( progressFL )-import Darcs.Repository.Cache ( hashedDir, HashedDir(HashedPristineDir) )-import Darcs.Repository.Format ( identifyRepoFormat,- createRepoFormat, writeRepoFormat, formatHas,- RepoProperty ( HashedInventory ) )-import qualified Darcs.Repository.HashedRepo as HashedRepo-import Darcs.Repository.Prefs ( getCaches )-import Darcs.Repository.State ( readRecorded )-import Darcs.Utils ( catchall )--import Storage.Hashed.Tree( Tree, TreeItem(..), list, expand, emptyTree )-import Storage.Hashed.AnchoredPath( anchorPath )-import Storage.Hashed.Plain( readPlainTree )-import Storage.Hashed.Darcs( writeDarcsHashed )--import Codec.Archive.Tar ( write )-import Codec.Archive.Tar.Entry ( fileEntry, toTarPath )-import Codec.Compression.GZip ( compress )--#include "gadts.h"--optimizeDescription :: String-optimizeDescription = "Optimize the repository."--optimizeHelp :: String-optimizeHelp =- "The `darcs optimize' command modifies the current repository in an\n" ++- "attempt to reduce its resource requirements. By default a single\n" ++- "fast, safe optimization is performed; additional optimization\n" ++- "techniques can be enabled by passing options to `darcs optimize'.\n" ++- "\n" ++ optimizeHelpInventory ++- -- "\n" ++ optimize_help_reorder ++- "\n" ++ optimizeHelpRelink ++- -- uncompression is least useful, so it is last.- "\n" ++ optimizeHelpCompression ++- "\n" ++- "There is one more optimization which CAN NOT be performed by this\n" ++- "command. Every time your record a patch, a new inventory file is\n" ++- "written to _darcs/inventories/, and old inventories are never reaped.\n" ++- "\n" ++- "If _darcs/inventories/ is consuming a relatively large amount of\n" ++- "space, you can safely reclaim it by using `darcs get' to make a\n" ++- "complete copy of the repo. When doing so, don't forget to copy over\n" ++- "any unsaved changes you have made to the working tree or to\n" ++- "unversioned files in _darcs/prefs/ (such as _darcs/prefs/author).\n"--optimize :: DarcsCommand-optimize = DarcsCommand {commandProgramName = "darcs",- commandName = "optimize",- commandHelp = optimizeHelp,- commandDescription = optimizeDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = optimizeCmd,- commandPrereq = amInRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [uncompressNocompress, umaskOption],- commandBasicOptions = [workingRepoDir,- reorderPatches,- sibling, relink,- upgradeFormat,- optimizePristine,- optimizeHTTP]}--optimizeCmd :: [DarcsFlag] -> [String] -> IO ()-optimizeCmd origopts _ = do- when (UpgradeFormat `elem` origopts) optimizeUpgradeFormat- withRepoLock opts $ RepoJob $ \repository -> do- cleanRepository repository -- garbage collect pristine.hashed directory- when (OptimizeHTTP `elem` origopts) $ doOptimizeHTTP repository- if (OptimizePristine `elem` opts)- then doOptimizePristine repository- else do when (Reorder `elem` opts) $ doReorder opts repository- doOptimizeInventory repository- when (Compress `elem` opts || UnCompress `elem` opts) $- optimizeCompression opts- when (Relink `elem` opts) $- doRelink opts- putStrLn "Done optimizing!"- where opts = if UnCompress `elem` origopts then NoCompress:origopts else origopts--optimizeHelpInventory :: String-optimizeHelpInventory =- "The default optimization moves recent patches (those not included in\n" ++- "the latest tag) to the `front', reducing the amount that a typical\n" ++- "remote command needs to download. It should also reduce the CPU time\n" ++- "needed for some operations.\n"--doOptimizeInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-doOptimizeInventory repository = do- debugMessage "Writing out a nice copy of the inventory."- optimizeInventory repository- debugMessage "Done writing out a nice copy of the inventory."--optimizeHelpCompression :: String-optimizeHelpCompression =- "By default patches are compressed with zlib (RFC 1951) to reduce\n" ++- "storage (and download) size. In exceptional circumstances, it may be\n" ++- "preferable to avoid compression. In this case the `--dont-compress'\n" ++- "option can be used (e.g. with `darcs record') to avoid compression.\n" ++- "\n" ++- "The `darcs optimize --uncompress' and `darcs optimize --compress'\n" ++- "commands can be used to ensure existing patches in the current\n" ++- "repository are respectively uncompressed or compressed. Note that\n" ++- "repositories in the legacy `old-fashioned-inventory' format have a .gz\n" ++- "extension on patch files even when uncompressed.\n"--optimizeCompression :: [DarcsFlag] -> IO ()-optimizeCompression opts = do- putStrLn "Optimizing (un)compression of patches..."- do_compress (darcsdir++"/patches")- putStrLn "Optimizing (un)compression of inventories..."- do_compress (darcsdir++"/inventories")- where do_compress f =- do isd <- doesDirectoryExist f- if isd then withCurrentDirectory f $- do fs <- filter notdot `fmap` getDirectoryContents "."- mapM_ do_compress fs- else if Compress `elem` opts- then gzReadFilePS f >>= gzWriteAtomicFilePS f- else gzReadFilePS f >>= writeAtomicFilePS f- notdot ('.':_) = False- notdot _ = True--optimizeHelpRelink :: String-optimizeHelpRelink =- "The `darcs optimize --relink' command hard-links patches that the\n" ++- "current repository has in common with its peers. Peers are those\n" ++- "repositories listed in _darcs/prefs/sources, or defined with the\n" ++- "`--sibling' option (which can be used multiple times).\n" ++- "\n" ++- "Darcs uses hard-links automatically, so this command is rarely needed.\n" ++- "It is most useful if you used `cp -r' instead of `darcs get' to copy a\n" ++- "repository, or if you pulled the same patch from a remote repository\n" ++- "into multiple local repositories.\n"--doOptimizePristine :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-doOptimizePristine repo = do- hashed <- doesFileExist $ darcsdir </> "hashed_inventory"- when hashed $ do- inv <- BS.readFile (darcsdir </> "hashed_inventory")- let linesInv = BS.split '\n' inv- case linesInv of- [] -> return ()- (pris_line:_) ->- let size = decodeDarcsSize $ BS.drop 9 pris_line- in when (isJust size) $ do putStrLn "Optimizing hashed pristine..."- readRecorded repo >>= replacePristine repo- cleanRepository repo--doRelink :: [DarcsFlag] -> IO ()-doRelink opts =- do some_siblings <- return (flagsToSiblings opts)- defrepolist <- getPreflist "defaultrepo"- siblings <- return (map toFilePath some_siblings ++ defrepolist)- if null siblings- then putStrLn "No siblings -- no relinking done."- else do debugMessage "Relinking patches..."- patch_tree <- expand =<< readPlainTree "_darcs/patches"- let patches = [ anchorPath "" p | (p, File _) <- list patch_tree ]- maybeRelinkFiles siblings patches "_darcs/patches"- debugMessage "Done relinking."--maybeRelinkFiles :: [String] -> [String] -> String -> IO ()-maybeRelinkFiles src dst dir =- mapM_ (maybeRelinkFile src) (map ((dir ++ "/") ++) dst)--maybeRelinkFile :: [String] -> String -> IO ()-maybeRelinkFile [] _ = return ()-maybeRelinkFile (h:t) f =- do done <- maybeRelink (h ++ "/" ++ f) f- unless done $- maybeRelinkFile t f---- FIXME: someone needs to grovel through the source and determine--- just how optimizeInventory differs from doReorder. The following--- is purely speculation. --twb, 2009-04--- optimize_help_reorder :: String--- optimize_help_reorder =--- "The `darcs optimize --reorder' command is a more comprehensive version\n" ++--- "of the default optimization. It reorders patches with respect to ALL\n" ++--- "tags, rather than just the latest tag.\n"--doReorder :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository p C(r u r) -> IO ()-doReorder opts repository = do- debugMessage "Reordering the inventory."- PatchSet ps _ <- chooseOrder `fmap` readRepo repository--- Warning: A do-notation statement discarded a result of type Repository p r u r.- withGutsOf repository $ do _ <- tentativelyReplacePatches repository (compression opts) $ reverseRL ps- finalizeRepositoryChanges repository- debugMessage "Done reordering the inventory."--chooseOrder :: forall p C(s x) . RepoPatch p => PatchSet p C(s x) -> PatchSet p C(s x)-chooseOrder ps = case filter isTag $ mapRL info $ newset2RL ps of- [] -> ps- (lt:_) -> case splitOnTag lt ps of- PatchSet xs ts :> r -> PatchSet (r+<+xs) ts--optimizeUpgradeFormat :: IO ()-optimizeUpgradeFormat = do- debugMessage $ "Upgrading to hashed..."- rf <- identifyRepoFormat "."- debugMessage $ "Found our format"- if formatHas HashedInventory rf- then putStrLn "No action taken because this repository already is hashed."- else do putStrLn "Checking repository in case of corruption..."- withRepoLock [] $ RepoJob $ \repository -> do- actuallyUpgradeFormat repository--actuallyUpgradeFormat :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-actuallyUpgradeFormat repository = do- -- convert patches/inventory- patches <- readRepo repository- let k = "Hashing patch"- beginTedious k- tediousSize k (lengthRL $ newset2RL patches)- let patches' = progressPatchSet k patches- cache <- getCaches [] "."- let compr = compression [] -- default compression- HashedRepo.writeTentativeInventory cache compr patches'- endTedious k- -- convert pristine by applying patches- -- the faster alternative would be to copy pristine, but the apply method is more reliable- let patchesToApply = progressFL "Applying patch" $ newset2FL $ patches'- createDirectoryIfMissing False $ darcsdir </> hashedDir HashedPristineDir--- Warning: A do-notation statement discarded a result of type Storage.Hashed.Hash.Hash.- _ <- writeDarcsHashed emptyTree "_darcs/pristine.hashed"- sequence_ $ mapFL HashedRepo.applyToTentativePristine $ bunchFL 100 patchesToApply- -- now make it official- HashedRepo.finalizeTentativeChanges repository compr- writeRepoFormat (createRepoFormat [UseHashedInventory]) (darcsdir </> "format")- -- clean out old-fashioned junk- debugMessage "Cleaning out old-fashioned repository files..."- removeFile $ darcsdir </> "inventory"- removeFile $ darcsdir </> "tentative_inventory"- rmRecursive (darcsdir </> "pristine") `catchall` rmRecursive (darcsdir </> "current")- rmGzsIn (darcsdir </> "patches")- rmGzsIn (darcsdir </> "inventories")- let checkpointDir = darcsdir </> "checkpoints"- hasCheckPoints <- doesDirectoryExist checkpointDir- when hasCheckPoints $ rmRecursive checkpointDir- putStrLn "Done upgrading!"- where- rmGzsIn dir =- withCurrentDirectory dir $ do- gzs <- filter ((== ".gz") . takeExtension) `fmap` getDirectoryContents "."- mapM_ removeFile gzs--doOptimizeHTTP :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-doOptimizeHTTP repo = flip finally (mapM_ (removeFileIfExists)- [ darcsdir </> "meta-filelist-inventories"- , darcsdir </> "meta-filelist-pristine"- , basicTar <.> "part"- , patchesTar <.> "part"- ]) $ do- rf <- identifyRepoFormat "."- unless (formatHas HashedInventory rf) $ fail oldRepoFailMsg- createDirectoryIfMissing False packsDir- -- pack patchesTar- ps <- mapRL hashedPatchFileName . newset2RL <$> readRepo repo- is <- map ((darcsdir </> "inventories") </>) <$> HashedRepo.listInventories- writeFile (darcsdir </> "meta-filelist-inventories") . unlines $- map takeFileName is- BL.writeFile (patchesTar <.> "part") . compress . write =<<- mapM fileEntry' ((darcsdir </> "meta-filelist-inventories") : ps ++- reverse is)- renameFile (patchesTar <.> "part") patchesTar- -- pack basicTar- pr <- sortByMTime =<< dirContents "pristine.hashed"- writeFile (darcsdir </> "meta-filelist-pristine") . unlines $- map takeFileName pr- BL.writeFile (basicTar <.> "part") . compress . write =<< mapM fileEntry' (- [ darcsdir </> "meta-filelist-pristine"- , darcsdir </> "hashed_inventory"- ] ++ reverse pr)- renameFile (basicTar <.> "part") basicTar- where- packsDir = darcsdir </> "packs"- basicTar = packsDir </> "basic.tar.gz"- patchesTar = packsDir </> "patches.tar.gz"- fileEntry' x = unsafeInterleaveIO $ do- content <- BL.fromChunks . return <$> gzReadFilePS x- tp <- either fail return $ toTarPath False x- return $ fileEntry tp content- dirContents d = dirContents' d $ const True- dirContents' d f = map ((darcsdir </> d) </>) . filter (\x ->- head x /= '.' && f x) <$> getDirectoryContents (darcsdir </> d)- hashedPatchFileName x = case extractHash x of- Left _ -> fail "unexpected unhashed patch"- Right h -> darcsdir </> "patches" </> h- sortByMTime xs = map snd . sort <$> mapM (\x -> (\t -> (t, x)) <$>- getModificationTime x) xs- removeFileIfExists x = do- ex <- doesFileExist x- when ex $ removeFile x
− src/Darcs/Commands/Pull.hs
@@ -1,361 +0,0 @@--- Copyright (C) 2002-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Pull ( pull, fetch ) where-import System.Exit ( ExitCode(..), exitWith )-import Workaround ( getCurrentDirectory )-import Control.Monad ( when )-import Data.List ( nub )-import Data.Maybe ( fromMaybe )--import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo )-import Darcs.CommandsAux ( checkPaths )-import Darcs.Arguments- ( DarcsFlag- ( AllowConflicts- , Complement- , DryRun- , Intersection- , MarkConflicts- , NoAllowConflicts- , Verbose- , XMLOutput- )- , allInteractive- , allowUnrelatedRepos- , changesReverse- , depsSel- , dryRun- , fixUrl- , getOutput- , ignoretimes- , makeScriptsExecutable- , matchSeveral- , networkOptions- , nocompress- , output- , pauseForGui- , printDryRunMessageAndExit- , pullConflictOptions- , remoteRepo- , repoCombinator- , restrictPaths- , setDefault- , setEnvDarcsPatches- , setScriptsExecutableOption- , summary- , test- , umaskOption- , useExternalMerge- , workingRepoDir- )-import Darcs.Flags( doReverse, isInteractive )-import Darcs.Repository ( Repository, identifyRepositoryFor, withGutsOf,- amInHashedRepository, withRepoLock, RepoJob(..),- finalizeRepositoryChanges, applyToWorking,- testTentative,- readRepo, checkUnrelatedRepos, invalidateIndex, modifyCache, modifyCache, Cache(..), CacheLoc(..), WritableOrNot(..))-import qualified Darcs.Repository.Cache as DarcsCache-import Darcs.Repository.Merge ( tentativelyMergePatches )-import Darcs.Patch.PatchInfoAnd ( info, hopefully, patchDesc )-import Darcs.Patch ( RepoPatch, description, PrimOf )-import Darcs.Patch.Bundle( makeBundleN, patchFilename )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet )-import Darcs.Witnesses.Unsafe ( unsafeCoercePEnd )-import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), FL(..), RL(..)- , mapFL, nullFL, reverseFL, mapFL_FL )-import Darcs.Patch.Permutations ( partitionFL )-import Darcs.Repository.Prefs ( addToPreflist, defaultrepo, setDefaultrepo, getPreflist )-import Darcs.Repository.Motd (showMotd )-import Darcs.Patch.Depends ( findUncommon, findCommonWithThem,- newsetIntersection, newsetUnion )-import Darcs.SelectChanges ( selectChanges,- WhichChanges(..),- filterOutConflicts,- runSelection, selectionContext)-import Darcs.Utils ( clarifyErrors, formatPath,- PromptConfig(..), promptChar )-import Darcs.Witnesses.Sealed ( Sealed(..), seal )-import Printer ( putDocLn, vcat, ($$), text, putDoc )-import Darcs.Lock ( writeDocBinFile )-import Darcs.RepoPath ( useAbsoluteOrStd, stdOut )-import Storage.Hashed.Tree( Tree )-#include "impossible.h"--#include "gadts.h"--pullDescription :: String-pullDescription =- "Copy and apply patches from another repository to this one."--fetchDescription :: String-fetchDescription =- "Fetch patches from another repository, but don't apply them."--pullHelp :: String-pullHelp =- "Pull is used to bring changes made in another repository into the current\n"++- "repository (that is, either the one in the current directory, or the one\n"++- "specified with the --repodir option). Pull allows you to bring over all or\n"++- "some of the patches that are in that repository but not in this one. Pull\n"++- "accepts arguments, which are URLs from which to pull, and when called\n"++- "without an argument, pull will use the repository from which you have most\n"++- "recently either pushed or pulled.\n" ++- "\n" ++- "See 'darcs help apply' for detailed description of many options.\n"--fetchHelp :: String-fetchHelp =- "fetch is used to bring changes made in another repository\n" ++- "into the current repository without actually applying\n"++- "them. Fetch allows you to bring over all or\n"++- "some of the patches that are in that repository but not in this one. Fetch\n"++- "accepts arguments, which are URLs from which to fetch, and when called\n"++- "without an argument, fetch will use the repository from which you have most\n"++- "recently either pushed or pulled.\n"++- "The fetched patches are stored into a patch bundle, to be later\n" ++- "applied using \"darcs apply\"."---fetch :: DarcsCommand-fetch = DarcsCommand {- commandProgramName = "darcs",- commandName = "fetch",- commandHelp = fetchHelp,- commandDescription = fetchDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["[REPOSITORY]..."],- commandCommand = fetchCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = getPreflist "repos",- commandArgdefaults = defaultrepo,- commandAdvancedOptions =- [ repoCombinator- , remoteRepo- ] ++ networkOptions,- commandBasicOptions = [matchSeveral,- allInteractive]- ++dryRun++- [summary,- depsSel,- setDefault False,- workingRepoDir,- output,- allowUnrelatedRepos]}--pull :: DarcsCommand-pull = DarcsCommand {commandProgramName = "darcs",- commandName = "pull",- commandHelp = pullHelp,- commandDescription = pullDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["[REPOSITORY]..."],- commandCommand = pullCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = getPreflist "repos",- commandArgdefaults = defaultrepo,- commandAdvancedOptions =- [ repoCombinator- , nocompress- , ignoretimes- , remoteRepo- , setScriptsExecutableOption- , umaskOption- , restrictPaths- , changesReverse- , pauseForGui- ] ++ networkOptions,- commandBasicOptions = [matchSeveral,- allInteractive,- pullConflictOptions,- useExternalMerge,- test]++dryRun++[summary,- depsSel,- setDefault False,- workingRepoDir,- allowUnrelatedRepos]}--mergeOpts :: [DarcsFlag] -> [DarcsFlag]-mergeOpts opts | NoAllowConflicts `elem` opts = opts- | AllowConflicts `elem` opts = opts- | otherwise = MarkConflicts : opts--pullCmd :: [DarcsFlag] -> [String] -> IO ()-pullCmd opts repos =- do- pullingFrom <- mapM (fixUrl opts) repos- withRepoLock opts $ RepoJob $ \ initRepo -> do- let repository = modifyCache initRepo $ addReposToCache pullingFrom- r <- fetchPatches opts' repos "pull" repository- applyPatches opts' repository r- where- opts' = mergeOpts opts- addReposToCache repos' (Ca cache) = Ca $ [ toReadOnlyCache r | r <- repos' ] ++ cache- toReadOnlyCache = Cache DarcsCache.Repo NotWritable---fetchCmd :: [DarcsFlag] -> [String] -> IO ()-fetchCmd opts repos =- withRepoLock opts $ RepoJob $ \ repository ->- fetchPatches opts repos "fetch" repository- >>= makeBundle opts--fetchPatches :: FORALL(p r u) (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> [String] -> String- -> Repository p C(r u r)- -> IO (SealedPatchSet p C(Origin),- Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(r)))-fetchPatches opts unfixedrepodirs@(_:_) jobname repository = do- here <- getCurrentDirectory- repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl opts) unfixedrepodirs- -- Test to make sure we aren't trying to pull from the current repo- when (null repodirs) $- fail "Can't pull from current repository!"- old_default <- getPreflist "defaultrepo"- when (old_default == repodirs && not (XMLOutput `elem` opts)) $- let pulling = if DryRun `elem` opts then "Would pull" else "Pulling"- in putInfo opts $ text $ pulling++" from "++concatMap formatPath repodirs++"..."- (Sealed them, Sealed compl) <- readRepos repository opts repodirs- setDefaultrepo (head repodirs) opts- mapM_ (addToPreflist "repos") repodirs- mapM_ (showMotd opts) repodirs- us <- readRepo repository- checkUnrelatedRepos opts us them-- common :> _ <- return $ findCommonWithThem us them- us' :\/: them' <- return $ findUncommon us them- _ :\/: compl' <- return $ findUncommon us compl-- let avoided = mapFL info compl'- ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) them'- when (Verbose `elem` opts) $- do case us' of- (x@(_:>:_)) -> putDocLn $ text "We have the following new (to them) patches:"- $$ (vcat $ mapFL description x)- _ -> return ()- when (not $ nullFL ps) $ putDocLn $ text "They have the following patches to pull:"- $$ (vcat $ mapFL description ps)- (hadConflicts, Sealed psFiltered) <- filterOutConflicts opts (reverseFL us') repository ps- when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."- when (nullFL psFiltered) $ do putInfo opts $ text "No remote changes to pull in!"- setEnvDarcsPatches psFiltered- exitWith ExitSuccess- let context = selectionContext jobname opts Nothing Nothing- selector = if doReverse opts- then selectChanges FirstReversed- else selectChanges First- (to_be_pulled :> _) <- runSelection (selector psFiltered) $ context- return (seal common, seal $ us' :\/: to_be_pulled)--fetchPatches _ [] jobname _ = fail $ "No default repository to " ++ jobname ++- " from, please specify one"--applyPatches :: forall p C(r u). (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)- => [DarcsFlag] -> Repository p C(r u r)- -> (SealedPatchSet p C(Origin),- Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(r)))- -> IO ()-applyPatches opts repository (_, Sealed (us' :\/: to_be_pulled)) =- do- printDryRunMessageAndExit "pull" opts to_be_pulled- setEnvDarcsPatches to_be_pulled- when (nullFL to_be_pulled) $ do- putStrLn "You don't want to pull any patches, and that's fine with me!"- exitWith ExitSuccess- checkPaths opts to_be_pulled- putVerbose opts $ text "Getting and merging the following patches:"- putVerbose opts $ vcat $ mapFL description to_be_pulled- Sealed pw <- tentativelyMergePatches repository "pull" opts us' to_be_pulled- invalidateIndex repository- rc <- testTentative repository- when (rc /= ExitSuccess) $ do- when (not $ isInteractive opts) $ exitWith rc- putStrLn $ "Looks like those patches do not pass the tests."- let prompt = "Shall I apply them anyway?"- yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])- case yn of- 'y' -> return ()- _ -> exitWith rc- withGutsOf repository $ do finalizeRepositoryChanges repository- _ <- revertable $ applyToWorking repository opts pw- makeScriptsExecutable opts pw- return ()- putInfo opts $ text "Finished pulling and applying."--makeBundle :: forall p C(r) . (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag]- -> (SealedPatchSet p C(Origin),- Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(r)))- -> IO ()-makeBundle opts (Sealed common, Sealed (_ :\/: to_be_fetched)) =- do- bundle <- makeBundleN Nothing (unsafeCoercePEnd common) $- mapFL_FL hopefully to_be_fetched- let fname = case to_be_fetched of- (x:>:_)-> patchFilename $ patchDesc x- _ -> impossible- o = fromMaybe stdOut (getOutput opts fname)- useAbsoluteOrStd writeDocBinFile putDoc o $ bundle--revertable :: IO a -> IO a-revertable x =- x `clarifyErrors` unlines- ["Error applying patch to the working directory.","",- "This may have left your working directory an inconsistent",- "but recoverable state. If you had no un-recorded changes",- "by using 'darcs revert' you should be able to make your",- "working directory consistent again."]--{- Read in the specified pull-from repositories. Perform-Intersection, Union, or Complement read. In patch-theory terms-(stated in set algebra, where + is union and & is intersection-and \ is complement):-- Union = ((R1 + R2 + ... + Rn) \ Rc)- Intersection = ((R1 & R2 & ... & Rn) \ Rc)- Complement = (R1 \ Rc) \ ((R2 + R3 + ... + Rn) \ Rc)-- where Rc = local repo- R1 = 1st specified pull repo- R2, R3, Rn = other specified pull repo--Since Rc is not provided here yet, the result of readRepos is a-tuple: the first patchset(s) to be complemented against Rc and then-the second patchset(s) to be complemented against Rc.--}--readRepos :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> [DarcsFlag] -> [String]- -> IO (SealedPatchSet p C(Origin),SealedPatchSet p C(Origin))-readRepos _ _ [] = impossible-readRepos to_repo opts us =- do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo u- ps <- readRepo r- return $ seal ps) us- return $ if Intersection `elem` opts- then (newsetIntersection rs, seal (PatchSet NilRL NilRL))- else if Complement `elem` opts- then (head rs, newsetUnion $ tail rs)- else (newsetUnion rs, seal (PatchSet NilRL NilRL))-
− src/Darcs/Commands/Push.hs
@@ -1,197 +0,0 @@--- Copyright (C) 2002-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, TypeOperators #-}--module Darcs.Commands.Push ( push ) where-import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ) )-import Control.Monad ( when )-import Data.Char ( toUpper )-import Workaround ( getCurrentDirectory )-import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo, abortRun )-import Darcs.Arguments ( DarcsFlag( DryRun, Sign, SignAs, NoSign, SignSSL ),- setEnvDarcsPatches,- workingRepoDir, summary,- printDryRunMessageAndExit,- applyas, matchSeveral, fixUrl, depsSel,- allInteractive, dryRun,- remoteRepo, networkOptions,- setDefault, sign, allowUnrelatedRepos,- changesReverse- )--import Darcs.Flags(doReverse)-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )-import Darcs.Repository ( Repository, withRepoReadLock, RepoJob(..), identifyRepositoryFor,- readRepo, amInHashedRepository, checkUnrelatedRepos )-import Darcs.Patch ( RepoPatch, description )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Witnesses.Ordered ( (:>)(..), RL, FL, nullRL,- nullFL, reverseFL, mapFL_FL, mapRL )-import Darcs.Repository.Prefs ( defaultrepo, setDefaultrepo, getPreflist )-import Darcs.External ( maybeURLCmd, signString )-import Darcs.URL ( isHttpUrl, isFile )-import Darcs.SelectChanges ( selectChanges, WhichChanges(..),- selectionContext, runSelection )-import Darcs.Utils ( formatPath )-import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )-import Darcs.Patch.Bundle ( makeBundleN )-import Darcs.Patch.Patchy( ShowPatch )-import Darcs.Patch.Set ( PatchSet )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Printer ( Doc, vcat, empty, text, ($$) )-import Darcs.RemoteApply ( remoteApply, applyAs )-import Darcs.Email ( makeEmail )-import English (englishNum, Noun(..))-import Storage.Hashed.Tree( Tree )-#include "impossible.h"--#include "gadts.h"--pushDescription :: String-pushDescription =- "Copy and apply patches from this repository to another one."--pushHelp :: String-pushHelp =- "Push is the opposite of pull. Push allows you to copy changes from the\n"++- "current repository into another repository.\n"--push :: DarcsCommand-push = DarcsCommand {commandProgramName = "darcs",- commandName = "push",- commandHelp = pushHelp,- commandDescription = pushDescription,- commandExtraArgs = 1,- commandExtraArgHelp = ["[REPOSITORY]"],- commandCommand = pushCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = getPreflist "repos",- commandArgdefaults = defaultrepo,- commandAdvancedOptions = [applyas,- remoteRepo,- changesReverse] ++- networkOptions,- commandBasicOptions = [matchSeveral, depsSel,- allInteractive,- sign]++dryRun++[summary,- workingRepoDir,- setDefault False,- allowUnrelatedRepos]}--pushCmd :: [DarcsFlag] -> [String] -> IO ()-pushCmd _ [""] = impossible-pushCmd opts [unfixedrepodir] =- do- repodir <- fixUrl opts unfixedrepodir- -- Test to make sure we aren't trying to push to the current repo- here <- getCurrentDirectory- checkOptionsSanity opts repodir- when (repodir == here) $- fail "Cannot push from repository to itself."- -- absolute '.' also taken into account by fix_filepath- (bundle) <- withRepoReadLock opts $ RepoJob $- prepareBundle opts repodir- sbundle <- signString opts bundle- let body = if isFile repodir- then sbundle- else makeEmail repodir [] Nothing Nothing sbundle Nothing- rval <- remoteApply opts repodir body- case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"- exitWith (ExitFailure ec)- ExitSuccess -> putInfo opts $ text "Push successful."-pushCmd _ _ = impossible--prepareBundle :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> String -> Repository p C(r u t) -> IO (Doc)-prepareBundle opts repodir repository = do- old_default <- getPreflist "defaultrepo"- when (old_default == [repodir]) $- let pushing = if DryRun `elem` opts then "Would push" else "Pushing"- in putInfo opts $ text $ pushing++" to "++formatPath repodir++"..."- them <- identifyRepositoryFor repository repodir >>= readRepo- setDefaultrepo repodir opts- us <- readRepo repository- common :> us' <- return $ findCommonWithThem us them- prePushChatter opts us (reverseFL us') them- let context = selectionContext "push" opts Nothing Nothing- selector = if doReverse opts- then selectChanges FirstReversed- else selectChanges First- runSelection (selector us') context- >>= bundlePatches opts common--prePushChatter :: forall p a C(x y t) . (RepoPatch p, ShowPatch a) =>- [DarcsFlag] -> PatchSet p C(Origin x) ->- RL a C(t x) -> PatchSet p C(Origin y) -> IO ()-prePushChatter opts us us' them = do- checkUnrelatedRepos opts us them- let num_to_pull = snd $ countUsThem us them- pull_reminder = if num_to_pull > 0- then text $ "The remote repository has " ++ show num_to_pull- ++ " " ++ englishNum num_to_pull (Noun "patch") " to pull."- else empty- putVerbose opts $ text "We have the following patches to push:" $$ (vcat $ mapRL description us')- when (not $ nullRL us') $ do putInfo opts $ pull_reminder- when (nullRL us') $ do putInfo opts $ text "No recorded local changes to push!"- exitWith ExitSuccess--bundlePatches :: forall t p C(z w a). (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> PatchSet p C(a z)- -> (FL (PatchInfoAnd p) :> t) C(z w)- -> IO (Doc)-bundlePatches opts common (to_be_pushed :> _) =- do- setEnvDarcsPatches to_be_pushed- printDryRunMessageAndExit "push" opts to_be_pushed- when (nullFL to_be_pushed) $ do- putInfo opts $- text "You don't want to push any patches, and that's fine with me!"- exitWith ExitSuccess- bundle <- makeBundleN Nothing- common (mapFL_FL hopefully to_be_pushed)- return (bundle)--wantSign :: [DarcsFlag] -> Bool-wantSign opts = case opts of- [] -> False- Sign:_ -> True- (SignAs _):_ -> True- (SignSSL _):_ -> True- NoSign:_ -> False- _:opts' -> wantSign opts'---checkOptionsSanity :: [DarcsFlag] -> String -> IO ()-checkOptionsSanity opts repodir =- if isHttpUrl repodir then do- when (applyAs opts /= Nothing) $- abortRun opts $ text "Cannot --apply-as when pushing to URLs"- maybeapply <- maybeURLCmd "APPLY" repodir- when (maybeapply == Nothing) $- let lprot = takeWhile (/= ':') repodir- prot = map toUpper lprot- msg = text ("Pushing to "++lprot++" URLs is not supported.\n"++- "You may be able to hack this to work"++- " using DARCS_APPLY_"++prot) in- abortRun opts msg- else do- when (wantSign opts) $- abortRun opts $ text "Signing doesn't make sense for local repositories or when pushing over ssh."-
− src/Darcs/Commands/Put.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE CPP #-}--module Darcs.Commands.Put ( put ) where-import System.Exit ( ExitCode( ExitSuccess, ExitFailure ), exitWith )-import Control.Monad ( when )-import Data.Maybe ( mapMaybe )-import System.Directory ( createDirectory )-import Darcs.Commands ( DarcsCommand(..), nodefaults, putVerbose, putInfo )-import Darcs.Arguments ( DarcsFlag( UseFormat2, UseHashedInventory ),- applyas, matchOneContext, fixUrl,- networkOptions, flagToString,- setScriptsExecutableOption, workingRepoDir, setDefault- )-import Darcs.Repository ( withRepoReadLock, RepoJob(..), patchSetToPatches, readRepo, amInHashedRepository )-import Darcs.Repository.Format ( identifyRepoFormat,- RepoProperty ( Darcs2 ), formatHas )-import Darcs.Patch.Bundle ( makeBundle2 )-import Darcs.Patch.Set ( PatchSet )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Witnesses.Eq ( EqCheck(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( RL(..), nullFL )-import Darcs.Match ( havePatchsetMatch, getOnePatchset )-import Darcs.Repository.Prefs ( getPreflist, setDefaultrepo )-import Darcs.URL ( isHttpUrl, isFile, splitSshUrl, SshFilePath(..) )-import Darcs.Utils ( withCurrentDirectory )-import Progress ( debugMessage )-import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )-import Darcs.External ( execSSH )-import Darcs.RemoteApply ( remoteApply )-import Darcs.Commands.Init ( initialize )-import Darcs.Email ( makeEmail )-import Darcs.Witnesses.Sealed ( Sealed(..), seal )-import Printer ( text )-#include "impossible.h"-#include "gadts.h"--putDescription :: String-putDescription =- "Makes a copy of the repository"--putHelp :: String-putHelp =- "The `darcs put' command creates a copy of the current repository. It\n" ++- "is currently very inefficient, so when creating local copies you\n" ++- "should use `darcs get . x' instead of `darcs put x'.\n" ++- "\n" ++- "Currently this command just uses `darcs init' to create the target\n" ++- "repository, then `darcs push --all' to copy patches to it. Options\n" ++- "passed to `darcs put' are passed to the init and/or push commands as\n" ++- "appropriate. See those commands for an explanation of each option.\n"--put ::DarcsCommand-put = DarcsCommand {commandProgramName = "darcs",- commandName = "put",- commandHelp = putHelp,- commandDescription = putDescription,- commandExtraArgs = 1,- commandExtraArgHelp = ["<NEW REPOSITORY>"],- commandCommand = putCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = getPreflist "repos",- commandArgdefaults = nodefaults,- commandAdvancedOptions = [applyas] ++ networkOptions,- commandBasicOptions = [matchOneContext, setScriptsExecutableOption,- setDefault False, workingRepoDir]}--putCmd :: [DarcsFlag] -> [String] -> IO ()-putCmd _ [""] = fail "Empty repository argument given to put."-putCmd opts [unfixedrepodir] =- do- repodir <- fixUrl opts unfixedrepodir- -- Test to make sure we aren't trying to push to the current repo- t_cur_absolute_repo_dir <- ioAbsoluteOrRemote "."- t_req_absolute_repo_dir <- ioAbsoluteOrRemote repodir- let cur_absolute_repo_dir = toPath t_cur_absolute_repo_dir- req_absolute_repo_dir = toPath t_req_absolute_repo_dir- when (cur_absolute_repo_dir == req_absolute_repo_dir) $- fail "Can't put to current repository!"- when (isHttpUrl req_absolute_repo_dir) $ error "Can't put to a URL!"-- debugMessage "Creating repository"- putVerbose opts $ text "Creating repository"- rf <- identifyRepoFormat "."- let initopts = if formatHas Darcs2 rf- then UseFormat2:opts- else UseHashedInventory:filter (/= UseFormat2) opts- if isFile req_absolute_repo_dir- then do createDirectory req_absolute_repo_dir- withCurrentDirectory req_absolute_repo_dir $ (commandCommand initialize) initopts []- else do -- isSshUrl req_absolute_repo_dir- remoteInit (splitSshUrl req_absolute_repo_dir) initopts-- withCurrentDirectory cur_absolute_repo_dir $- withRepoReadLock opts $ RepoJob $ \repository -> (do- setDefaultrepo req_absolute_repo_dir opts- let doRead = if havePatchsetMatch opts- then getOnePatchset repository opts -- todo: make sure getOnePatchset has the right type- else readRepo repository >>= (return . seal)- Sealed (patchset :: PatchSet p C(Origin x1)) <- doRead- Sealed (patchset2 :: PatchSet p C(Origin x2)) <- doRead- IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck C(x1 x2))- let patches = patchSetToPatches patchset- patches2 = patchSetToPatches patchset2- when (nullFL patches) $ do- putInfo opts $ text "No patches were selected to put. Nothing to be done."- exitWith ExitSuccess- bundle <- makeBundle2 Nothing NilRL patches patches2- let message = if isFile req_absolute_repo_dir- then bundle- else makeEmail req_absolute_repo_dir [] Nothing Nothing bundle Nothing- putVerbose opts $ text "Applying patches in new repository..."- rval <- remoteApply opts req_absolute_repo_dir message- case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"- exitWith (ExitFailure ec)- ExitSuccess -> putInfo opts $ text "Put successful.") :: IO ()-putCmd _ _ = impossible--remoteInit :: SshFilePath -> [DarcsFlag] -> IO ()-remoteInit repo opts = do- let args = mapMaybe (flagToString $ commandBasicOptions initialize) opts- command = "darcs initialize --repodir='" ++ (sshRepo repo) ++ "' " ++ unwords args- exitCode <- execSSH repo command- when (exitCode /= ExitSuccess) $- fail "Couldn't initialize remote repository."
− src/Darcs/Commands/Record.hs
@@ -1,430 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, PatternGuards #-}--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, catch, IOException )-import Control.Monad ( when, unless )-import System.IO ( stdin )-import Data.List ( sort, isPrefixOf, union )-import Data.Char ( ord )-import System.Exit ( exitWith, exitFailure, ExitCode(..) )-import System.Directory ( removeFile )-import Data.Maybe ( isJust, catMaybes )-import qualified Data.ByteString as B ( hPut )--import Darcs.Lock ( readLocaleFile, writeLocaleFile, worldReadableTemp, appendToFile )-import Darcs.Patch.PatchInfoAnd ( info, n2pia, PatchInfoAnd )-import Darcs.Repository ( Repository, amInHashedRepository, withRepoLock, RepoJob(..),- withGutsOf,- readTentativeRepo,- tentativelyAddPatch, finalizeRepositoryChanges- , testTentative- , invalidateIndex, unrecordedChanges, readRecorded )-import Darcs.Patch ( RepoPatch, Patchy, PrimOf, PrimPatch, namepatch, summaryFL, anonymous,- adddeps, fromPrims )-import Darcs.Patch.Set ( PatchSet(..) )-import Darcs.Witnesses.Eq ( unsafeCompare )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+),- reverseRL, mapFL, mapFL_FL, nullFL )-import Darcs.Witnesses.Sealed-import Darcs.Patch.Info ( PatchInfo )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Split ( primSplitter )-import Darcs.Patch.Choices ( patchChoicesTps, tpPatch,- forceFirsts, getChoices, tag )-import Darcs.SelectChanges ( selectChanges, WhichChanges(..),- selectionContext, selectionContextPrim,- runSelection- )-import Darcs.RepoPath ( FilePathLike, SubPath, toFilePath )-import Darcs.Commands ( DarcsCommand(..), nodefaults, commandStub )-import Darcs.Commands.Util ( announceFiles, filterExistingFiles )-import Darcs.Arguments ( DarcsFlag( PromptLongComment, NoEditLongComment,- EditLongComment, LogFile, Pipe, Quiet,- PatchName, AskDeps, All ),- fileHelpAuthor,- getAuthor, workingRepoDir, lookforadds,- fixSubPaths, setEnvDarcsFiles,- askLongComment, askdeps, patchSelectFlag,- allPipeInteractive, leaveTestDir, test,- author, patchnameOption, umaskOption, ignoretimes,- nocompress, rmlogfile, logfile, listRegisteredFiles,- setScriptsExecutableOption- , unified )-import Darcs.Flags (willRemoveLogFile, diffingOpts, compression, isInteractive)-import Darcs.Utils ( askUser, promptYorn, PromptConfig(..), promptChar, editFile, clarifyErrors )-import Progress ( debugMessage)-import Darcs.ProgressPatches( progressFL)-import IsoDate ( getIsoDateTime, cleanLocalDate )-import Printer ( hPutDocLn, text, wrapText, ($$) )-import ByteStringUtils ( encodeLocale )-import Storage.Hashed.Tree( Tree )--#include "impossible.h"-#include "gadts.h"--recordDescription :: String-recordDescription = "Create a patch from unrecorded changes."--recordHelp :: String-recordHelp =- "The `darcs record' command is used to create a patch from changes in\n" ++- "the working tree. If you specify a set of files and directories,\n" ++- "changes to other files will be skipped.\n" ++- "\n" ++ recordHelp' ++- "\n" ++ recordHelp''--record :: DarcsCommand-record = DarcsCommand {commandProgramName = "darcs",- commandName = "record",- commandHelp = recordHelp,- commandDescription = recordDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["[FILE or DIRECTORY]..."],- commandCommand = recordCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = listRegisteredFiles,- commandArgdefaults = nodefaults,- commandAdvancedOptions = [logfile, rmlogfile,- nocompress, ignoretimes,- umaskOption,- setScriptsExecutableOption],- commandBasicOptions = [patchnameOption, author,- test,- leaveTestDir,- allPipeInteractive,- askdeps,- askLongComment,- lookforadds,- workingRepoDir, unified]}--commitDescription :: String-commitDescription = "Redirect the user to record, push or send."--commitHelp :: String-commitHelp =- "This command does not do anything.\n"++- "If you want to save changes locally, use the `darcs record' command.\n"++- "If you want to save a recorded patch to another repository, use the\n"++- "`darcs push' or `darcs send' commands instead.\n"--commit :: DarcsCommand-commit = commandStub "commit" commitHelp commitDescription record--recordCmd :: [DarcsFlag] -> [String] -> IO ()-recordCmd opts args = do- checkNameIsNotOption opts- withRepoLock opts $ RepoJob $ \repository -> do- files <- if null args then return Nothing- else Just . sort <$> fixSubPaths opts args- when (files == Just []) $ fail "No valid arguments were given."- announceFiles files "Recording changes in"- existing_files <- maybe (return Nothing)- (fmap Just . filterExistingFiles repository) files- when (existing_files == Just []) $- fail "None of the files you specified exist!"- debugMessage "About to get the unrecorded changes."- changes <- unrecordedChanges (diffingOpts opts) repository files- debugMessage "I've gotten unrecorded."- case allow_empty_with_askdeps changes of--- Warning: A do-notation statement discarded a result of type String.- Nothing -> do when (Pipe `elem` opts) $ do _ <- getDate opts- return ()- putStrLn "No changes!"- exitFailure- Just ch -> doRecord repository opts existing_files ch- where allow_empty_with_askdeps :: FL p C(x y) -> Maybe (FL p C(x y))- allow_empty_with_askdeps NilFL- | AskDeps `elem` opts = Just NilFL- | otherwise = Nothing- allow_empty_with_askdeps p = Just p-- -- check that what we treat as the patch name is not accidentally a command- -- line flag-checkNameIsNotOption :: [DarcsFlag] -> IO ()-checkNameIsNotOption opts = do- let patchNames = [n | PatchName n <- opts]- when (length patchNames == 1) $ do- let n = head patchNames- oneLetterName = length n == 1 || (length n == 2 && head n == '-')- if (oneLetterName && (All `notElem` opts))- then do confirmed <- promptYorn $ "You specified " ++ show n ++ " as the patch name. Is that really what you want?"- unless confirmed $ do putStrLn "Okay, aborting the record."- exitFailure- else return ()---doRecord :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)- => Repository p C(r u r) -> [DarcsFlag] -> Maybe [SubPath] -> FL (PrimOf p) C(r x) -> IO ()-doRecord repository opts files ps = do- let make_log = worldReadableTemp "darcs-record"- date <- getDate opts- my_author <- getAuthor opts- debugMessage "I'm slurping the repository."- debugMessage "About to select changes..."- pristine <- readRecorded repository- (chs :> _ ) <- runSelection (selectChanges First ps) $- selectionContextPrim "record" opts (Just primSplitter)- (map toFilePath <$> files)- (Just pristine)- when (is_empty_but_not_askdeps chs) $- do putStrLn "Ok, if you don't want to record anything, that's fine!"- exitWith ExitSuccess- handleJust onlySuccessfulExits (\_ -> return ()) $- do deps <- if AskDeps `elem` opts- then askAboutDepends repository chs opts []- else return []- when (AskDeps `elem` opts) $ debugMessage "I've asked about dependencies."- if nullFL chs && null deps- then putStrLn "Ok, if you don't want to record anything, that's fine!"- else do setEnvDarcsFiles chs- (name, my_log, logf) <- getLog opts Nothing make_log chs- debugMessage ("Patch name as received from getLog: " ++ show (map ord name))- doActualRecord repository opts name date- my_author my_log logf deps chs- where is_empty_but_not_askdeps l- | AskDeps `elem` opts = False- -- a "partial tag" patch; see below.- | otherwise = nullFL l--doActualRecord :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u r) -> [DarcsFlag] -> String -> String -> String- -> [String] -> Maybe String- -> [PatchInfo] -> FL (PrimOf p) C(r x) -> IO ()-doActualRecord repository opts name date my_author my_log logf deps chs =- do debugMessage "Writing the patch file..."- mypatch <- namepatch date name my_author my_log $- fromPrims $ progressFL "Writing changes:" chs--- Warning: A do-notation statement discarded a result of type Repository p r u x.- _ <- tentativelyAddPatch repository (compression opts) $ n2pia $ adddeps mypatch deps- invalidateIndex repository- debugMessage "Applying to pristine..."- rc <- testTentative repository- when (rc /= ExitSuccess) $ do- when (not $ isInteractive opts) $ exitWith rc `clarifyErrors` failuremessage- putStrLn $ "Looks like you have a bad patch: '"++name++"'"- let prompt = "Shall I record it anyway?"- yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])- case yn of- 'y' -> return ()- _ -> exitWith rc `clarifyErrors` failuremessage- withGutsOf repository (finalizeRepositoryChanges repository)- `clarifyErrors` failuremessage- debugMessage "Syncing timestamps..."- when (isJust logf) $ removeFile (fromJust logf)- when (Quiet `notElem` opts) $- putStrLn $ "Finished recording patch '"++name++"'"- where failuremessage = "Failed to record patch '"++name++"'" ++- case logf of Just lf -> "\nLogfile left in "++lf++"."- Nothing -> ""--recordHelp' :: String-recordHelp' =- "Every patch has a name, an optional description, an author and a date.\n" ++- "\n" ++- "The patch name should be a short sentence that concisely describes the\n" ++- "patch, such as `Add error handling to main event loop.' You can\n" ++- "supply it in advance with the -m option, or provide it when prompted.\n" ++- "\n" ++- "The patch description is an optional block of free-form text. It is\n" ++- "used to supply additional information that doesn't fit in the patch\n" ++- "name. For example, it might include a rationale of WHY the change was\n" ++- "necessary. By default Darcs asks if you want to add a description;\n" ++- "the --edit-long-comment and --skip-long-comment can be used to answer\n" ++- "`yes' or `no' (respectively) to this prompt. Finally, the --logfile\n" ++- "option allows you to supply a file that already contains the patch\n" ++- "name (first line) and patch description (subsequent lines). This is\n" ++- "useful if a previous record failed and left a darcs-record-0 file.\n" ++- "\n" ++- unlines fileHelpAuthor ++- "\n" ++- "The patch date is generated automatically. It can only be spoofed by\n" ++- "using the --pipe option.\n"--getDate :: [DarcsFlag] -> IO String-getDate opts- | Pipe `elem` opts = do cleanLocalDate `fmap` askUser "What is the date? "-getDate _ = getIsoDateTime--data PName = FlagPatchName String | PriorPatchName String | NoPatchName--getLog :: forall prim C(x y) . (Patchy prim, PrimPatch prim) => [DarcsFlag] -> Maybe (String, [String]) -> IO String -> FL prim C(x y) ->- IO (String, [String], Maybe String)-getLog opts m_old make_log chs = gl opts- where patchname_specified = patchname_helper opts- patchname_helper (PatchName n:_) | "TAG " `isPrefixOf` n = FlagPatchName $ '.':n- | otherwise = FlagPatchName n- patchname_helper (_:fs) = patchname_helper fs- patchname_helper [] = case m_old of Just (p,_) -> PriorPatchName p- Nothing -> NoPatchName- default_log = case m_old of- Nothing -> []- Just (_,l) -> l- gl (Pipe:_) = do p <- case patchname_specified of- FlagPatchName p -> return p- PriorPatchName p -> return p- NoPatchName -> prompt_patchname False- putStrLn "What is the log?"- thelog <- lines `fmap` Ratified.hGetContents stdin- return (p, thelog, Nothing)- gl (LogFile f:fs) =- do -- round 1 (patchname)- mlp <- lines `fmap` readLocaleFile f `catch` (\(_ :: IOException) -> return [])- firstname <- case (patchname_specified, mlp) of- (FlagPatchName p, []) -> return p- (_, p:_) -> return p -- logfile trumps prior!- (PriorPatchName p, []) -> return p- (NoPatchName, []) -> prompt_patchname True- -- round 2- append_info f firstname--- Warning: A do-notation statement discarded a result of type ExitCode.- when (EditLongComment `elem` fs) $ do _ <- editFile f- return ()- (name, thelog, _) <- read_long_comment f firstname- let toRemove = if willRemoveLogFile opts- then Just $ toFilePath f- else Nothing- return (name, thelog, toRemove)- gl (EditLongComment:_) =- case patchname_specified of- FlagPatchName p -> actually_get_log p- PriorPatchName p -> actually_get_log p- NoPatchName -> prompt_patchname True >>= actually_get_log- gl (NoEditLongComment:_) =- case patchname_specified of- FlagPatchName p- | Just ("",_) <- m_old ->- return (p, default_log, Nothing) -- rollback -m- FlagPatchName p -> return (p, default_log, Nothing) -- record (or amend) -m- PriorPatchName p -> return (p, default_log, Nothing) -- amend- NoPatchName -> do p <- prompt_patchname True -- record- return (p, [], Nothing)- gl (PromptLongComment:fs) =- case patchname_specified of- FlagPatchName p -> prompt_long_comment p -- record (or amend) -m- _ -> gl fs- gl (_:fs) = gl fs- gl [] = case patchname_specified of- FlagPatchName p -> return (p, default_log, Nothing) -- record (or amend) -m- PriorPatchName "" -> prompt_patchname True >>= prompt_long_comment- PriorPatchName p -> return (p, default_log, Nothing)- NoPatchName -> prompt_patchname True >>= prompt_long_comment- prompt_patchname retry =- do n <- askUser "What is the patch name? "- if n == "" || "TAG " `isPrefixOf` n- then if retry then prompt_patchname retry- else fail "Bad patch name!"- else return n- prompt_long_comment oldname =- do y <- promptYorn "Do you want to add a long comment?"- if y then actually_get_log oldname- else return (oldname, [], Nothing)- actually_get_log p = do logf <- make_log- -- TODO: make sure encoding used for logf is the same everywhere- -- probably should be locale because the editor will assume it- writeLocaleFile logf $ unlines $ p : default_log- append_info logf p--- Warning: A do-notation statement discarded a result of type ExitCode.- _ <- editFile logf- read_long_comment logf p- read_long_comment :: FilePathLike p => p -> String -> IO (String, [String], Maybe p)- read_long_comment f oldname =- do t <- (lines.filter (/='\r')) `fmap` readLocaleFile f- case t of [] -> return (oldname, [], Just f)- (n:ls) -> return (n, takeWhile- (not.(eod `isPrefixOf`)) ls,- Just f)- append_info f oldname =- do fc <- readLocaleFile f- appendToFile f $ \h ->- do case fc of- _ | null (lines fc) -> B.hPut h (encodeLocale (oldname ++ "\n"))- | last fc /= '\n' -> B.hPut h (encodeLocale "\n")- | otherwise -> return ()- hPutDocLn h $ text eod- $$ text ""- $$ wrapText 75- ("Place the long patch description above the "++- eod++- " marker. The first line of this file "++- "will be the patch name.")- $$ text ""- $$ text "This patch contains the following changes:"- $$ text ""- $$ summaryFL chs--eod :: String-eod = "***END OF DESCRIPTION***"--askAboutDepends :: forall p C(r u t y) . (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> FL (PrimOf p) C(t y) -> [DarcsFlag]- -> [PatchInfo] -> IO [PatchInfo]-askAboutDepends repository pa' opts olddeps = do- -- ideally we'd just default the olddeps to yes but still ask about them.- -- SelectChanges doesn't currently (17/12/09) offer a way to do this so would- -- have to have this support added first.- pps <- readTentativeRepo repository- pa <- n2pia `fmap` anonymous (fromPrims pa')- FlippedSeal ps <- return- ((case pps of- PatchSet x _ -> FlippedSeal ((reverseRL x)+>+(pa:>:NilFL)))- :: FlippedSeal (FL (PatchInfoAnd p)) C(y))- let (pc, tps) = patchChoicesTps ps- tas = case catMaybes (mapFL (\tp -> if pa `unsafeCompare` (tpPatch tp) || info (tpPatch tp) `elem` olddeps- then Just (tag tp) else Nothing) tps) of-- [] -> error "askAboutDepends: []"- tgs -> tgs- Sealed2 ps' <- return $ case getChoices (forceFirsts tas pc) of _ :> mc :> _ -> Sealed2 $ mapFL_FL tpPatch mc- (deps:>_) <- runSelection (selectChanges FirstReversed ps') $- selectionContext "depend on" (filter askdep_allowed opts) Nothing Nothing- return $ olddeps `union` mapFL info deps- where- askdep_allowed = not . patchSelectFlag---onlySuccessfulExits :: ExitCode -> Maybe ()-onlySuccessfulExits ExitSuccess = Just ()-onlySuccessfulExits _ = Nothing--recordHelp'' :: String-recordHelp'' =- "If a test command has been defined with `darcs setpref', attempting to\n" ++- "record a patch will cause the test command to be run in a clean copy\n" ++- "of the working tree (that is, including only recorded changes). If\n" ++- "the test fails, you will be offered to abort the record operation.\n" ++- "\n" ++- "The --set-scripts-executable option causes scripts to be made\n" ++- "executable in the clean copy of the working tree, prior to running the\n" ++- "test. See `darcs get' for an explanation of the script heuristic.\n" ++- "\n" ++- "If your test command is tediously slow (e.g. `make all') and you are\n" ++- "recording several patches in a row, you may wish to use --no-test to\n" ++- "skip all but the final test.\n" ++- "\n" ++- "To see some context (unchanged lines) around each change, use the\n" ++- "--unified option.\n"-
− src/Darcs/Commands/Remove.hs
@@ -1,166 +0,0 @@--- Copyright (C) 2002-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Remove ( remove, rm, unadd ) where--import Control.Monad ( when, foldM )-import Darcs.Commands ( DarcsCommand(..), nodefaults,- commandAlias, commandStub,- putWarning- )-import Darcs.Arguments ( DarcsFlag (Recursive), fixSubPaths,- listRegisteredFiles,- workingRepoDir, umaskOption,- recursive- )-import Darcs.RepoPath ( SubPath, sp2fn )-import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), amInHashedRepository,- addToPending, readRecordedAndPending, readUnrecorded )-import Darcs.Diff( treeDiff )-import Darcs.Patch ( RepoPatch, PrimOf, PrimPatch, adddir, rmdir, addfile, rmfile )-import Darcs.Patch.FileName( fn2fp )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Witnesses.Ordered ( FL(..), (+>+) )-import Darcs.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )-import Darcs.Repository.Prefs ( filetypeFunction, FileType )-import Storage.Hashed.Tree( Tree, TreeItem(..), find, modifyTree, expand, list )-import Storage.Hashed.AnchoredPath( anchorPath, AnchoredPath )-import Storage.Hashed( floatPath )--import Darcs.Commands.Add( expandDirs )-import Printer ( text )--#include "gadts.h"--removeDescription :: String-removeDescription = "Remove files from version control."--removeHelp :: String-removeHelp =- "The `darcs remove' command exists primarily for symmetry with `darcs\n" ++- "add', as the normal way to remove a file from version control is\n" ++- "simply to delete it from the working tree. This command is only\n" ++- "useful in the unusual case where one wants to record a removal patch\n" ++- "WITHOUT deleting the copy in the working tree (which can be re-added).\n" ++- "\n" ++- "Note that applying a removal patch to a repository (e.g. by pulling\n" ++- "the patch) will ALWAYS affect the working tree of that repository.\n"--remove :: DarcsCommand-remove = DarcsCommand {commandProgramName = "darcs",- commandName = "remove",- commandHelp = removeHelp,- commandDescription = removeDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["<FILE or DIRECTORY> ..."],- commandCommand = removeCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = listRegisteredFiles,- commandArgdefaults = nodefaults,- commandAdvancedOptions = [umaskOption],- commandBasicOptions =- [workingRepoDir, recursive "recurse into subdirectories"]}--removeCmd :: [DarcsFlag] -> [String] -> IO ()-removeCmd opts relargs = do- when (null relargs) $- fail "Nothing specified, nothing removed."- origfiles <- fixSubPaths opts relargs- when (null origfiles) $- fail "No valid arguments were given."- withRepoLock opts $ RepoJob $ \repository -> do- args <- if Recursive `elem` opts- then reverse `fmap` expandDirs origfiles- else return origfiles- Sealed p <- makeRemovePatch opts repository args- addToPending repository p---- | makeRemovePatch builds a list of patches to remove the given filepaths.--- This function does not recursively process directories. The 'Recursive'--- flag should be handled by the caller by adding all offspring of a directory--- to the files list.-makeRemovePatch :: (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> Repository p C(r u t)- -> [SubPath] -> IO (Sealed (FL (PrimOf p) C(u)))-makeRemovePatch opts repository files =- do recorded <- expand =<< readRecordedAndPending repository- unrecorded <- readUnrecorded repository $ Just files- ftf <- filetypeFunction- result <- foldM removeOnePath (ftf,recorded,unrecorded, []) $ map (floatPath . fn2fp . sp2fn) files- case result of- (_, _, _, patches) -> return $- unFreeLeft $ foldr (joinGap (+>+)) (emptyGap NilFL) $ reverse patches- where removeOnePath (ftf, recorded, unrecorded, patches) f = do- let recorded' = modifyTree recorded f Nothing- unrecorded' = modifyTree unrecorded f Nothing- local <- makeRemoveGap opts ftf recorded unrecorded unrecorded' f- -- we can tell if the remove succeeded by looking if local is- -- empty. If the remove succeeded, we should pass on updated- -- recorded and unrecorded that reflect the removal- return $ case local of- Just gap -> (ftf, recorded', unrecorded', gap : patches)- _ -> (ftf, recorded, unrecorded, patches)---- | Takes a file path and returns the FL of patches to remove that, wrapped in--- a 'Gap'.--- Returns 'Nothing' in case the path cannot be removed (if it is not tracked,--- or if it's a directory and it's not tracked).--- The three 'Tree' arguments are the recorded state, the unrecorded state--- excluding the removal of this file, and the unrecorded state including the--- removal of this file.-makeRemoveGap :: PrimPatch prim => [DarcsFlag] -> (FilePath -> FileType)- -> Tree IO -> Tree IO -> Tree IO -> AnchoredPath- -> IO (Maybe (FreeLeft (FL prim)))-makeRemoveGap opts ftf recorded unrecorded unrecorded' f =- case (find recorded f, find unrecorded f) of- (Just (SubTree _), Just (SubTree unrecordedChildren)) -> do- if not $ null (list unrecordedChildren)- then skipAndWarn "it is not empty"- else return $ Just $ freeGap (rmdir f_fp :>: NilFL)- (Just (File _), Just (File _)) ->- Just `fmap` treeDiff ftf unrecorded unrecorded'- (Just (File _), _) ->- return $ Just $ freeGap (addfile f_fp :>: rmfile f_fp :>: NilFL)- (Just (SubTree _), _) ->- return $ Just $ freeGap (adddir f_fp :>: rmdir f_fp :>: NilFL)- (_, _) -> skipAndWarn "it is not tracked by darcs"- where f_fp = anchorPath "" f- skipAndWarn reason =- do putWarning opts . text $ "Can't remove " ++ f_fp- ++ " (" ++ reason ++ ")"- return $ Nothing---rmDescription :: String-rmDescription = "Help newbies find `darcs remove'."--rmHelp :: String-rmHelp =- "The `darcs rm' command does nothing.\n" ++- "\n" ++- "The normal way to remove a file from version control is simply to\n" ++- "delete it from the working tree. To remove a file from version\n" ++- "control WITHOUT affecting the working tree, see `darcs remove'.\n"--rm :: DarcsCommand-rm = commandStub "rm" rmHelp rmDescription remove--unadd :: DarcsCommand-unadd = commandAlias "unadd" Nothing remove-
− src/Darcs/Commands/Replace.hs
@@ -1,241 +0,0 @@--- Copyright (C) 2002-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--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 )-import Darcs.Arguments ( DarcsFlag(ForceReplace, Toks), listRegisteredFiles,- ignoretimes, umaskOption, tokens, forceReplace,- workingRepoDir, fixSubPaths )-import Darcs.Repository ( withRepoLock, RepoJob(..),- addToPending,- amInHashedRepository,- applyToWorking,- readUnrecorded, readRecordedAndPending- )-import Darcs.Patch ( Patchy, PrimPatch, tokreplace, forceTokReplace, applyToTree )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.FileName( fn2fp )-import Darcs.Patch.Patchy ( Apply )-import Darcs.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL )-import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..) )-import Darcs.Patch.RegChars ( regChars )-import Data.Char ( isSpace )-import Darcs.RepoPath ( SubPath, toFilePath, sp2fn )-import Darcs.Repository.Prefs ( FileType(TextFile) )-import Darcs.Diff( treeDiff )-import Storage.Hashed.Tree( readBlob, modifyTree , findFile, TreeItem(..), Tree, makeBlobBS )-import Storage.Hashed.AnchoredPath( AnchoredPath, floatPath )--import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString as BS-#include "impossible.h"-#include "gadts.h"--replaceDescription :: String-replaceDescription = "Substitute one word for another."--replaceHelp :: String-replaceHelp =- "In addition to line-based patches, Darcs supports a limited form of\n" ++- "lexical substitution. Files are treated as sequences of words, and\n" ++- "each occurrence of the old word is replaced by the new word.\n" ++- "This is intended to provide a clean way to rename a function or\n" ++- "variable. Such renamings typically affect lines all through the\n" ++- "source code, so a traditional line-based patch would be very likely to\n" ++- "conflict with other branches, requiring manual merging.\n" ++- "\n" ++- "Files are tokenized according to one simple rule: words are strings of\n" ++- "valid token characters, and everything between them (punctuation and\n" ++- -- FIXME: this heuristic is ham-fisted and silly. Can we drop it?- "whitespace) is discarded. By default, valid token characters are\n" ++- "letters, numbers and the underscore (i.e. [A-Za-z0-9_]). However if\n" ++- "the old and/or new token contains either a hyphen or period, BOTH\n" ++- "hyphen and period are treated as valid (i.e. [A-Za-z0-9_.-]).\n" ++- "\n" ++- "The set of valid characters can be customized using the --token-chars\n" ++- "option. The argument must be surrounded by square brackets. If a\n" ++- "hyphen occurs between two characters in the set, it is treated as a\n" ++- "set range. For example, in most locales [A-Z] denotes all uppercase\n" ++- "letters. If the first character is a caret, valid tokens are taken to\n" ++- "be the complement of the remaining characters. For example, [^:\\n]\n" ++- "could be used to match fields in the passwd(5), where records and\n" ++- "fields are separated by newlines and colons respectively.\n" ++- "\n" ++- "If you choose to use --token-chars, you are STRONGLY encouraged to do\n" ++- "so consistently. The consequences of using multiple replace patches\n" ++- "with different --token-chars arguments on the same file are not well\n" ++- "tested nor well understood.\n" ++- "\n" ++- "By default Darcs will refuse to perform a replacement if the new token\n" ++- "is already in use, because the replacements would be not be\n" ++- "distinguishable from the existing tokens. This behaviour can be\n" ++- "overridden by supplying the --force option, but an attempt to `darcs\n" ++- "rollback' the resulting patch will affect these existing tokens.\n" ++- "\n" ++- "Limitations:\n" ++- "\n" ++- "The tokenizer treats files as byte strings, so it is not possible for\n" ++- "--token-chars to include multi-byte characters, such as the non-ASCII\n" ++- "parts of UTF-8. Similarly, trying to replace a `high-bit' character\n" ++- "from a unibyte encoding will also result in replacement of the same\n" ++- "byte in files with different encodings. For example, an acute a from\n" ++- "ISO 8859-1 will also match an alpha from ISO 8859-7.\n" ++- "\n" ++- "Due to limitations in the patch file format, --token-chars arguments\n" ++- "cannot contain literal whitespace. For example, [^ \\n\\t] cannot be\n" ++- "used to declare all characters except the space, tab and newline as\n" ++- "valid within a word, because it contains a literal space.\n" ++- "\n" ++- "Unlike POSIX regex(7) bracket expressions, character classes (such as\n" ++- "[[:alnum:]]) are NOT supported by --token-chars, and will be silently\n" ++- "treated as a simple set of characters.\n"--replace :: DarcsCommand-replace = DarcsCommand {commandProgramName = "darcs",- commandName = "replace",- commandHelp = replaceHelp,- commandDescription = replaceDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["<OLD>","<NEW>",- "<FILE> ..."],- commandCommand = replaceCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = listRegisteredFiles,- commandArgdefaults = nodefaults,- commandAdvancedOptions = [ignoretimes, umaskOption],- commandBasicOptions =- [tokens, forceReplace, workingRepoDir]}--replaceCmd :: [DarcsFlag] -> [String] -> IO ()-replaceCmd opts (old:new:relfs) = withRepoLock opts $ RepoJob $ \repository -> do- fs <- fixSubPaths opts relfs- toks <- chooseToks opts old new- let checkToken tok =- unless (isTok toks tok) $ fail $ "'"++tok++"' is not a valid token!"- checkToken old- checkToken new- work <- readUnrecorded repository Nothing- cur <- readRecordedAndPending repository- 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 :: IOException) ->- fail $ "Can't do replace on working!\n"- ++ "Perhaps one of the files already contains '"++ new++"'?\n"- ++ show e- return ()- where ftf _ = TextFile- skipmsg f = "Skipping file '" ++ toFilePath f ++ "' which isn't in the repository."- exists tree file = if isJust $ findFile tree (floatSubPath file)- then return True- else do putStrLn $ skipmsg file- return False- repl :: forall prim . (Patchy prim, PrimPatch prim, ApplyState prim ~ Tree)- => String -> Tree IO -> Tree IO -> SubPath -> IO (FreeLeft (FL prim))- repl toks cur work f =- do work_replaced <- maybeApplyToTree replace_patch work- cur_replaced <- maybeApplyToTree replace_patch cur- if ForceReplace `elem` opts || isJust work_replaced || isJust cur_replaced- then get_force_replace f toks work- else do putStrLn $ "Skipping file '"++f_fp++"'"- putStrLn $ "Perhaps the recorded version of this " ++- "file already contains '" ++new++"'?"- putStrLn $ "Use the --force option to override."- return (emptyGap NilFL)- where f_fp = toFilePath f- replace_patch :: prim C(x y)- replace_patch = tokreplace f_fp toks old new-- get_force_replace :: PrimPatch prim => SubPath -> String -> Tree IO -> IO (FreeLeft (FL prim))- get_force_replace f toks tree = do- let path = floatSubPath f- content <- readBlob $ fromJust $ findFile tree path- let newcontent = forceTokReplace toks new old (BS.concat $ BL.toChunks content)- tree' = modifyTree tree path (File . makeBlobBS <$> newcontent)- case newcontent of- Nothing -> bug "weird forcing bug in replace."- Just _ -> do pfix <- treeDiff ftf tree tree'- putStrLn $ "Don't be surprised!"- putStrLn $ "I've changed all instances of '" ++ new ++ "' to '" ++ old ++ "' first"- putStrLn $ "so that darcs replace can token-replace them back into '" ++ new ++ "' again."- return $ joinGap (+>+) pfix (freeGap (tokreplace f_fp toks old new :>: NilFL))- where f_fp = toFilePath f--replaceCmd _ _ = fail "Usage: darcs replace OLD NEW [FILES]"--floatSubPath :: SubPath -> AnchoredPath-floatSubPath = floatPath . fn2fp . sp2fn--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)- (\(_ :: IOException) -> return Nothing)--defaultToks :: String-defaultToks = "A-Za-z_0-9"-filenameToks :: String-filenameToks = "A-Za-z_0-9\\-\\."---- | Given a set of characters and a string, returns true iff the--- string contains only characters from the set. A set beginning with--- a caret (@^@) is treated as a complementary set.-isTok :: String -> String -> Bool-isTok _ "" = False-isTok toks s = all (regChars toks) s---- | This function checks for @--token-chars@ on the command-line. If--- found, it validates the argument and returns it, without the--- surrounding square brackets. Otherwise, it returns either--- 'defaultToks' or 'filenameToks' as explained in 'replaceHelp'.------ Note: Limitations in the current replace patch file format prevents--- tokens and token-char specifiers from containing any whitespace.-chooseToks :: [DarcsFlag] -> String -> String -> IO String-chooseToks (Toks t:_) a b- | length t <= 2 =- bad_token_spec $ "It must contain more than 2 characters, because " ++- "it should be enclosed in square brackets"- | head t /= '[' || last t /= ']' =- bad_token_spec "It should be enclosed in square brackets"- | '^' == head tok && length tok == 1 =- bad_token_spec "Must be at least one character in the complementary set"- | any isSpace t =- bad_token_spec "Space is not allowed in the spec"- | any isSpace a = bad_token_spec $ spacey_token a- | any isSpace b = bad_token_spec $ spacey_token b- | not (isTok tok a) = bad_token_spec $ not_a_token a- | not (isTok tok b) = bad_token_spec $ not_a_token b- | otherwise = return tok- where tok = init $ tail t :: String- bad_token_spec msg = fail $ "Bad token spec: '"++ t ++"' ("++ msg ++")"- spacey_token x = x ++ " must not contain any space"- not_a_token x = x ++ " is not a token, according to your spec"-chooseToks (_:fs) a b = chooseToks fs a b-chooseToks [] a b = if isTok defaultToks a && isTok defaultToks b- then return defaultToks- else return filenameToks-
− src/Darcs/Commands/Revert.hs
@@ -1,123 +0,0 @@--- Copyright (C) 2002-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- 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 )--import English (englishNum, This(..), Noun(..))-import Darcs.Flags( diffingOpts )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Commands.Util ( announceFiles )-import Darcs.Arguments ( DarcsFlag( All, Debug ),- ignoretimes, workingRepoDir,- allInteractive,- fixSubPaths,- listRegisteredFiles, umaskOption, unified- )-import Darcs.Utils ( askUser )-import Darcs.RepoPath ( toFilePath )-import Darcs.Repository ( withRepoLock, RepoJob(..), withGutsOf,- addToPending,- applyToWorking,- amInHashedRepository, readRecorded,- unrecordedChanges- )-import Darcs.Patch ( invert, effectOnFilePaths, commute )-import Darcs.Patch.Split ( reversePrimSplitter )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), lengthFL, nullFL, (+>+) )-import Darcs.SelectChanges ( selectChanges, WhichChanges(Last), selectionContextPrim, runSelection )-import Darcs.Patch.TouchesFiles ( chooseTouching )-import Darcs.Commands.Unrevert ( writeUnrevert )-import Darcs.Witnesses.Sealed ( Sealed(..) )--#include "gadts.h"--revertDescription :: String-revertDescription = "Discard unrecorded changes."--revertHelp :: String-revertHelp =- "The `darcs revert' command discards unrecorded changes the working\n" ++- "tree. As with `darcs record', you will be asked which hunks (changes)\n" ++- "to revert. The --all switch can be used to avoid such prompting. If\n" ++- "files or directories are specified, other parts of the working tree\n" ++- "are not reverted.\n" ++- "\n" ++- "In you accidentally reverted something you wanted to keep (for\n" ++- "example, typing `darcs rev -a' instead of `darcs rec -a'), you can\n" ++- "immediately run `darcs unrevert' to restore it. This is only\n" ++- "guaranteed to work if the repository has not changed since `darcs\n" ++- "revert' ran.\n"--revert :: DarcsCommand-revert = DarcsCommand {commandProgramName = "darcs",- commandName = "revert",- commandHelp = revertHelp,- commandDescription = revertDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["[FILE or DIRECTORY]..."],- commandCommand = revertCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = listRegisteredFiles,- commandArgdefaults = nodefaults,- commandAdvancedOptions = [ignoretimes, umaskOption],- commandBasicOptions = [allInteractive, unified,- workingRepoDir]}--revertCmd :: [DarcsFlag] -> [String] -> IO ()-revertCmd opts args = withRepoLock opts $ RepoJob $ \repository -> do- files <- if null args then return Nothing- else Just . sort <$> fixSubPaths opts args- announceFiles files "Reverting changes in"- changes <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository files- let pre_changed_files = effectOnFilePaths (invert changes) . map toFilePath <$> files- rec <- readRecorded repository- Sealed touching_changes <- return (chooseTouching pre_changed_files changes)- (case touching_changes of- NilFL -> putStrLn "There are no changes to revert!"- _ -> do- let context = selectionContextPrim "revert" opts (Just reversePrimSplitter) pre_changed_files (Just rec)- (norevert:>p) <- runSelection (selectChanges Last changes) context- if nullFL p- then putStrLn $ "If you don't want to revert after all," ++- " that's fine with me!"- else do- let theseChanges = englishNum (lengthFL p) . This . Noun $ "change"- yorn <- if All `elem` opts- then return "y"- else askUser $ "Do you really want to revert " ++ theseChanges "? "- case yorn of ('y':_) -> return ()- _ -> exitWith $ ExitSuccess- withGutsOf repository $ do- addToPending repository $ invert p- when (Debug `elem` opts) $ putStrLn "About to write the unrevert file."- case commute (norevert:>p) of- 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 :: IOException) ->- fail ("Unable to apply inverse patch!" ++ show e)- return ()) :: IO ()- putStrLn "Finished reverting."-
− src/Darcs/Commands/Rollback.hs
@@ -1,193 +0,0 @@--- Copyright (C) 2002-2004,2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--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 )-import Data.Maybe ( isJust )-import System.Directory ( removeFile )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag(MarkConflicts), fixSubPaths, getAuthor,- setEnvDarcsPatches,- workingRepoDir, nocompress,- author, patchnameOption, askLongComment,- leaveTestDir, notest, listRegisteredFiles,- matchSeveralOrLast, allInteractive, umaskOption,- recordRollback- )-import Darcs.RepoPath ( toFilePath )-import Darcs.Repository ( Repository, amInHashedRepository, withRepoLock, RepoJob(..),- applyToWorking,- readRepo,- tentativelyMergePatches, withGutsOf,- testTentative,- finalizeRepositoryChanges, invalidateIndex,- tentativelyAddToPending, considerMergeToWorking- )-import Darcs.Patch ( RepoPatch, summary, invert, namepatch, effect, fromPrims,- sortCoalesceFL, canonize, anonymous, PrimOf )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Flags ( isInteractive, rollbackInWorkingDir )-import Darcs.Patch.Set ( PatchSet(..), newset2FL )-import Darcs.Patch.Split ( reversePrimSplitter )-import Darcs.Witnesses.Ordered-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )-import Darcs.Lock ( worldReadableTemp )-import Darcs.Match ( firstMatch )-import Darcs.SelectChanges ( selectChanges,- WhichChanges(..),- selectionContext, selectionContextPrim,- runSelection- )-import Darcs.Commands.Record ( getLog )-import Darcs.Commands.Unrecord ( getLastPatches )-import Darcs.Commands.Util ( announceFiles, filterExistingFiles )-import Darcs.Utils ( clarifyErrors, PromptConfig(..), promptChar )-import Printer ( renderString )-import Progress ( debugMessage )-import Darcs.Witnesses.Sealed ( Sealed(..) )-import IsoDate ( getIsoDateTime )-import Storage.Hashed.Tree( Tree )-#include "impossible.h"-#include "gadts.h"--rollbackDescription :: String-rollbackDescription =- "Record a new patch reversing some recorded changes."--rollbackHelp :: String-rollbackHelp =- "Rollback is used to undo the effects of one or more patches without actually\n"++- "deleting them. Instead, it creates a new patch reversing selected portions.\n"++- "of those changes. Unlike obliterate and unrecord (which accomplish a similar\n"++- "goal) rollback is perfectly safe, since it leaves in the repository a record\n"++- "of its changes.\n"--rollback :: DarcsCommand-rollback = DarcsCommand {commandProgramName = "darcs",- commandName = "rollback",- commandHelp = rollbackHelp,- commandDescription = rollbackDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["[FILE or DIRECTORY]..."],- commandCommand = rollbackCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = listRegisteredFiles,- commandArgdefaults = nodefaults,- commandAdvancedOptions = [nocompress,umaskOption],- commandBasicOptions = [matchSeveralOrLast,- allInteractive,- author, patchnameOption, askLongComment,- notest, leaveTestDir,- workingRepoDir, recordRollback]}--rollbackCmd :: [DarcsFlag] -> [String] -> IO ()-rollbackCmd opts args = withRepoLock opts $ RepoJob $ \repository -> do- files <- if null args then return Nothing- else Just . sort <$> fixSubPaths opts args- when (files == Just []) $ fail "No valid arguments were given."- let files_fp = map toFilePath <$> files- announceFiles files "Recording changes in"- existing_files <- maybe (return Nothing)- (fmap Just . filterExistingFiles repository) files- when (existing_files == Just []) $- fail "None of the files you specified exist!"- allpatches <- readRepo repository- (_ :> patches) <- return $ if firstMatch opts- then getLastPatches opts allpatches- else (PatchSet NilRL NilRL):> (newset2FL allpatches)- let patches_context = selectionContext "rollback" opts Nothing files_fp- (_ :> ps) <- runSelection (selectChanges LastReversed patches) patches_context- when (nullFL ps) $ do putStrLn "No patches selected!"- exitWith ExitSuccess- setEnvDarcsPatches ps- let hunks_context = selectionContextPrim "rollback" opts (Just reversePrimSplitter) files_fp Nothing- hunks = (concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect ps)- runSelection (selectChanges Last hunks) hunks_context >>=- if (rollbackInWorkingDir opts)- then (undoItNow opts repository)- else (rollItBackNow opts repository ps)--rollItBackNow :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) =>- [DarcsFlag] -> Repository p C(r u t) -> FL (PatchInfoAnd p) C(x y)- -> (q :> FL (PrimOf p)) C(a t) -> IO ()-rollItBackNow opts repository ps (_ :> ps'') =- do when (nullFL ps'') $ do putStrLn "No changes selected!"- exitWith ExitSuccess- let make_log = worldReadableTemp "darcs-rollback"- newlog = Just ("", "":"rolling back:":"":lines (renderString $ summary ps ))- --tentativelyRemovePatches repository opts (mapFL_FL hopefully ps)- (name, my_log, logf) <- getLog opts newlog make_log $ invert ps''- date <- getIsoDateTime- my_author <- getAuthor opts- rbp <- n2pia `fmap` namepatch date name my_author my_log- (fromPrims $ invert ps'')- debugMessage "Adding rollback patch to repository."- Sealed pw <-- tentativelyMergePatches repository "rollback"- (MarkConflicts : opts) NilFL- (rbp :>: NilFL)- debugMessage "Finalizing rollback changes..."- invalidateIndex repository- rc <- testTentative repository- when (rc /= ExitSuccess) $ do- when (not $ isInteractive opts) $ exitWith rc- putStrLn $ "Looks like you have a bad patch: '"++name++"'"- let prompt = "Shall I rollback anyway?"- yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])- case yn of- 'y' -> return ()- _ -> exitWith rc- withGutsOf repository $ do- finalizeRepositoryChanges repository- debugMessage "About to apply rolled-back changes to working directory."- _ <- revertable $ applyToWorking repository opts pw- return ()- when (isJust logf) $ removeFile (fromJust logf)- putStrLn "Finished rolling back."- where revertable x = x `clarifyErrors` unlines- ["Error applying patch to the working directory.","",- "This may have left your working directory an inconsistent",- "but recoverable state. If you had no un-recorded changes",- "by using 'darcs revert' you should be able to make your",- "working directory consistent again."]--undoItNow :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)- => [DarcsFlag] -> Repository p C(r u t)- -> (q :> FL (PrimOf p)) C(a t) -> IO ()-undoItNow opts repo (_ :> prims) =- do- rbp <- n2pia `fmap` anonymous (fromPrims $ invert prims)- Sealed pw <- considerMergeToWorking repo "rollback" (MarkConflicts: opts)- NilFL (rbp :>: NilFL)- tentativelyAddToPending repo opts pw- withGutsOf repo $ do- finalizeRepositoryChanges repo- _ <- 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"-
− src/Darcs/Commands/Send.hs
@@ -1,411 +0,0 @@--- Copyright (C) 2002-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# 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 )-import Data.Maybe ( isNothing, fromMaybe )--import Darcs.Commands ( DarcsCommand(..), putInfo, putVerbose )-import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile,- Target, Context,- DryRun, Quiet- ),- fixUrl, setEnvDarcsPatches,- getCc, getAuthor, workingRepoDir,- editDescription, logfile, rmlogfile,- sign, getSubject, depsSel, getInReplyTo,- matchSeveral, setDefault, outputAutoName,- output, ccSend, subject, target, author, sendmailCmd,- inReplyTo, remoteRepo, networkOptions,- allInteractive, getSendmailCmd,- printDryRunMessageAndExit,- summary, allowUnrelatedRepos,- fromOpt, dryRun, sendToContext, getOutput,- changesReverse, charset, getCharset,- )-import Darcs.Flags ( willRemoveLogFile, doReverse )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, patchDesc )-import Darcs.Repository ( PatchSet, Repository,- amInHashedRepository, identifyRepositoryFor, withRepoReadLock, RepoJob(..),- readRepo, readRecorded, prefsUrl, checkUnrelatedRepos )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch ( RepoPatch, description, applyToTree, invert )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:>)(..),- mapFL, mapFL_FL, lengthFL, nullFL )-import Darcs.Patch.Bundle ( makeBundleN, scanContext, patchFilename )-import Darcs.Repository.Prefs ( defaultrepo, setDefaultrepo, getPreflist )-import Darcs.External ( signString, sendEmailDoc, fetchFilePS, Cachable(..), generateEmail-#ifndef HAVE_MAPI- , haveSendmail-#endif- )-import ByteStringUtils ( mmapFilePS, isAscii )-import qualified Data.ByteString.Char8 as BC (unpack)-import Darcs.Lock ( withOpenTemp, writeDocBinFile, readDocBinFile, worldReadableTemp, removeFileMayNotExist )-import Darcs.SelectChanges ( selectChanges, WhichChanges(..), selectionContext, runSelection )-import Darcs.Patch.Depends ( findCommonWithThem )-import Darcs.Utils ( askUser, promptYorn, catchall, editFile, formatPath, getSystemEncoding, isUTF8Locale )-import Data.Text.Encoding ( decodeUtf8' )-import Progress ( debugMessage )-import Darcs.Email ( makeEmail )-import Printer ( Doc, vsep, vcat, text, ($$), (<+>), (<>), putDoc, renderPS )-import Darcs.RepoPath ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd,- getCurrentDirectory, useAbsoluteOrStd )-import URL.HTTP ( postUrl )-#include "impossible.h"--#include "gadts.h"--sendDescription :: String-sendDescription =- "Send by email a bundle of one or more patches."--sendHelp :: String-sendHelp =- "Send is used to prepare a bundle of patches that can be applied to a target\n"++- "repository. Send accepts the URL of the repository as an argument. When\n"++- "called without an argument, send will use the most recent repository that\n"++- "was either pushed to, pulled from or sent to. By default, the patch bundle\n"++- "is sent by email, although you may save it to a file.\n"--send :: DarcsCommand-send = DarcsCommand {commandProgramName = "darcs",- commandName = "send",- commandHelp = sendHelp,- commandDescription = sendDescription,- commandExtraArgs = 1,- commandExtraArgHelp = ["[REPOSITORY]"],- commandCommand = sendCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = getPreflist "repos",- commandArgdefaults = defaultrepo,- commandAdvancedOptions = [logfile, rmlogfile,- remoteRepo,- sendToContext, changesReverse] ++- networkOptions,- commandBasicOptions = [matchSeveral, depsSel,- allInteractive,- fromOpt, author,- target,ccSend,subject, inReplyTo, charset,- output,outputAutoName,sign]- ++dryRun++[summary,- editDescription,- setDefault False,- workingRepoDir,- sendmailCmd,- allowUnrelatedRepos]}--sendCmd :: [DarcsFlag] -> [String] -> IO ()-sendCmd input_opts [""] = sendCmd input_opts []-sendCmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $ RepoJob $- \(repository :: Repository p C(r u r)) -> do- context_ps <- the_context input_opts- case context_ps of- Just them -> do- wtds <- decideOnBehavior input_opts (Nothing :: Maybe (Repository p C(r u r)))- sendToThem repository input_opts wtds "CONTEXT" them- Nothing -> do- repodir <- fixUrl input_opts unfixedrepodir- -- Test to make sure we aren't trying to push to the current repo- here <- getCurrentDirectory- when (repodir == toFilePath here) $- fail "Can't send to current repository! Did you mean send --context?"- old_default <- getPreflist "defaultrepo"- when (old_default == [repodir] && Quiet `notElem` input_opts) $- putStrLn $ "Creating patch to "++formatPath repodir++"..."- repo <- identifyRepositoryFor repository repodir- them <- readRepo repo- setDefaultrepo repodir input_opts- wtds <- decideOnBehavior input_opts (Just repo)- sendToThem repository input_opts wtds repodir them- where the_context [] = return Nothing- the_context (Context foo:_)- = (Just . scanContext )`fmap` mmapFilePS (toFilePath foo)- the_context (_:fs) = the_context fs-sendCmd _ _ = impossible--sendToThem :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> [DarcsFlag] -> [WhatToDo] -> String- -> PatchSet p C(Origin x) -> IO ()-sendToThem repo opts wtds their_name them = do-#ifndef HAVE_MAPI- -- Check if the user has sendmail or provided a --sendmail-cmd- -- (unless -o/-O or --dry-run is used)- sendmail <- haveSendmail- sm_cmd <- getSendmailCmd opts- when (isNothing (getOutput opts "") && DryRun `notElem` opts &&- not sendmail && sm_cmd == "") $ do- putInfo opts $ text "No working sendmail instance on your machine!"- exitWith $ ExitFailure 1-#endif- us <- readRepo repo- common :> us' <- return $ findCommonWithThem us them- checkUnrelatedRepos opts us them- (case us' of- NilFL -> do putInfo opts $ text "No recorded local changes to send!"- exitWith ExitSuccess- _ -> putVerbose opts $ text "We have the following patches to send:"- $$ vcat (mapFL description us')) :: IO ()- pristine <- readRecorded repo- let context = selectionContext "send" opts Nothing Nothing- selector = if doReverse opts- then selectChanges FirstReversed- else selectChanges First- (to_be_sent :> _) <- runSelection (selector us') context- printDryRunMessageAndExit "send" opts to_be_sent- when (nullFL to_be_sent) $ do- putInfo opts $ text "You don't want to send any patches, and that's fine with me!"- exitWith ExitSuccess- setEnvDarcsPatches to_be_sent- bundle <- prepareBundle opts common pristine (us':\/:to_be_sent)- let make_fname (tb:>:_) = patchFilename $ patchDesc tb- make_fname _ = impossible- fname = make_fname to_be_sent- outname = getOutput opts fname- case outname of- Just fname' -> writeBundleToFile opts to_be_sent bundle fname' wtds their_name- Nothing -> sendBundle opts to_be_sent bundle fname wtds their_name--prepareBundle :: forall p C(x y z). (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> PatchSet p C(Origin z)- -> Tree IO -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(x y)- -> IO Doc-prepareBundle opts common pristine (us' :\/: to_be_sent) = do- pristine' <- applyToTree (invert $ mapFL_FL hopefully us') pristine- unsig_bundle <- makeBundleN (Just pristine') (unsafeCoerceP common) (mapFL_FL hopefully to_be_sent)- signString opts unsig_bundle--sendBundle :: forall p C(x y) . (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y)- -> Doc -> String -> [WhatToDo] -> String -> IO ()-sendBundle opts to_be_sent bundle fname wtds their_name=- let- auto_subject :: forall pp C(a b) . FL (PatchInfoAnd pp) C(a b) -> String- auto_subject (p:>:NilFL) = "darcs patch: " ++ trim (patchDesc p) 57- auto_subject (p:>:ps) = "darcs patch: " ++ trim (patchDesc p) 43 ++- " (and " ++ show (lengthFL ps) ++ " more)"- auto_subject _ = error "Tried to get a name from empty patch list."- trim st n = if length st <= n then st- else take (n-3) st ++ "..."- in do- thetargets <- getTargets wtds- from <- getAuthor opts- let thesubject = fromMaybe (auto_subject to_be_sent) $ getSubject opts- (mailcontents, mailfile, mailcharset) <- getDescription opts their_name to_be_sent-- let warnMailBody = let msg = "Email body left in " in- case mailfile of- Just mf -> putStrLn $ msg++mf++"."- Nothing -> return ()-- warnCharset msg = do- confirmed <- promptYorn $ "Warning: " ++ msg ++ " Send anyway?"- unless confirmed $ do- putStrLn "Aborted. You can specify charset with the --charset option."- warnMailBody- exitWith ExitSuccess-- thecharset <- case getCharset opts of- -- Always trust provided charset- providedCset@(Just _) -> return providedCset- Nothing ->- case mailcharset of- Nothing -> do- warnCharset "darcs could not guess the charset of your mail."- return mailcharset- Just "utf-8" -> do- -- Check the locale encoding for consistency- encoding <- getSystemEncoding- debugMessage $ "Current locale encoding: " ++ encoding- unless (isUTF8Locale encoding) $- warnCharset "your mail is valid UTF-8 but your locale differs."- return mailcharset- -- Trust other cases (us-ascii)- Just _ -> return mailcharset-- let body = makeEmail their_name- (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . getInReplyTo $ opts)- (Just mailcontents)- thecharset- bundle- (Just fname)- contentAndBundle = Just (mailcontents, bundle)-- sendmail = do- sm_cmd <- getSendmailCmd opts- let to = generateEmailToString thetargets- sendEmailDoc from to thesubject (getCc opts)- sm_cmd contentAndBundle body >>- (putInfo opts . text $ ("Successfully sent patch bundle to: "- ++ to- ++ ccs (getCc opts) ++"."))- `catch` \e -> do warnMailBody- fail $ ioeGetErrorString e- ccs [] = []- ccs cs = " and cc'ed " ++ cs-- when (null [ p | Post p <- thetargets]) sendmail- nbody <- withOpenTemp $ \ (fh,fn) -> do- let to = generateEmailToString thetargets- generateEmail fh from to thesubject (getCc opts) body- hClose fh- mmapFilePS fn- forM_ [ p | Post p <- thetargets]- (\url -> do- putInfo opts . text $ "Posting patch to " ++ url- postUrl url (BC.unpack nbody) "message/rfc822")- `catch` (\(_ :: IOException) -> sendmail)- cleanup opts mailfile--generateEmailToString :: [WhatToDo] -> String-generateEmailToString = intercalate " , " . filter (/= "") . map extractEmail- where- extractEmail (SendMail t) = t- extractEmail _ = ""--cleanup :: (FilePathLike t) => [DarcsFlag] -> Maybe t -> IO ()-cleanup opts (Just mailfile) = when (isNothing (getFileopt opts) || willRemoveLogFile opts) $- removeFileMayNotExist mailfile-cleanup _ Nothing = return ()--writeBundleToFile :: forall p C(x y) . (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> Doc ->- AbsolutePathOrStd -> [WhatToDo] -> String -> IO ()-writeBundleToFile opts to_be_sent bundle fname wtds their_name =- do (d,f,_) <- getDescription opts their_name to_be_sent- let putabs a = do writeDocBinFile a (d $$ bundle)- putStrLn $ "Wrote patch to " ++ toFilePath a ++ "."- putstd = putDoc (d $$ bundle)- useAbsoluteOrStd putabs putstd fname- let to = generateEmailToString wtds- unless (null to) $- putInfo opts . text $ "The usual recipent for this bundle is: " ++ to- cleanup opts f--data WhatToDo- = Post String -- ^ POST the patch via HTTP- | SendMail String -- ^ send patch via email--decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Maybe (Repository p C(r u t)) -> IO [WhatToDo]-decideOnBehavior opts remote_repo =- case the_targets of- [] -> do wtds <- case remote_repo of- Nothing -> return []- Just r -> check_post r- unless (null wtds) $ announce_recipients wtds- return wtds- ts -> do announce_recipients ts- return ts- where the_targets = collectTargets opts-#ifdef HAVE_HTTP- -- the ifdef above is to so that darcs only checks the remote- -- _darcs/post if we have an implementation of postUrl. See- -- our HTTP module for more details- check_post the_remote_repo =- do p <- ((readPost . BC.unpack) `fmap`- fetchFilePS (prefsUrl the_remote_repo++"/post")- (MaxAge 600)) `catchall` return []- emails <- who_to_email the_remote_repo- return (p++emails)- readPost = map parseLine . lines where- parseLine t = maybe (Post t) SendMail $ stripPrefix "mailto:" t-#else- check_post = who_to_email-#endif- who_to_email the_remote_repo =- do email <- (BC.unpack `fmap`- fetchFilePS (prefsUrl the_remote_repo++"/email")- (MaxAge 600))- `catchall` return ""- if '@' `elem` email then return . map SendMail $ lines email- else return []- announce_recipients emails =- let pn (SendMail s) = s- pn (Post p) = p- in if DryRun `elem` opts- then putInfo opts . text $ "Patch bundle would be sent to: "++unwords (map pn emails)- else when (null the_targets && isNothing (getOutput opts "")) $- putInfo opts . text $ "Patch bundle will be sent to: "++unwords (map pn emails)--getTargets :: [WhatToDo] -> IO [WhatToDo]-getTargets [] = fmap ((:[]) . SendMail) $ askUser "What is the target email address? "-getTargets wtds = return wtds--collectTargets :: [DarcsFlag] -> [WhatToDo]-collectTargets flags = [ f t | Target t <- flags ] where- f url | "http:" `isPrefixOf` url = Post url- f em = SendMail em--getDescription :: (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> String -> FL (PatchInfoAnd p) C(x y) -> IO (Doc, Maybe String, Maybe String)-getDescription opts their_name patches =- case get_filename of- Just f -> do file <- f- when (EditDescription `elem` opts) $ do- when (isNothing $ getFileopt opts) $- writeDocBinFile file patchdesc- debugMessage $ "About to edit file " ++ file- (_, changed) <- editFile file- unless changed $ do- confirmed <- promptYorn "File content did not change. Continue anyway?"- unless confirmed $ do putStrLn "Aborted."- exitWith ExitSuccess- return ()- doc <- readDocBinFile file- return (doc, Just file, tryGetCharset doc)- Nothing -> return (patchdesc, Nothing, tryGetCharset patchdesc)- where patchdesc = text (if lengthFL patches == 1- then "1 patch"- else show (lengthFL patches) ++ " patches")- <+> text "for repository" <+> text their_name <> text ":"- $$ text ""- $$ vsep (mapFL description patches)- get_filename = case getFileopt opts of- Just f -> Just $ return $ toFilePath f- Nothing -> if EditDescription `elem` opts- then Just tempfile- else Nothing- tempfile = worldReadableTemp "darcs-temp-mail"- tryGetCharset content = let body = renderPS content in- if isAscii body- then Just "us-ascii"- else either (const Nothing)- (const $ Just "utf-8")- (decodeUtf8' body)--getFileopt :: [DarcsFlag] -> Maybe AbsolutePath-getFileopt (LogFile f:_) = Just f-getFileopt (_:flags) = getFileopt flags-getFileopt [] = Nothing
− src/Darcs/Commands/SetPref.hs
@@ -1,108 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.SetPref ( setpref ) where--import System.Exit ( exitWith, ExitCode(..) )-import Control.Monad (when)-import Data.Maybe (fromMaybe)--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, workingRepoDir, umaskOption )-import Darcs.Repository ( amInHashedRepository, addToPending, withRepoLock, RepoJob(..) )-import Darcs.Patch ( changepref )-import Darcs.Witnesses.Ordered ( FL(..) )-import Darcs.Repository.Prefs ( getPrefval, changePrefval, )-import English ( orClauses )-#include "impossible.h"---- | A list of all valid preferences for @_darcs/prefs/prefs@.-validPrefData :: [(String, String)] -- ^ (name, one line description)-validPrefData =- [("test", "a shell command that runs regression tests"),- ("predist", "a shell command to run before `darcs dist'"),- ("boringfile", "the path to a version-controlled boring file"),- ("binariesfile", "the path to a version-controlled binaries file")]--validPrefs :: [String]-validPrefs = map fst validPrefData--setprefDescription :: String-setprefDescription =- "Set a preference (" ++ orClauses validPrefs ++ ")."--setprefHelp :: String-setprefHelp =- "When working on project with multiple repositories and contributors,\n" ++- "it is sometimes desirable for a preference to be set consistently\n" ++- "project-wide. This is achieved by treating a preference set with\n" ++- "`darcs setpref' as an unrecorded change, which can then be recorded\n" ++- "and then treated like any other patch.\n" ++- "\n" ++- "Valid preferences are:\n" ++- "\n" ++- unlines [" "++x++" -- "++y | (x,y) <- validPrefData] ++- "\n" ++- "For example, a project using GNU autotools, with a `make test' target\n" ++- "to perform regression tests, might enable Darcs' integrated regression\n" ++- "testing with the following command:\n" ++- "\n" ++- " darcs setpref test 'autoconf && ./configure && make && make test'\n" ++- "\n" ++- "Note that merging is not currently implemented for preferences: if two\n" ++- "patches attempt to set the same preference, the last patch applied to\n" ++- "the repository will always take precedence. This is considered a\n" ++- "low-priority bug, because preferences are seldom set.\n"--setpref :: DarcsCommand-setpref = DarcsCommand {commandProgramName = "darcs",- commandName = "setpref",- commandHelp = setprefHelp,- commandDescription = setprefDescription,- commandExtraArgs = 2,- commandExtraArgHelp = ["<PREF>",- "<VALUE>"],- commandCommand = setprefCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = return validPrefs,- commandArgdefaults = nodefaults,- commandAdvancedOptions = [umaskOption],- commandBasicOptions =- [workingRepoDir]}--setprefCmd :: [DarcsFlag] -> [String] -> IO ()-setprefCmd opts [pref,val] = withRepoLock opts $ RepoJob $ \repository -> do- when (' ' `elem` pref) $ do- putStrLn $ "'"++pref++- "' is not a valid preference name: no spaces allowed!"- exitWith $ ExitFailure 1- when (pref `notElem` validPrefs) $ do- putStrLn $ "'"++pref++"' is not a valid preference name!"- putStrLn $ "Try one of: " ++ unwords validPrefs- exitWith $ ExitFailure 1- oval <- getPrefval pref- let old = fromMaybe "" oval- when ('\n' `elem` val) $ do- putStrLn $ val ++ "is not a valid preference value: newlines forbidden!"- exitWith $ ExitFailure 1- changePrefval pref old val- putStrLn $ "Changing value of "++pref++" from '"++old++"' to '"++val++"'"- addToPending repository (changepref pref old val :>: NilFL)-setprefCmd _ _ = impossible-
− src/Darcs/Commands/Show.hs
@@ -1,82 +0,0 @@--- Copyright (C) 2002-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Commands.Show ( showCommand, list, query ) where--import Darcs.Commands ( DarcsCommand(..),- CommandControl(CommandData, HiddenCommand),- commandAlias,- )-import Darcs.Commands.ShowAuthors ( showAuthors )-import Darcs.Commands.ShowBug ( showBug )-import Darcs.Commands.ShowContents ( showContents )-import Darcs.Commands.ShowFiles ( showFiles, manifestCmd, toListManifest )-import Darcs.Commands.ShowTags ( showTags )-import Darcs.Commands.ShowRepo ( showRepo )-import Darcs.Commands.ShowIndex ( showIndex, showPristineCmd )-import Darcs.Repository ( amInRepository )--showDescription :: String-showDescription = "Show information which is stored by darcs."--showHelp :: String-showHelp =- "Use the --help option with the subcommands to obtain help for\n"++- "subcommands (for example, \"darcs show files --help\").\n" ++- "\n" ++- "In previous releases, this command was called `darcs query'.\n" ++- "Currently this is a deprecated alias.\n"--showCommand :: DarcsCommand-showCommand = SuperCommand {commandProgramName = "darcs",- commandName = "show",- commandHelp = showHelp,- commandDescription = showDescription,- commandPrereq = amInRepository,- commandSubCommands = [HiddenCommand showBug,- CommandData showContents,- CommandData showFiles, HiddenCommand showManifest,- CommandData showIndex,- CommandData showPristine,- CommandData showRepo,- CommandData showAuthors,- CommandData showTags]- }--query :: DarcsCommand-query = commandAlias "query" Nothing showCommand--list :: DarcsCommand-list = commandAlias "list" Nothing showCommand---- unfortunately, aliases for sub-commands have to live in their parent command--- to avoid an import cycle-showPristine :: DarcsCommand-showPristine = (commandAlias "pristine" (Just showCommand) showIndex) {- commandCommand = showPristineCmd,- commandDescription = "Dump contents of pristine cache.",- commandHelp =- "The `darcs show pristine' command lists all version-controlled files " ++- "and directories along with the hashes of their pristine copies. " ++- "For files, the fields correspond to file size, sha256 of the pristine " ++- "file content and the filename." }--showManifest :: DarcsCommand-showManifest = (commandAlias "manifest" (Just showCommand) showFiles) {- commandCommand = manifestCmd toListManifest-}-
− src/Darcs/Commands/ShowAuthors.hs
@@ -1,195 +0,0 @@--- Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael, Tomas Caithaml------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--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 )-import Data.Maybe( isJust )-import Text.ParserCombinators.Parsec hiding (lower, count, Line)-import Text.ParserCombinators.Parsec.Error-import Text.Regex ( Regex, mkRegexWithOpts, matchRegex )--import Darcs.Arguments ( DarcsFlag(..), workingRepoDir )-import Darcs.Commands ( DarcsCommand(..), nodefaults, putWarning )-import Darcs.External ( viewDoc )-import Darcs.Patch.PatchInfoAnd ( info )-import Darcs.Repository ( amInRepository, readRepo, withRepository, RepoJob(..) )-import Darcs.Patch.Info ( piAuthor )-import Darcs.Patch.Set ( newset2RL )-import Darcs.Witnesses.Ordered ( mapRL )-import Printer ( text )-import Data.Function (on)--data Spelling = Spelling String String [Regex] -- name, email, regexps-type ParsedLine = Maybe Spelling -- Nothing for blank lines---showAuthorsDescription :: String-showAuthorsDescription = "List authors by patch count."--showAuthorsHelp :: String-showAuthorsHelp =- "The `darcs show authors' command lists the authors of the current\n" ++- "repository, sorted by the number of patches contributed. With the\n" ++- "--verbose option, this command simply lists the author of each patch\n" ++- "(without aggregation or sorting).\n" ++- "\n" ++- "An author's name or email address may change over time. To tell Darcs\n" ++- "when multiple author strings refer to the same individual, create an\n" ++- "`.authorspellings' file in the root of the working tree. Each line in\n" ++- "this file begins with an author's canonical name and address, and may\n" ++- "be followed by a comma separated list of extended regular expressions.\n" ++- "Blank lines and lines beginning with two hyphens are ignored.\n" ++- "The format of .authorspelling can be described by this pattern:\n" ++- "\n" ++- " name <address> [, regexp ]*\n" ++- "\n" ++- "There are some pitfalls concerning special characters:\n" ++- "Whitespaces are stripped, if you need space in regexp use [ ]. \n" ++- "Because comma serves as a separator you have to escape it if you want\n" ++- "it in regexp. Note that .authorspelingfile use extended regular\n" ++- "expressions so +, ? and so on are metacharacters and you need to \n" ++- "escape them to be interpreted literally.\n" ++- "\n" ++- "Any patch with an author string that matches the canonical address or\n" ++- "any of the associated regexps is considered to be the work of that\n" ++- "author. All matching is case-insensitive and partial (it can match a\n" ++- "substring). Use ^,$ to match the whole string in regexps\n" ++- "\n" ++- "Currently this canonicalization step is done only in `darcs show\n" ++- "authors'. Other commands, such as `darcs changes' use author strings\n" ++- "verbatim.\n" ++- "\n" ++- "An example .authorspelling file is:\n" ++- "\n" ++- " -- This is a comment.\n" ++- " Fred Nurk <fred@example.com>\n" ++- " John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n" ++- " Chuck Jones\\, Jr. <chuck@pobox.com>, cj\\+user@example.com\n"--showAuthors :: DarcsCommand-showAuthors = DarcsCommand {- commandProgramName = "darcs",- commandName = "authors",- commandHelp = showAuthorsHelp,- commandDescription = showAuthorsDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = authorsCmd,- commandPrereq = amInRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [workingRepoDir] }--authorsCmd :: [DarcsFlag] -> [String] -> IO ()-authorsCmd opts _ = withRepository opts $ RepoJob $ \repository -> do- patches <- readRepo repository- spellings <- compiledAuthorSpellings opts- let authors = mapRL (piAuthor . info) $ newset2RL patches- viewDoc $ text $ unlines $- if Verbose `elem` opts- then authors- else -- A list of the form ["<count> <canonical name>"]...-- -- Turn the final result into a list of strings.- map (\ (count, name) -> show count ++ "\t" ++ name) $- -- Sort by descending patch count.- reverse $ sortBy (comparing fst) $- -- Combine duplicates from a list [(count, canonized name)]- -- with duplicates canonized names (see next comment).- map ((sum *** head) . unzip) $- groupBy ((==) `on` snd) $- sortBy (comparing snd) $- -- Because it would take a long time to canonize "foo" into- -- "foo <foo@bar.baz>" once per patch, the code below- -- generates a list [(count, canonized name)].- map (length &&& (canonizeAuthor spellings . head)) $- group $ sort authors--canonizeAuthor :: [Spelling] -> String -> String-canonizeAuthor spells author = getName canonicals- where- getName [] = author- getName ((Spelling name email _):_) = name ++ " <" ++ email ++ ">"- canonicals = filter (ismatch author) spells- ismatch s (Spelling _ mail regexps) =- s `correspondsTo` mail || any (s `contains_regex`) regexps- contains_regex a r = isJust $ matchRegex r a- correspondsTo a b = lower b `isInfixOf` lower a- lower = map toLower--compiledAuthorSpellings :: [DarcsFlag] -> IO [Spelling]-compiledAuthorSpellings opts = do- let as_file = ".authorspellings"- contents <- (Ratified.readFile -- never unlinked from within darcs- as_file `catch` (\(_ :: IOException) -> return ""))- let parse_results = map (parse sentence as_file) $ lines contents- clean 1 parse_results- where- clean :: Int -> [Either ParseError ParsedLine] -> IO [Spelling]- clean _ [] = return []- -- print parse error- clean n ((Left err):xs) = do- let npos = setSourceLine (errorPos err) n- putWarning opts . text . show $ setErrorPos npos err- clean (n+1) xs- -- skip blank line- clean n ((Right Nothing):xs) = clean (n+1) xs- -- unwrap Spelling- clean n ((Right (Just a):xs)) = do- as <- clean (n+1) xs- return (a:as)--------------- PARSERS--sentence :: Parser ParsedLine-sentence = spaces >> (comment <|> blank <|> addressline)- where- comment = string "--" >> return Nothing- blank = eof >> return Nothing--addressline :: Parser ParsedLine-addressline = do- name <- canonicalName <?> "Canonical name"- addr <- between (char '<') (char '>') (many1 (noneOf ">")) <?> "Address"- spaces- rest <- option [] (char ',' >> regexp `sepBy` char ',') <?> "List of regexps"- return $ Just $ Spelling (strip name) addr (compile rest)- where- strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse- makeRegex s = mkRegexWithOpts s True False- compile = map makeRegex . filter (not . null) . map strip--regexp :: Parser String-regexp = many1 p <?> "Regular expression"- where p = try (string "\\," >> return ',')- <|> noneOf ","--canonicalName :: Parser String-canonicalName = many1 p- where p = try (string "\\," >> return ',')- <|> noneOf ",<"-
− src/Darcs/Commands/ShowBug.hs
@@ -1,51 +0,0 @@--- Copyright (C) 2007 Eric Kow------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.ShowBug ( showBug ) where--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, workingRepoDir )-import Darcs.Repository ( findRepository )-#include "impossible.h"--showBugDescription :: String-showBugDescription = "Simulate a run-time failure."--showBugHelp :: String-showBugHelp =- "Show bug can be used to see what darcs would show you if you encountered.\n"- ++"a bug in darcs.\n"--showBug :: DarcsCommand-showBug = DarcsCommand {commandProgramName = "darcs",- commandName = "bug",- commandHelp = showBugHelp,- commandDescription = showBugDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = showBugCmd,- commandPrereq = findRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [workingRepoDir]}--showBugCmd :: [DarcsFlag] -> [String] -> IO ()-showBugCmd _ _ = bug "This is actually a fake bug in darcs."-
− src/Darcs/Commands/ShowContents.hs
@@ -1,90 +0,0 @@--- Copyright (C) 2007 Eric Kow------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Commands.ShowContents ( showContents ) where--import Control.Monad ( filterM, forM_, forM, unless )-import System.IO ( stdout )--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, matchOne,- workingRepoDir, fixSubPaths )-import Darcs.RepoPath ( sp2fn, toFilePath )-import Darcs.Patch.FileName( FileName, fp2fn )-import Darcs.Patch.ApplyMonad ( withFiles )-import Darcs.Match ( haveNonrangeMatch, applyInvToMatcher, nonrangeMatcher- , InclusiveOrExclusive(..), matchExists, applyNInv- , hasIndexRange )-import Darcs.Repository ( withRepository, RepoJob(..), findRepository, readRepo, readRecorded )-import qualified Storage.Hashed.Monad as HSM-import Storage.Hashed.AnchoredPath( floatPath, anchorPath )--showContentsDescription :: String-showContentsDescription = "Outputs a specific version of a file."--showContentsHelp :: String-showContentsHelp =- "Show contents can be used to display an earlier version of some file(s).\n"++- "If you give show contents no version arguments, it displays the recorded\n"++- "version of the file(s).\n"--showContents :: DarcsCommand-showContents = DarcsCommand {commandProgramName = "darcs",- commandName = "contents",- commandHelp = showContentsHelp,- commandDescription = showContentsDescription,- commandExtraArgs = -1,- commandExtraArgHelp- = ["[FILE]..."],- commandCommand = showContentsCmd,- commandPrereq = findRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [matchOne, workingRepoDir]}--showContentsCmd :: [DarcsFlag] -> [String] -> IO ()-showContentsCmd _ [] = fail "show contents needs at least one argument."-showContentsCmd opts args = withRepository opts $ RepoJob $ \repository -> do- path_list <- map sp2fn `fmap` fixSubPaths opts args- pristine <- readRecorded repository- unapply <- if haveNonrangeMatch opts- then do- patchset <- readRepo repository- case nonrangeMatcher opts of- -- Index cannot be a Matcher, so handle it manually.- Nothing -> case hasIndexRange opts of- Just (n, m) | n == m -> return $ applyNInv (n-1) patchset- _ -> fail "Couldn't obtain a valid matcher."- Just m -> do- unless (matchExists m patchset) $- fail $ "Couldn't match pattern " ++ show m- return $ applyInvToMatcher Exclusive m patchset- else return (return ())- let dump :: HSM.TreeIO [(FileName, B.ByteString)]- dump = do- let floatedPaths = map (floatPath . toFilePath) path_list- okpaths <- filterM HSM.fileExists floatedPaths- forM okpaths $ \f -> do- content <- (B.concat . BL.toChunks) `fmap` HSM.readFile f- return (fp2fn $ ("./" ++) $ anchorPath "" f, content)- files <- flip withFiles unapply `fmap` fst- `fmap` HSM.virtualTreeIO dump pristine- forM_ files $ \(_, f) -> B.hPut stdout f
− src/Darcs/Commands/ShowFiles.hs
@@ -1,133 +0,0 @@--- Copyright (C) 2005 Florian Weimer------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}-#include "gadts.h"-module Darcs.Commands.ShowFiles ( showFiles- , manifestCmd, toListManifest -- for alias- , manifest- ) where-import Darcs.Arguments ( DarcsFlag(..), workingRepoDir,- files, directories, pending, nullFlag, matchOne )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Repository ( Repository, amInRepository, withRepository,- RepoJob(..) )-import Darcs.Patch ( RepoPatch )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Repository.State ( readRecorded, readRecordedAndPending )-import Storage.Hashed.Tree( Tree, TreeItem(..), list, expand )-import Storage.Hashed.AnchoredPath( anchorPath )-import Storage.Hashed.Plain( readPlainTree )-import System.FilePath ( splitDirectories )--import Data.List( isPrefixOf )--import Darcs.Match ( haveNonrangeMatch, getNonrangeMatch )-import Darcs.Lock ( withDelayedDir )-showFilesDescription :: String-showFilesDescription = "Show version-controlled files in the working copy."--showFilesHelp :: String-showFilesHelp =- "The `darcs show files' command lists those files and directories in\n" ++- "the working tree that are under version control. This command is\n" ++- "primarily for scripting purposes; end users will probably want `darcs\n" ++- "whatsnew --summary'.\n" ++- "\n" ++- "A file is `pending' if it has been added but not recorded. By\n" ++- "default, pending files (and directories) are listed; the --no-pending\n" ++- "option prevents this.\n" ++- "\n" ++- "By default `darcs show files' lists both files and directories, but\n" ++- "the alias `darcs show manifest' only lists files. The --files,\n" ++- "--directories, --no-files and --no-directories modify this behaviour.\n" ++- "\n" ++- "By default entries are one-per-line (i.e. newline separated). This\n" ++- "can cause problems if the files themselves contain newlines or other\n" ++- "control characters. To get aroudn this, the --null option uses the\n" ++- "null character instead. The script interpreting output from this\n" ++- "command needs to understand this idiom; `xargs -0' is such a command.\n" ++- "\n" ++- "For example, to list version-controlled files by size:\n" ++- "\n" ++- " darcs show files -0 | xargs -0 ls -ldS\n"--showFiles :: DarcsCommand-showFiles = DarcsCommand {- commandProgramName = "darcs",- commandName = "files",- commandHelp = showFilesHelp,- commandDescription = showFilesDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["[FILE or DIRECTORY]..."],- commandCommand = manifestCmd toListFiles,- commandPrereq = amInRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [files, directories, pending, nullFlag, matchOne,- workingRepoDir] }--toListFiles, toListManifest :: [DarcsFlag] -> Tree m -> [FilePath]-toListFiles opts = filesDirs (NoFiles `notElem` opts) (NoDirectories `notElem` opts)-toListManifest opts = filesDirs (NoFiles `notElem` opts) (Directories `elem` opts)--filesDirs :: Bool -> Bool -> Tree m -> [FilePath]-filesDirs False False _ = []-filesDirs False True t = "." : [ anchorPath "." p | (p, SubTree _) <- list t ]-filesDirs True False t = [ anchorPath "." p | (p, File _) <- list t ]-filesDirs True True t = "." : (map (anchorPath "." . fst) $ list t)--manifest :: [DarcsFlag] -> [String] -> IO [FilePath]-manifest = manifestHelper toListFiles--manifestCmd :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> [DarcsFlag] -> [String] -> IO ()-manifestCmd to_list opts argList = do- mapM_ output =<< manifestHelper to_list opts argList- where- output_null name = do { putStr name ; putChar '\0' }- output = if NullFlag `elem` opts then output_null else putStrLn--manifestHelper :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> [DarcsFlag] -> [String] -> IO [FilePath]-manifestHelper to_list opts argList = do- list' <- (to_list opts) `fmap` withRepository opts (RepoJob myslurp)- case argList of- [] -> return list'- prefixes -> return (onlysubdirs prefixes list')- where myslurp :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u r) -> IO (Tree IO)- myslurp r = do let fRevisioned = haveNonrangeMatch opts- fPending = Pending `elem` opts- fNoPending = NoPending `elem` opts- -- this covers all 8 options- expand =<< case (fRevisioned,fPending,fNoPending) of- (True,False,_) -> slurpRevision opts r- (True,True,_) -> error $ "can't mix revisioned and pending flags"- (False,False,True) -> readRecorded r- (False,_,False) -> readRecordedAndPending r -- pending is default- (False,True,True) -> error $ "can't mix pending and no-pending flags"- isParentDir a' b' =- let a = splitDirectories a'- b = splitDirectories b'- in (a `isPrefixOf` b) || (("." : a) `isPrefixOf` b)- onlysubdirs dirs = filter (\p -> any (`isParentDir` p) dirs)--slurpRevision :: (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> Repository p C(r u r) -> IO (Tree IO)-slurpRevision opts r = withDelayedDir "revisioned.showfiles" $ \_ -> do- getNonrangeMatch r opts- expand =<< readPlainTree "."-
− src/Darcs/Commands/ShowIndex.hs
@@ -1,84 +0,0 @@--- Copyright (C) 2009 Petr Rockai------ 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.--{-# LANGUAGE CPP #-}-#include "gadts.h"-module Darcs.Commands.ShowIndex ( showIndex- , showPristineCmd -- for alias- ) where-import Darcs.Arguments ( DarcsFlag(..), workingRepoDir,- files, directories, nullFlag )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Repository ( amInRepository, withRepository, RepoJob(..), readIndex )-import Darcs.Repository.State ( readRecorded )--import Storage.Hashed( floatPath )-import Storage.Hashed.Hash( encodeBase16, Hash( NoHash ) )-import Storage.Hashed.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) )-import Storage.Hashed.Index( updateIndex )-import Storage.Hashed.AnchoredPath( anchorPath )--import qualified Data.ByteString.Char8 as BS--showIndex :: DarcsCommand-showIndex = DarcsCommand {- commandProgramName = "darcs",- commandName = "index",- commandDescription = "Dump contents of working tree index.",- commandHelp =- "The `darcs show index' command lists all version-controlled files and " ++- "directories along with their hashes as stored in _darcs/index. " ++- "For files, the fields correspond to file size, sha256 of the current " ++- "file content and the filename.",- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = showIndexCmd,- commandPrereq = amInRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [files, directories, nullFlag, workingRepoDir] }--dump :: [DarcsFlag] -> Tree IO -> IO ()-dump opts tree = do- let line | NullFlag `elem` opts = \t -> putStr t >> putChar '\0'- | otherwise = putStrLn- output (p, i) = do- let hash = case itemHash i of- NoHash -> "(no hash available)"- h -> BS.unpack $ encodeBase16 h- path = anchorPath "" p- isdir = case i of- SubTree _ -> "/"- _ -> ""- line $ hash ++ " " ++ path ++ isdir- x <- expand tree- mapM_ output $ (floatPath ".", SubTree x) : list x--showIndexCmd :: [DarcsFlag] -> [String] -> IO ()-showIndexCmd opts _ = withRepository opts $ RepoJob $ \repo -> do- readIndex repo >>= updateIndex >>= dump opts--showPristineCmd :: [DarcsFlag] -> [String] -> IO ()-showPristineCmd opts _ = withRepository opts $ RepoJob $ \repo -> do- readRecorded repo >>= dump opts-
− src/Darcs/Commands/ShowRepo.hs
@@ -1,149 +0,0 @@--- Copyright (C) 2007 Kevin Quick------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}-#include "gadts.h"-module Darcs.Commands.ShowRepo ( showRepo ) where--import Data.Char ( toLower, isSpace )-import Data.List ( intercalate )-import Control.Monad ( when, unless )-import Text.Html ( tag, stringToHtml )-import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, files, xmloutput )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Repository ( withRepository, RepoJob(..), amInRepository, readRepo )-import Darcs.Repository.Internal ( Repository(..), RepoType(..) )-import Darcs.Repository.Format ( RepoFormat(..) )-import Darcs.Repository.Prefs ( getPreflist )-import Darcs.Repository.Motd ( getMotd )-import Darcs.Patch ( RepoPatch )-import Darcs.Patch.Set ( newset2RL )-import Darcs.Witnesses.Ordered ( lengthRL )-import qualified Data.ByteString.Char8 as BC (unpack)-import Darcs.Patch.Apply( ApplyState )-import Storage.Hashed.Tree ( Tree )--showRepoHelp :: String-showRepoHelp =- "The `darcs show repo' command displays statistics about the current\n" ++- "repository, allowing third-party scripts to access this information\n" ++- "without inspecting _darcs directly (and without breaking when the\n" ++- "_darcs format changes).\n" ++- "\n" ++- "By default, the number of patches is shown. If this data isn't\n" ++- "needed, use --no-files to accelerate this command from O(n) to O(1).\n" ++- "\n" ++- "By default, output is in a human-readable format. The --xml-output\n" ++- "option can be used to generate output for machine postprocessing.\n"--showRepoDescription :: String-showRepoDescription = "Show repository summary information"--showRepo :: DarcsCommand-showRepo = DarcsCommand { commandProgramName = "darcs",- commandName = "repo",- commandHelp = showRepoHelp,- commandDescription = showRepoDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = repoCmd,- commandPrereq = amInRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [workingRepoDir, files, xmloutput] }--repoCmd :: [DarcsFlag] -> [String] -> IO ()-repoCmd opts _ = let put_mode = if XMLOutput `elem` opts then showInfoXML else showInfoUsr- in withRepository opts $ RepoJob $ \repository -> actuallyShowRepo (putInfo put_mode) repository---- Some convenience functions to output a labelled text string or an--- XML tag + value (same API). If no value, output is suppressed--- entirely. Borrow some help from Text.Html to perform XML output.--type ShowInfo = String -> String -> String--showInfoXML :: ShowInfo-showInfoXML t i = show $ tag (safeTag t) $ stringToHtml i--safeTag :: String -> String-safeTag [] = []-safeTag (' ':cs) = safeTag cs-safeTag ('#':cs) = "num_" ++ (safeTag cs)-safeTag (c:cs) = toLower c : safeTag cs---- labelled strings: labels are right-aligned at 14 characters;--- subsequent lines in multi-line output are indented accordingly.-showInfoUsr :: ShowInfo-showInfoUsr t i = (replicate (14 - length(t)) ' ') ++ t ++ ": " ++- intercalate ('\n' : (replicate 16 ' ')) (lines i) ++ "\n"--type PutInfo = String -> String -> IO ()-putInfo :: ShowInfo -> PutInfo-putInfo m t i = unless (null i) (putStr $ m t i)---- Primary show-repo operation. Determines ordering of output for--- sub-displays. The `out' argument is one of the above operations to--- output a labelled text string or an XML tag and contained value.--actuallyShowRepo :: (RepoPatch p, ApplyState p ~ Tree)- => PutInfo -> Repository p C(r u r) -> IO ()-actuallyShowRepo out r@(Repo loc opts rf rt) = do- when (XMLOutput `elem` opts) (putStr "<repository>\n")- showRepoType out rt- when (Verbose `elem` opts) (out "Show" $ show r)- showRepoFormat out rf- out "Root" loc- showRepoAux out rt- showRepoPrefs out- unless (NoFiles `elem` opts) (numPatches r >>= (out "Num Patches" . show ))- showRepoMOTD out r- when (XMLOutput `elem` opts) (putStr "</repository>\n")---- Most of the actual elements being displayed are part of the Show--- class; that's fine for a Haskeller, but not for the common user, so--- the routines below work to provide more human-readable information--- regarding the repository elements.--showRepoType :: PutInfo -> RepoType p -> IO ()-showRepoType out (DarcsRepository _ _) = out "Type" "darcs"--showRepoFormat :: PutInfo -> RepoFormat -> IO ()-showRepoFormat out (RF rf) = out "Format" $- intercalate ", " (map (intercalate "|" . map BC.unpack) rf)--showRepoAux :: PutInfo -> RepoType p -> IO ()-showRepoAux out (DarcsRepository pris cs) =- do out "Pristine" $ show pris- out "Cache" $ intercalate ", " $ lines $ show cs---showRepoPrefs :: PutInfo -> IO ()-showRepoPrefs out = do- getPreflist "prefs" >>= mapM_ prefOut- getPreflist "author" >>= out "Author" . unlines- getPreflist "defaultrepo" >>= out "Default Remote" . unlines- where prefOut = uncurry out . (\(p,v) -> (p++" Pref", (dropWhile isSpace v))) . break isSpace--showRepoMOTD :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO ()-showRepoMOTD out (Repo loc _ _ _) = getMotd loc >>= out "MOTD" . BC.unpack---- Support routines to provide information used by the PutInfo operations above.--numPatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u r) -> IO Int-numPatches r = readRepo r >>= (return . lengthRL . newset2RL)-
− src/Darcs/Commands/ShowTags.hs
@@ -1,82 +0,0 @@--- Copyright (C) 2007 Florian Weimer------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Commands.ShowTags ( showTags ) where-import Darcs.Arguments ( DarcsFlag(..), possiblyRemoteRepoDir, getRepourl )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Patch.PatchInfoAnd ( info )-import Darcs.Repository ( findRepository, readRepo, withRepositoryDirectory, RepoJob(..) )-import Darcs.Patch.Info ( piTag )-import Darcs.Patch.Set ( newset2RL )-import Darcs.Witnesses.Ordered ( mapRL )-import Data.Maybe ( fromMaybe )-import System.IO ( stderr, hPutStrLn )--- import Printer ( renderPS )--showTagsDescription :: String-showTagsDescription = "Show all tags in the repository."--showTagsHelp :: String-showTagsHelp =- "The tags command writes a list of all tags in the repository to standard\n"++- "output.\n" ++- "\n" ++- "Tab characters (ASCII character 9) in tag names are changed to spaces\n" ++- "for better interoperability with shell tools. A warning is printed if\n" ++- "this happens."--showTags :: DarcsCommand-showTags = DarcsCommand {- commandProgramName = "darcs",- commandName = "tags",- commandHelp = showTagsHelp,- commandDescription = showTagsDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = tagsCmd,- commandPrereq = findRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [possiblyRemoteRepoDir] }--tagsCmd :: [DarcsFlag] -> [String] -> IO ()-tagsCmd opts _ =- let repodir = fromMaybe "." (getRepourl opts) in- withRepositoryDirectory opts repodir $ RepoJob $ \repository -> do- patches <- readRepo repository- sequence_ $ mapRL process $ newset2RL patches- where process hp =- case piTag $ info hp of- Just t -> do- t' <- normalize t t False- putStrLn t'- Nothing -> return ()- normalize :: String -> String -> Bool -> IO String- normalize _ [] _ = return []- normalize t (x : xs) flag =- if x == '\t' then do- if flag- then return ()- else hPutStrLn stderr- ("warning: tag with TAB character: " ++ t)- rest <- (normalize t xs True)- return $ ' ' : rest- else do- rest <- (normalize t xs flag)- return $ x : rest-
− src/Darcs/Commands/Tag.hs
@@ -1,123 +0,0 @@--- Copyright (C) 2003-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Commands.Tag ( tag ) where-import System.Directory ( removeFile )-import Control.Monad ( when )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( nocompress, umaskOption, patchnameOption, author,- pipeInteractive, askLongComment,- workingRepoDir, getAuthor )-import Darcs.Patch.PatchInfoAnd ( n2pia )-import Darcs.Repository ( amInHashedRepository, withRepoLock, Repository, RepoJob(..), readRepo,- tentativelyAddPatch, finalizeRepositoryChanges,- )-import Darcs.Patch ( infopatch, adddeps, Patchy, PrimPatch, PrimOf )-import Darcs.Patch.Info ( patchinfo )-import Darcs.Patch.Depends ( getTagsRight )-import Darcs.Commands.Record ( getDate, getLog )-import Darcs.Witnesses.Ordered ( FL(..) )-import Darcs.Lock ( worldReadableTemp )-import Darcs.Flags ( DarcsFlag(..), compression )-import System.IO ( hPutStr, stderr )--#include "gadts.h"--tagDescription :: String-tagDescription = "Name the current repository state for future reference."--tagHelp :: String-tagHelp =- "The `darcs tag' command names the current repository state, so that it\n" ++- "can easily be referred to later. Every `important' state should be\n" ++- "tagged; in particular it is good practice to tag each stable release\n" ++- "with a number or codename. Advice on release numbering can be found\n" ++- "at http://producingoss.com/en/development-cycle.html.\n" ++- "\n" ++- "To reproduce the state of a repository `R' as at tag `t', use the\n" ++- "command `darcs get --tag t R'. The command `darcs show tags' lists\n" ++- "all tags in the current repository.\n" ++- "\n" ++- "Tagging also provides significant performance benefits: when Darcs\n" ++- "reaches a shared tag that depends on all antecedent patches, it can\n" ++- "simply stop processing.\n" ++- "\n" ++- "Like normal patches, a tag has a name, an author, a timestamp and an\n" ++- "optional long description, but it does not change the working tree.\n" ++- "A tag can have any name, but it is generally best to pick a naming\n" ++- "scheme and stick to it.\n" ++- "\n" ++- "The `darcs tag' command accepts the --pipe option, which behaves as\n" ++- "described in `darcs record'.\n"--tag :: DarcsCommand-tag = DarcsCommand {commandProgramName = "darcs",- commandName = "tag",- commandHelp = tagHelp,- commandDescription = tagDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["[TAGNAME]"],- commandCommand = tagCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [nocompress,umaskOption],- commandBasicOptions = [patchnameOption, author,- pipeInteractive,- askLongComment,- workingRepoDir]}--tagCmd :: [DarcsFlag] -> [String] -> IO ()-tagCmd opts args = withRepoLock opts $ RepoJob $ \(repository :: Repository p C(r u r)) -> do- date <- getDate opts- the_author <- getAuthor opts- deps <- getTagsRight `fmap` readRepo repository- (name, long_comment, mlogf) <- get_name_log (NilFL :: FL (PrimOf p) C(a a)) opts args- myinfo <- patchinfo date name the_author long_comment- let mypatch = infopatch myinfo NilFL--- Warning: A do-notation statement discarded a result of type Darcs.Repository.InternalTypes.Repository p r u r.- _ <- tentativelyAddPatch repository (compression opts) $ n2pia $ adddeps mypatch deps- finalizeRepositoryChanges repository- maybe (return ()) removeFile mlogf- putStrLn $ "Finished tagging patch '"++name++"'"- where get_name_log ::(Patchy prim, PrimPatch prim) => FL prim C(a a) -> [DarcsFlag] -> [String] -> IO (String, [String], Maybe String)- get_name_log nilFL o a- = do let o2 = if null a then o else (add_patch_name o (unwords a))- (name, comment, mlogf) <- getLog o2 Nothing (worldReadableTemp "darcs-tag") nilFL- when (length name < 2) $ hPutStr stderr $- "Do you really want to tag '"- ++name++"'? If not type: darcs obliterate --last=1\n"- return ("TAG " ++ name, comment, mlogf)- add_patch_name :: [DarcsFlag] -> String -> [DarcsFlag]- add_patch_name o a| has_patch_name o = o- | otherwise = [PatchName a] ++ o- has_patch_name (PatchName _:_) = True- has_patch_name (_:fs) = has_patch_name fs- has_patch_name [] = False---- This may be useful for developers, but users don't care about--- internals:------ A tagged version automatically depends on all patches in the--- repository. This allows you to later reproduce precisely that--- version. The tag does this by depending on all patches in the--- repository, except for those which are depended upon by other tags--- already in the repository. In the common case of a sequential--- series of tags, this means that the tag depends on all patches--- since the last tag, plus that tag itself.-
− src/Darcs/Commands/Test.hs
@@ -1,70 +0,0 @@--- Copyright (C) 2002-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- 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 )-import Darcs.Arguments ( DarcsFlag(Test)- , leaveTestDir- , workingRepoDir- )-import Darcs.Repository ( Repository, amInHashedRepository, withRepository,- testRecorded, RepoJob(..) )-import Darcs.Patch ( RepoPatch )-import Darcs.Patch.Apply( ApplyState )-import Printer ( text )-import Storage.Hashed.Tree( Tree )--#include "gadts.h"--testDescription :: String-testDescription = "Run regression test."--testHelp :: String-testHelp =- "If a regression test is defined (see `darcs setpref') it will be run.\n"--test :: DarcsCommand-test = DarcsCommand {commandProgramName = "darcs",- commandName = "test",- commandHelp = testHelp,- commandDescription = testDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = testCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [ leaveTestDir,- workingRepoDir- ]}--testCmd :: [DarcsFlag] -> [String] -> IO ()-testCmd opts _ = withRepository (Test:opts) (RepoJob (test' opts))--test'- :: forall p C(r u t) . (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -> Repository p C(r u t) -> IO ()-test' opts repository = do- putInfo opts $ text "Running test on current repository state."- rc <- testRecorded repository- exitWith rc
− src/Darcs/Commands/TrackDown.hs
@@ -1,194 +0,0 @@--- Copyright (C) 2002-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Commands.TrackDown ( trackdown ) where-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 )-import Darcs.Arguments ( DarcsFlag(SetScriptsExecutable, Bisect), workingRepoDir, bisect,- setScriptsExecutableOption, makeScriptsExecutable )-import Darcs.Patch.PatchInfoAnd ( hopefully )-import Darcs.Repository ( amInHashedRepository, readRepo, withRepoReadLock, RepoJob(..), withRecorded,- setScriptsExecutable )-import Darcs.Witnesses.Ordered ( RL(..), (:<)(..), (+<+),- reverseRL, splitAtRL, lengthRL, mapRL, mapFL, mapRL_RL )-import Darcs.Patch.Conflict ( Conflict )-import Darcs.Patch.FileHunk ( IsHunk )-import Darcs.Patch.ApplyMonad ( ApplyMonad )-import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Patchy ( Patchy, Invert, Apply, ShowPatch )-import Darcs.Patch ( RepoPatch, Named, description, apply, invert )-import Darcs.Patch.Set ( newset2RL )-import Printer ( putDocLn )-import Darcs.Test ( getTest )-import Darcs.Lock ( withTempDir )-import Storage.Hashed.Tree( Tree )--#include "gadts.h"--trackdownDescription :: String-trackdownDescription = "Locate the most recent version lacking an error."--trackdownHelp :: String-trackdownHelp =- "Trackdown tries to find the most recent version in the repository which\n"++- "passes a test. Given no arguments, it uses the default repository test.\n"++- "Given one argument, it treats it as a test command. Given two arguments,\n"++- "the first is an initialization command with is run only once, and the\n"++- "second is the test command.\n\n"++- "Without the --bisect option, trackdown does linear search starting from head,\n"++- "and moving away from head. With the --bisect option, it does binary search.\n\n"++- "Under the assumption that failure is monotonous, trackdown produces\n"++- "the same result with and without --bisect. (Monotonous means that when\n"++- "moving away from head, the test result changes only once from \"fail\" to \"ok\".)\n"++- "If failure is not monotonous, any one of the patches that break the test is\n"++- "found at random."--trackdown :: DarcsCommand-trackdown = DarcsCommand {commandProgramName = "darcs",- commandName = "trackdown",- commandHelp = trackdownHelp,- commandDescription = trackdownDescription,- commandExtraArgs = -1,- commandExtraArgHelp = ["[[INITIALIZATION]",- "COMMAND]"],- commandCommand = trackdownCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [setScriptsExecutableOption],- commandBasicOptions = [workingRepoDir, bisect]}--trackdownCmd :: [DarcsFlag] -> [String] -> IO ()-trackdownCmd opts args = withRepoReadLock opts $ RepoJob $ \repository -> do- patches <- readRepo repository- (init,test) <- case args of- [] ->- do t <- getTest opts- return (return ExitSuccess, t)- [cmd] ->- do putStrLn $ "Tracking down command:\n"++cmd- return $ (return ExitSuccess, system cmd)- [init,cmd] ->- do putStrLn $ "Initializing with command:\n"++init- putStrLn $ "Tracking down command:\n"++cmd- return $ (system init, system cmd)- _ -> fail "Trackdown expects zero to two arguments."- withRecorded repository (withTempDir "trackingdown") $ \_ -> do- when (SetScriptsExecutable `elem` opts) setScriptsExecutable- _ <- init- (if Bisect `elem` opts- then trackBisect- else trackNextLinear) opts test (mapRL_RL hopefully . newset2RL $ patches)---- | linear search (without --bisect)-trackNextLinear :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)- => [DarcsFlag] -> IO ExitCode -> RL (Named p) C(x y) -> IO ()-trackNextLinear opts test (p:<:ps) = do- test_result <- test- if test_result == ExitSuccess- then putStrLn "Success!"- 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- hFlush stdout- trackNextLinear opts test ps-trackNextLinear _opts test NilRL = do- test_result <- test- if test_result == ExitSuccess- then putStrLn "Success!"- else putStrLn "Noone passed the test!"---- | binary search (with --bisect)-trackBisect :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p))- => [DarcsFlag] -> IO ExitCode -> RL p C(x y) -> IO ()-trackBisect _ test NilRL = do- test_result <- test- if test_result == ExitSuccess- then putStrLn "Success!"- else putStrLn "Noone passed the test!"-trackBisect opts test ps = do- test_result <- test- if test_result == ExitSuccess- then putStrLn ("Test does not fail on head.")- else trackNextBisect opts curr_prog test BisectRight (patchTreeFromRL ps)- where- curr_prog = (1, 1 + round ((logBase 2 $ fromIntegral $ lengthRL ps) :: Double)) :: (Int,Int)---- | Bisect Patch Tree-data PatchTree p C(x y) where- Leaf :: p C(x y) -> PatchTree p C(x y)- Fork :: PatchTree p C(y z) -> PatchTree p C(x y) -> PatchTree p C(x z)---- | Direction of Bisect trackdown-data BisectDir = BisectLeft | BisectRight deriving Show---- | Progress of Bisect-type BisectState = (Int, Int)---- | Create Bisect PatchTree from the RL-patchTreeFromRL :: (Patchy p) => RL p C(x y) -> PatchTree p C(x y)-patchTreeFromRL (l :<: NilRL) = Leaf l-patchTreeFromRL xs = case splitAtRL (lengthRL xs `div` 2) xs of- (l :< r) -> Fork (patchTreeFromRL l) (patchTreeFromRL r)---- | Convert PatchTree back to RL-patchTree2RL :: (Patchy p) => PatchTree p C(x y) -> RL p C(x y)-patchTree2RL (Leaf p) = p :<: NilRL-patchTree2RL (Fork l r) = (patchTree2RL l) +<+ (patchTree2RL r)---- | Iterate the Patch Tree-trackNextBisect :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p))- => [DarcsFlag] -> BisectState -> IO ExitCode -> BisectDir -> PatchTree p C(x y) -> IO ()-trackNextBisect opts (dnow, dtotal) test dir (Fork l r) = do- putStr ("Trying " ++ show dnow ++ "/" ++ show dtotal ++ " sequences...\n")- hFlush stdout- case dir of- BisectRight -> jumpHalfOnRight opts l -- move in temporary repo- BisectLeft -> jumpHalfOnLeft opts r -- within given direction- test_result <- test -- execute test on repo- case test_result of- ExitSuccess -> trackNextBisect opts (dnow+1, dtotal) test BisectLeft l -- continue left (to the present)- _ -> trackNextBisect opts (dnow+1, dtotal) test BisectRight r -- continue right (to the past)-trackNextBisect _ _ _ _ (Leaf p) = do- putStrLn ("Last recent patch that fails the test (assuming monotony in the given range):")- putDocLn (description p)--jumpHalfOnRight :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p)) => [DarcsFlag] -> PatchTree p C(x y) -> IO ()-jumpHalfOnRight opts l = unapplyRL ps >> makeScriptsExecutable opts ps- where ps = patchTree2RL l--jumpHalfOnLeft :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p)) => [DarcsFlag] -> PatchTree p C(x y) -> IO ()-jumpHalfOnLeft opts r = applyRL p >> makeScriptsExecutable opts p- where p = patchTree2RL r--applyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad IO (ApplyState p)) => RL p C(x y) -> IO ()-applyRL patches = sequence_ (mapFL safeApply (reverseRL $ patches))--unapplyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad IO (ApplyState p)) => RL p C(x y) -> IO ()-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 :: IOException) -> fail ("Bad patch (during trackdown --bisect):\n" ++ show msg))-
− src/Darcs/Commands/TransferMode.hs
@@ -1,86 +0,0 @@--- Copyright (C) 2008 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, PatternGuards #-}---- The pragma above is only for pattern guards.-module Darcs.Commands.TransferMode ( transferMode ) where--import Prelude hiding ( catch )-import Control.Exception.Extensible ( catch )-import System.IO ( stdout, hFlush )--import Darcs.Utils ( withCurrentDirectory, prettyException )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, workingRepoDir )-import Darcs.Repository ( amInRepository )-import Progress ( setProgressMode )-import Darcs.Global ( darcsdir )--import qualified Data.ByteString as B (hPut, readFile, length, ByteString)--transferModeDescription :: String-transferModeDescription = "Internal command for efficient ssh transfers."--transferModeHelp :: String-transferModeHelp =- "When pulling from or pushing to a remote repository over ssh, if both\n" ++- "the local and remote ends have Darcs 2, the `transfer-mode' command\n" ++- "will be invoked on the remote end. This allows Darcs to intelligently\n" ++- "transfer information over a single ssh connection.\n" ++- "\n" ++- "If either end runs Darcs 1, a separate ssh connection will be created\n" ++- "for each transfer. As well as being less efficient, this means users\n" ++- "who do not run ssh-agent will be prompted for the ssh password tens or\n" ++- "hundreds of times!\n"--transferMode :: DarcsCommand-transferMode = DarcsCommand {commandProgramName = "darcs",- commandName = "transfer-mode",- commandHelp = transferModeHelp,- commandDescription = transferModeDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandGetArgPossibilities = return [],- commandCommand = transferModeCmd,- commandPrereq = amInRepository,- commandArgdefaults = nodefaults,- commandAdvancedOptions = [],- commandBasicOptions = [workingRepoDir]}--transferModeCmd :: [DarcsFlag] -> [String] -> IO ()-transferModeCmd _ _ = do setProgressMode False- putStrLn "Hello user, I am darcs transfer mode"- hFlush stdout- withCurrentDirectory darcsdir $ transfer--transfer :: IO ()-transfer = do 'g':'e':'t':' ':fn <- getLine- x <- readfile fn- case x of- Right c -> do putStrLn $ "got " ++ fn- print $ B.length c- B.hPut stdout c- hFlush stdout- Left e -> do putStrLn $ "error " ++ fn- print e- hFlush stdout- transfer--readfile :: String -> IO (Either String B.ByteString)-readfile fn = (Right `fmap` B.readFile fn) `catch` (\e -> return $ Left (prettyException e))-
− src/Darcs/Commands/Unrecord.hs
@@ -1,259 +0,0 @@--- Copyright (C) 2002-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# 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 )--import Printer ( text, putDoc )-import English ( presentParticiple )-import Darcs.Patch.PatchInfoAnd ( hopefully, patchDesc )-import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias,- putVerbose )-import Darcs.Arguments ( DarcsFlag,- output, outputAutoName, getOutput,- workingRepoDir, nocompress, setEnvDarcsPatches,- matchSeveralOrLast, depsSel,- ignoretimes,- allInteractive, umaskOption, summary, dryRun,- printDryRunMessageAndExit, changesReverse- )-import Darcs.Flags ( doReverse, UseIndex(..), ScanKnown(..), compression )-import Darcs.Match ( firstMatch, matchFirstPatchset, matchAPatchread )-import Darcs.Repository ( PatchInfoAnd, withGutsOf,- withRepoLock, RepoJob(..),- tentativelyRemovePatches, finalizeRepositoryChanges,- tentativelyAddToPending,- applyToWorking,- readRepo, amInHashedRepository,- invalidateIndex, unrecordedChanges )-import Darcs.Patch ( RepoPatch, invert, commute, effect )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), appendPSFL )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Witnesses.Ordered ( RL(..), (:>)(..), (+<+),- mapFL_FL, nullFL,- reverseRL, mapRL, FL(..) )-import Darcs.Patch.Depends ( findCommonWithThem )-import Darcs.SelectChanges ( selectChanges- , WhichChanges(..)- , selectionContext, runSelection )-import Darcs.Patch.Bundle ( makeBundleN, patchFilename, contextPatches )-import Progress ( debugMessage )-import Darcs.Witnesses.Sealed ( Sealed(..) )-import Darcs.RepoPath( useAbsoluteOrStd )-import Darcs.Lock( writeDocBinFile )-import Storage.Hashed.Tree( Tree )-#include "gadts.h"--unrecordDescription :: String-unrecordDescription =- "Remove recorded patches without changing the working copy."--unrecordHelp :: String-unrecordHelp =- "Unrecord does the opposite of record in that it makes the changes from\n"++- "patches active changes again which you may record or revert later. The\n"++- "working copy itself will not change.\n"++- "Beware that you should not use this command if you are going to\n"++- "re-record the changes in any way and there is a possibility that\n"++- "another user may have already pulled the patch.\n"--unrecord :: DarcsCommand-unrecord = DarcsCommand {commandProgramName = "darcs",- commandName = "unrecord",- commandHelp = unrecordHelp,- commandDescription = unrecordDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = unrecordCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions =- [nocompress,umaskOption,changesReverse],- commandBasicOptions = [matchSeveralOrLast,- depsSel,- allInteractive,- workingRepoDir]}--unrecordCmd :: [DarcsFlag] -> [String] -> IO ()-unrecordCmd opts _ = withRepoLock opts $ RepoJob $ \repository -> do- allpatches <- readRepo repository- (_ :> patches) <- return $ if firstMatch opts- then getLastPatches opts allpatches- else matchingHead opts allpatches- let context = selectionContext "unrecord" opts Nothing Nothing- selector = if doReverse opts- then selectChanges Last- else selectChanges LastReversed- (_ :> to_unrecord) <- runSelection (selector patches) context- when (nullFL to_unrecord) $ do putStrLn "No patches selected!"- exitWith ExitSuccess- putVerbose opts $ text- "About to write out (potentially) modified patches..."- setEnvDarcsPatches to_unrecord- invalidateIndex repository--- Warning: A do-notation statement discarded a result of type Darcs.Repository.InternalTypes.Repository p r u z.- withGutsOf repository $ do _ <- tentativelyRemovePatches repository (compression opts) to_unrecord- finalizeRepositoryChanges repository- putStrLn "Finished unrecording."--getLastPatches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(Origin r)- -> ((PatchSet p) :> (FL (PatchInfoAnd p))) C(Origin r)-getLastPatches opts ps =- case matchFirstPatchset opts ps of- Sealed p1s -> findCommonWithThem ps p1s--unpullDescription :: String-unpullDescription =- "Opposite of pull; unsafe if patch is not in remote repository."--unpullHelp :: String-unpullHelp =- "Unpull completely removes recorded patches from your local repository.\n"++- "The changes will be undone in your working copy and the patches will not be\n"++- "shown in your changes list anymore.\n"++- "Beware that if the patches are not still present in another repository you\n"++- "will lose precious code by unpulling!\n"--unpull :: DarcsCommand-unpull = (commandAlias "unpull" Nothing obliterate)- {commandHelp = unpullHelp,- commandDescription = unpullDescription,- commandCommand = unpullCmd}--unpullCmd :: [DarcsFlag] -> [String] -> IO ()-unpullCmd = genericObliterateCmd "unpull"---obliterateDescription :: String-obliterateDescription =- "Delete selected patches from the repository. (UNSAFE!)"--obliterateHelp :: String-obliterateHelp =- "Obliterate completely removes recorded patches from your local repository.\n"++- "The changes will be undone in your working copy and the patches will not be\n"++- "shown in your changes list anymore.\n"++- "Beware that you can lose precious code by obliterating!\n"--obliterate :: DarcsCommand-obliterate = DarcsCommand {commandProgramName = "darcs",- commandName = "obliterate",- commandHelp = obliterateHelp,- commandDescription = obliterateDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = obliterateCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [nocompress,ignoretimes,umaskOption, changesReverse],- commandBasicOptions = [matchSeveralOrLast,- depsSel,- allInteractive,- workingRepoDir,- summary,- output,- outputAutoName]++- dryRun}-obliterateCmd :: [DarcsFlag] -> [String] -> IO ()-obliterateCmd = genericObliterateCmd "obliterate"---- | genericObliterateCmd is the function that executes the "obliterate" and--- "unpull" commands.-genericObliterateCmd :: String -- ^ The name under which the command is invoked (@unpull@ or @obliterate@)- -> [DarcsFlag] -- ^ The flags given on the command line- -> [String] -- ^ Files given on the command line (unused)- -> IO ()-genericObliterateCmd cmdname opts _ = withRepoLock opts $ RepoJob $ \repository -> do- -- FIXME we may need to honour --ignore-times here, although this command- -- does not take that option (yet)- pend <- unrecordedChanges (UseIndex, ScanKnown) repository Nothing- allpatches <- readRepo repository- (auto_kept :> removal_candidates) <- return $- if firstMatch opts- then getLastPatches opts allpatches- else matchingHead opts allpatches- let- context = selectionContext cmdname opts Nothing Nothing- selector = if doReverse opts- then selectChanges Last- else selectChanges LastReversed- (kept :> removed) <- runSelection (selector removal_candidates) context- when (nullFL removed) $ do putStrLn "No patches selected!"- exitWith ExitSuccess- case commute (effect removed :> pend) of- Nothing -> fail $ "Can't "++ cmdname ++- " patch without reverting some unrecorded change."- Just (_ :> p_after_pending) -> do- printDryRunMessageAndExit "obliterate" opts removed- setEnvDarcsPatches removed- when (isJust $ getOutput opts "") $- savetoBundle opts (auto_kept `appendPSFL` kept) removed- invalidateIndex repository- withGutsOf repository $--- Warning: A do-notation statement discarded a result of type Darcs.Repository.InternalTypes.Repository p r u z.- do _ <- tentativelyRemovePatches repository (compression opts) removed- tentativelyAddToPending repository opts $ invert $ effect removed- finalizeRepositoryChanges repository- debugMessage "Applying patches to working directory..."- _ <- 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 ++ "."---- | matchingHead returns the repository up to some tag. The tag t is--- the last tag such that there is a patch after t that is matched by--- the user's query.-matchingHead :: forall p C(r). RepoPatch p =>- [DarcsFlag] -> PatchSet p C(Origin r)- -> (PatchSet p :> FL (PatchInfoAnd p)) C(Origin r)-matchingHead opts set =- case mh set of- (start :> patches) -> (start :> reverseRL patches)- where- mh :: FORALL(x) PatchSet p C(Origin x)- -> (PatchSet p :> RL (PatchInfoAnd p)) C(Origin x)- mh s@(PatchSet x _)- | or (mapRL (matchAPatchread opts) x) = contextPatches s- mh (PatchSet x (Tagged t _ ps :<: ts))- = case mh (PatchSet (t:<:ps) ts)- of (start :> patches) -> (start :> x +<+ patches)- mh ps = (ps :> NilRL)--savetoBundle :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag]- -> PatchSet p C(Origin z) -> FL (PatchInfoAnd p) C(z t)- -> IO ()-savetoBundle opts kept removed@(x :>: _) = do- bundle <- makeBundleN Nothing kept (mapFL_FL hopefully removed)- let filename = patchFilename $ patchDesc x- Just outname = getOutput opts filename- useAbsoluteOrStd writeDocBinFile putDoc outname $ bundle--savetoBundle _ _ NilFL = return ()-
− src/Darcs/Commands/Unrevert.hs
@@ -1,139 +0,0 @@--- Copyright (C) 2003-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, GADTs #-}--#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 )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Flags( diffingOpts )-import Darcs.Arguments ( DarcsFlag( MarkConflicts ),- ignoretimes, workingRepoDir,- allInteractive, umaskOption, unified- )-import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, RepoJob(..),- unrevertUrl, considerMergeToWorking,- tentativelyAddToPending, finalizeRepositoryChanges,- readRepo, amInHashedRepository,- readRecorded,- applyToWorking, unrecordedChanges )-import Darcs.Patch ( RepoPatch, PrimOf, commute, namepatch, fromPrims )-import Darcs.Patch.Apply( ApplyState )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+) )-import Darcs.SelectChanges ( selectChanges, WhichChanges(First),- runSelection, selectionContextPrim )-import qualified Data.ByteString as B-import Darcs.Lock ( writeDocBinFile, removeFileMayNotExist )-import Darcs.Patch.Depends ( mergeThem )-import Darcs.Utils ( askUser, catchall )-import Darcs.Patch.Bundle ( scanBundle, makeBundleN )-import IsoDate ( getIsoDateTime )-import Darcs.SignalHandler ( withSignalsBlocked )-import Progress ( debugMessage )-import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-#include "impossible.h"--unrevertDescription :: String-unrevertDescription =- "Undo the last revert (may fail if changes after the revert)."--unrevertHelp :: String-unrevertHelp =- "Unrevert is a rescue command in case you accidentally reverted\n" ++- "something you wanted to keep (for example, typing `darcs rev -a'\n" ++- "instead of `darcs rec -a').\n" ++- "\n" ++- "This command may fail if the repository has changed since the revert\n" ++- "took place. Darcs will ask for confirmation before executing an\n" ++- "interactive command that will DEFINITELY prevent unreversion.\n"--unrevert :: DarcsCommand-unrevert = DarcsCommand {commandProgramName = "darcs",- commandName = "unrevert",- commandHelp = unrevertHelp,- commandDescription = unrevertDescription,- commandExtraArgs = 0,- commandExtraArgHelp = [],- commandCommand = unrevertCmd,- commandPrereq = amInHashedRepository,- commandGetArgPossibilities = return [],- commandArgdefaults = nodefaults,- commandAdvancedOptions = [umaskOption],- commandBasicOptions = [ignoretimes,- allInteractive,- workingRepoDir,- unified]}--unrevertCmd :: [DarcsFlag] -> [String] -> IO ()-unrevertCmd opts [] = withRepoLock opts $ RepoJob $ \repository -> do- us <- readRepo repository- Sealed them <- unrevertPatchBundle repository- rec <- readRecorded repository- unrec <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository Nothing- Sealed h_them <- return $ mergeThem us them- Sealed pw <- considerMergeToWorking repository "pull" (MarkConflicts:opts) NilFL h_them- let context = selectionContextPrim "unrevert" opts Nothing Nothing (Just rec)- (p :> skipped) <- runSelection (selectChanges First pw) context- tentativelyAddToPending repository opts p- withSignalsBlocked $- do finalizeRepositoryChanges repository- _ <- applyToWorking repository opts p `catch` \(e :: IOException) ->- fail ("Error applying unrevert to working directory...\n"- ++ show e)- debugMessage "I'm about to writeUnrevert."- writeUnrevert repository skipped rec (unrec+>+p)- debugMessage "Finished unreverting."-unrevertCmd _ _ = impossible--writeUnrevert :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> FL (PrimOf p) C(x y)- -> Tree IO -> FL (PrimOf p) C(r x) -> IO ()-writeUnrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository-writeUnrevert repository ps rec pend = do- case commute (pend :> ps) of- Nothing -> do really <- askUser "You will not be able to unrevert this operation! Proceed? "- case really of ('y':_) -> return ()- _ -> exitWith $ ExitSuccess- writeUnrevert repository NilFL rec pend- Just (p' :> _) -> do- rep <- readRepo repository- date <- getIsoDateTime- np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p')- bundle <- makeBundleN (Just rec) rep (np :>: NilFL)- writeDocBinFile (unrevertUrl repository) bundle- where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL (PrimOf p) C(r y) -> FL p C(r y)- fromRepoPrims _ xs = fromPrims xs--unrevertPatchBundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p C(Origin))-unrevertPatchBundle repository = do- pf <- B.readFile (unrevertUrl repository)- `catchall` fail "There's nothing to unrevert!"- case scanBundle pf of- Right ps -> return ps- Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err-
− src/Darcs/Commands/Util.hs
@@ -1,60 +0,0 @@--- Copyright (C) 2002-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Commands.Util ( announceFiles, filterExistingFiles ) where--import Darcs.Arguments ( DarcsFlag(LookForAdds) )-import Darcs.Patch ( RepoPatch )-import Darcs.RepoPath ( SubPath, toFilePath )-import Darcs.Repository ( Repository, extractOptions, readRecorded,- readUnrecorded )-import Darcs.Repository.State ( applyTreeFilter, restrictBoring )-import Darcs.Patch.Apply ( ApplyState )-import Storage.Hashed( floatPath, readPlainTree )-import Storage.Hashed.Tree( Tree )-import Storage.Hashed.Monad ( virtualTreeIO, exists )--announceFiles :: Maybe [SubPath] -> String -> IO ()-announceFiles Nothing _ = return ()-announceFiles (Just files) message = putStrLn $ message ++ " " ++- unwords (map show files) ++ ":\n"--filterExistingFiles :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> [SubPath] -> IO [SubPath]-filterExistingFiles repo files = do- pristine <- readRecorded repo- -- TODO this is slightly inefficient, since we should really somehow- -- extract the unrecorded state as a side-effect of unrecordedChanges- index <- readUnrecorded repo $ Just files- nonboring <- restrictBoring index- working <- applyTreeFilter nonboring `fmap` readPlainTree "."- let paths = map toFilePath files- check = virtualTreeIO (mapM exists $ map floatPath paths)- (in_working, _) <- check working- (in_pristine, _) <- check pristine- mapM_ maybe_warn $ zip3 paths in_working in_pristine- return [ path | (path, True) <- zip files (zipWith (||) in_working in_pristine) ]- where maybe_warn (file, False, False) =- putStrLn $ "WARNING: File '"++file++"' does not exist!"- maybe_warn (file, True, False) | LookForAdds `notElem` extractOptions repo =- putStrLn $ "WARNING: File '" ++ file ++ "' not in repository!"- maybe_warn _ = return ()-
− src/Darcs/Commands/WhatsNew.hs
@@ -1,193 +0,0 @@--- Copyright (C) 2002-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Commands.WhatsNew- (- whatsnew- , status- ) where--import Control.Applicative ( (<$>) )-import Data.List ( delete )-import System.Exit ( ExitCode(..), exitWith )--import Storage.Hashed.Tree( Tree )--import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, lookforadds,- ignoretimes, noskipBoring, unified, summary,- fixSubPaths, listRegisteredFiles )-import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )-import Darcs.Commands.Util ( announceFiles )-import Darcs.Diff( treeDiff )-import Darcs.Flags( isUnified, diffingOpts )-import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf, plainSummaryPrims,- primIsHunk, applyToTree )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Format ( PatchListFormat(..) )-import Darcs.Patch.FileHunk ( IsHunk(..) )-import Darcs.Patch.Patchy ( Patchy )-import Darcs.Patch.Permutations ( partitionRL )-import Darcs.Patch.Prim.Class ( PrimDetails(..) )-import Darcs.Patch.TouchesFiles( choosePreTouching )-import Darcs.RepoPath( SubPath, toFilePath )-import Darcs.Repository ( Repository, withRepository, RepoJob(..)- , amInRepository- , unrecordedChanges, readRecorded )-import Darcs.Repository.Prefs ( filetypeFunction )-import Darcs.PrintPatch ( printPatch, contextualPrintPatch )-import Darcs.Witnesses.Ordered ( FL(..), reverseRL, reverseFL, (:>)(..) )-import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft )-import Printer ( putDocLn, renderString, vcat, text )--whatsnew :: DarcsCommand-whatsnew = DarcsCommand { commandProgramName = "darcs"- , commandName = "whatsnew"- , commandHelp = whatsnewHelp- , commandDescription = whatsnewDescription- , commandExtraArgs = -1- , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]- , commandCommand = whatsnewCmd- , commandPrereq = amInRepository- , commandGetArgPossibilities = listRegisteredFiles- , commandArgdefaults = nodefaults- , commandAdvancedOptions = [ignoretimes, noskipBoring]- , commandBasicOptions = [ summary- , unified- , lookforadds- , workingRepoDir- ]- }--whatsnewDescription :: String-whatsnewDescription = "List unrecorded changes in the working tree."--whatsnewHelp :: String-whatsnewHelp =- "The `darcs whatsnew' command lists unrecorded changes to the working\n" ++- "tree. If you specify a set of files and directories, only unrecorded\n" ++- "changes to those files and directories are listed.\n" ++- "\n" ++- "With the --summary option, the changes are condensed to one line per\n" ++- "file, with mnemonics to indicate the nature and extent of the change.\n" ++- "The --look-for-adds option causes candidates for `darcs add' to be\n" ++- "included in the summary output. Summary mnemonics are as follows:\n" ++- "\n" ++- " `A f' and `A d/' respectively mean an added file or directory.\n" ++- " `R f' and `R d/' respectively mean a removed file or directory.\n" ++- " `M f -N +M rP' means a modified file, with N lines deleted, M\n" ++- " lines added, and P lexical replacements.\n" ++- " `f -> g' means a moved file or directory.\n" ++- " `a f' and `a d/' respectively mean a new, but unadded, file or\n" ++- " directory, when using --look-for-adds.\n" ++- "\n" ++- " An exclamation mark (!) as in `R! foo.c', means the hunk is known to\n" ++- " conflict with a hunk in another patch. The phrase `duplicated'\n" ++- " means the hunk is known to be identical to a hunk in another patch.\n" ++- "\n" ++- "By default, `darcs whatsnew' uses Darcs' internal format for changes.\n" ++- "To see some context (unchanged lines) around each change, use the\n" ++- "--unified option. To view changes in conventional `diff' format, use\n" ++- "the `darcs diff' command; but note that `darcs whatsnew' is faster.\n" ++- "\n" ++- "This command exits unsuccessfully (returns a non-zero exit status) if\n" ++- "there are no unrecorded changes.\n"--whatsnewCmd :: [DarcsFlag] -> [String] -> IO ()-whatsnewCmd opts args =- withRepository opts $ RepoJob $ \(repo :: Repository p C(r u r)) -> do- files <- if null args- then return Nothing- else Just <$> fixSubPaths opts args- let isLookForAdds = LookForAdds `elem` opts && NoSummary `notElem` opts- -- LookForAdds implies Summary, unless it's explcitly disabled.- optsModifier = if isLookForAdds- then (Summary :) . (LookForAdds `delete`)- else id- opts' = optsModifier opts- Sealed noLookChanges <- filteredUnrecordedChanges opts' repo files- pristine <- readRecorded repo- -- If we are looking for adds, return the corresponding FL of changes.- Sealed unaddedNewPathsPs <- if isLookForAdds- then do- -- Use opts not opts', here, since we *do* want to look for adds.- Sealed lookChanges <- filteredUnrecordedChanges opts repo files- noLookAddsTree <- applyAddPatchesToPristine noLookChanges pristine- lookAddsTree <- applyAddPatchesToPristine lookChanges pristine- ftf <- filetypeFunction- -- Return the patches that create files/dirs that aren't yet added.- unFreeLeft <$> treeDiff ftf noLookAddsTree lookAddsTree- else return (Sealed NilFL)- announceFiles files "What's new in"- exitOnNoChanges (unaddedNewPathsPs, noLookChanges)- printChanges opts' pristine noLookChanges- printUnaddedPaths unaddedNewPathsPs- where- -- |Filter out hunk patches (leaving add patches) and return the tree- -- resulting from applying the filtered patches to the pristine tree.- applyAddPatchesToPristine ps pristine = do- adds :> _ <- return $ partitionRL primIsHunk $ reverseFL ps- applyToTree (reverseRL adds) pristine-- exitOnNoChanges :: (FL p C(x y), FL p C(u v)) -> IO ()- exitOnNoChanges (NilFL, NilFL) = do putStrLn "No changes!"- exitWith $ ExitFailure 1- exitOnNoChanges _ = return ()-- printUnaddedPaths :: PrimPatch p => FL p C(x y) -> IO ()- printUnaddedPaths NilFL = return ()- printUnaddedPaths ps =- putDocLn . lowercaseAs . renderString . plainSummaryPrims $ ps-- -- Make any add markers lowercase, to distinguish new-but-unadded files- -- from those that are unrecorded, but added.- lowercaseAs x = vcat $ map (text . lowercaseA) $ lines x- lowercaseA ('A' : x) = 'a' : x- lowercaseA x = x-- -- |Appropriately print changes, according to the passed flags.- printChanges :: (PatchListFormat p, IsHunk p, Patchy p, PrimDetails p,- ApplyState p ~ Tree) => [DarcsFlag] -> Tree IO -> FL p C(x y)- -> IO ()- printChanges opts' pristine changes- | Summary `elem` opts' = putDocLn $ plainSummaryPrims changes- | isUnified opts' = contextualPrintPatch pristine changes- | otherwise = printPatch changes-- -- |return the unrecorded changes that affect an optional list of paths.- filteredUnrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree,- ApplyState (PrimOf p) ~ Tree) => [DarcsFlag]- -> Repository p C(r u t) -> Maybe [SubPath]- -> IO (Sealed (FL (PrimOf p) C(t)))- filteredUnrecordedChanges opts' repo files =- let filePaths = map toFilePath <$> files in- let diffOpts = diffingOpts opts' in- choosePreTouching filePaths <$> unrecordedChanges diffOpts repo files---- |status is an alias for whatsnew, with implicit Summary and LookForAdds--- flags. We override the default description, to include the implicit flags.-status :: DarcsCommand-status = statusAlias { commandCommand = statusCmd- , commandDescription = statusDesc- }- where- statusAlias = commandAlias "status" Nothing whatsnew- statusCmd fs = commandCommand whatsnew (Summary : LookForAdds : fs)- statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '."
− src/Darcs/CommandsAux.hs
@@ -1,122 +0,0 @@--- Copyright (C) 2006 Tommy Pettersson <ptp@lysator.liu.se>------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.CommandsAux ( checkPaths, maliciousPatches, hasMaliciousPath,- isMaliciousPath, isMaliciousSubPath,- ) where-import Darcs.Flags ( DarcsFlag( RestrictPaths, DontRestrictPaths ) )-import Darcs.Patch ( Patchy, listTouchedFiles )-import Darcs.Witnesses.Ordered ( FL, mapFL )-import Darcs.Witnesses.Sealed ( Sealed2(..), unseal2 )-import Darcs.Global ( darcsdir )-import Data.List ( intersect )-import System.FilePath ( splitDirectories, isRelative )---- * File paths-{-- Darcs will operate on files and directories with the invoking user's- privileges. The paths for these files and directories are stored in- patches, which darcs receives in various ways. Even though darcs will not- create patches with "unexpected" file paths, there are no such guarantees- for received patches. A spoofed patch could inflict changes on any file- or directory which the invoking user is privileged to modify.-- There is no one single "apply" function that can check paths, so each- command is responsible for not applying patches without first checking- them with one of these function when appropriate.--}--{- |- A convenience function to call from all darcs command functions before- applying any patches. It checks for malicious paths in patches, and- prints an error message and fails if it finds one.--}-checkPaths :: Patchy p => [DarcsFlag] -> FL p C(x y) -> IO ()-checkPaths opts patches- = if check_is_on && or (mapFL hasMaliciousPath patches)- then fail $ unlines $ ["Malicious path in patch:"] ++- (map (\s -> " " ++ s) $ concat $ mapFL maliciousPaths patches) ++- ["", "If you are sure this is ok then you can run again with the --dont-restrict-paths option."]- -- TODO: print patch(es)- -- NOTE: should use safe Doc printer, this can be evil chars- else return ()- where- check_is_on = DontRestrictPaths `notElem` opts ||- RestrictPaths `elem` opts---- | Filter out patches that contains some malicious file path-maliciousPatches :: Patchy p => [Sealed2 p] -> [Sealed2 p]-maliciousPatches to_check = filter (unseal2 hasMaliciousPath) to_check--hasMaliciousPath :: Patchy p => p C(x y) -> Bool-hasMaliciousPath patch =- case maliciousPaths patch of- [] -> False- _ -> True--maliciousPaths :: Patchy p => p C(x y) -> [String]-maliciousPaths patch =- let paths = listTouchedFiles patch in- filter isMaliciousPath paths--{-|- What is a malicious path?-- A spoofed path is a malicious path.-- 1. Darcs only creates explicitly relative paths (beginning with @\".\/\"@),- so any not explicitly relative path is surely spoofed.-- 2. Darcs normalizes paths so they never contain @\"\/..\/\"@, so paths with- @\"\/..\/\"@ are surely spoofed.-- A path to a darcs repository's meta data can modify \"trusted\" patches or- change safety defaults in that repository, so we check for paths- containing @\"\/_darcs\/\"@ which is the entry to darcs meta data.-- To do?-- * How about get repositories?-- * Would it be worth adding a --semi-safe-paths option for allowing- changes to certain preference files (_darcs\/prefs\/) in sub- repositories'?--}-isMaliciousPath :: String -> Bool-isMaliciousPath fp =- not (isExplicitlyRelative fp) || isGenerallyMalicious fp---- | Warning : this is less rigorous than isMaliciousPath--- but it's to allow for subpath representations that--- don't start with ./-isMaliciousSubPath :: String -> Bool-isMaliciousSubPath fp =- not (isRelative fp) || isGenerallyMalicious fp--isGenerallyMalicious :: String -> Bool-isGenerallyMalicious fp =- splitDirectories fp `contains_any` [ "..", darcsdir ]- where- contains_any a b = not . null $ intersect a b--isExplicitlyRelative :: String -> Bool-isExplicitlyRelative ('.':'/':_) = True -- begins with "./"-isExplicitlyRelative _ = False
− src/Darcs/Compat.hs
@@ -1,126 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--module Darcs.Compat (stdoutIsAPipe, mkStdoutTemp, canonFilename,- maybeRelink, atomicCreate, sloppyAtomicCreate) where--import Prelude hiding ( catch )--import Darcs.Utils ( withCurrentDirectory )-#ifdef WIN32-import Darcs.Utils ( showHexLen )-import Data.Bits ( (.&.) )-import System.Random ( randomIO )-#else-import Foreign.C.String ( peekCString )-#endif--import Control.Monad ( unless )-import Foreign.C.Types ( CInt(..) )-import Foreign.C.String ( CString, withCString )-import Foreign.C.Error ( throwErrno, eEXIST, getErrno )-import System.Directory ( getCurrentDirectory )-import System.IO ( hFlush, stdout, stderr, hSetBuffering,- BufferMode(NoBuffering) )-import System.IO.Error ( mkIOError, alreadyExistsErrorType )-import System.Posix.Files ( stdFileMode )-import System.Posix.IO ( openFd, closeFd, stdOutput, stdError,- dupTo, defaultFileFlags, exclusive,- OpenMode(WriteOnly) )-import System.Posix.Types ( Fd(..) )--import Darcs.SignalHandler ( stdoutIsAPipe )--canonFilename :: FilePath -> IO FilePath-canonFilename f@(_:':':_) = return f -- absolute windows paths-canonFilename f@('/':_) = return f-canonFilename ('.':'/':f) = do cd <- getCurrentDirectory- return $ cd ++ "/" ++ f-canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of- "" -> fmap (++('/':f)) getCurrentDirectory- rd -> withCurrentDirectory rd $- do fd <- getCurrentDirectory- return $ fd ++ "/" ++ simplefilename- where- simplefilename = reverse $ takeWhile (/='/') $ reverse f--#ifdef WIN32-mkstempCore :: FilePath -> IO (Fd, String)-mkstempCore fp- = do r <- randomIO- let fp' = fp ++ (showHexLen 6 (r .&. 0xFFFFFF :: Int))- fd <- openFd fp' WriteOnly (Just stdFileMode) flags- return (fd, fp')- where flags = defaultFileFlags { exclusive = True }-#else-mkstempCore :: String -> IO (Fd, String)-mkstempCore str = withCString (str++"XXXXXX") $- \cstr -> do fd <- c_mkstemp cstr- if fd < 0- then throwErrno $ "Failed to create temporary file "++str- else do str' <- peekCString cstr- fname <- canonFilename str'- return (Fd fd, fname)--foreign import ccall unsafe "static stdlib.h mkstemp"- c_mkstemp :: CString -> IO CInt-#endif--mkStdoutTemp :: String -> IO String-mkStdoutTemp str = do (fd, fn) <- mkstempCore str- hFlush stdout- hFlush stderr--- Warning: A do-notation statement discarded a result of type Fd.- _ <- dupTo fd stdOutput--- Warning: A do-notation statement discarded a result of type Fd.- _ <- dupTo fd stdError- hFlush stdout- hFlush stderr- hSetBuffering stdout NoBuffering- hSetBuffering stderr NoBuffering- return fn----foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink- :: CString -> CString -> CInt -> IO CInt---- Checks whether src and dst are identical. If so, makes dst into a--- link to src. Returns True if dst is a link to src (either because--- we linked it or it already was). Safe against changes to src if--- they are not in place, but not to dst.-maybeRelink :: String -> String -> IO Bool-maybeRelink src dst =- withCString src $ \csrc ->- withCString dst $ \cdst ->- do rc <- maybe_relink csrc cdst 1- (case rc of- 0 -> return True- 1 -> return True- -1 -> throwErrno ("Relinking " ++ dst)- -2 -> return False- -3 -> do putStrLn ("Relinking: race condition avoided on file " ++- dst)- return False- _ -> fail ("Unexpected situation when relinking " ++ dst))--sloppyAtomicCreate :: FilePath -> IO ()-sloppyAtomicCreate fp- = do fd <- openFd fp WriteOnly (Just stdFileMode) flags- closeFd fd- where flags = defaultFileFlags { exclusive = True }--atomicCreate :: FilePath -> IO ()-atomicCreate fp = withCString fp $ \cstr -> do- rc <- c_atomic_create cstr- unless (rc >= 0) $- do errno <- getErrno- pwd <- getCurrentDirectory- if errno == eEXIST- then ioError $ mkIOError alreadyExistsErrorType- ("atomicCreate in "++pwd)- Nothing (Just fp)- else throwErrno $ "atomicCreate "++fp++" in "++pwd--foreign import ccall unsafe "atomic_create.h atomic_create" c_atomic_create- :: CString -> IO CInt
− src/Darcs/Diff.hs
@@ -1,156 +0,0 @@--- Copyright (C) 2009 Petr Rockai------ 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.---- |--- Module : Darcs.Diff--- Copyright : 2009 Petr Rockai--- License : MIT--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module Darcs.Diff- (- treeDiff- ) where---import qualified Data.ByteString.Lazy.Char8 as BLC-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BL--import Data.List ( sortBy )--import Storage.Hashed.Tree ( diffTrees- , zipTrees- , TreeItem(..)- , Tree- , readBlob- , emptyBlob- )-import Storage.Hashed.AnchoredPath( AnchoredPath, anchorPath )---import ByteStringUtils ( isFunky )-import Darcs.Patch ( PrimPatch- , hunk- , canonize- , binary- , addfile- , rmfile- , adddir- , rmdir- , invert- )-import Darcs.Repository.Prefs ( FileType(..) )-import Darcs.Witnesses.Ordered ( FL(..)- , (+>+)- )-import Darcs.Witnesses.Sealed ( Gap(..) )---#include "gadts.h"-#include "impossible.h"---data Diff m = Added (TreeItem m)- | Removed (TreeItem m)- | Changed (TreeItem m) (TreeItem m)---getDiff :: AnchoredPath- -> Maybe (TreeItem m)- -> Maybe (TreeItem m)- -> (AnchoredPath, Diff m)-getDiff p Nothing (Just t) = (p, Added t)-getDiff p (Just from) (Just to) = (p, Changed from to)-getDiff p (Just t) Nothing = (p, Removed t)-getDiff _ Nothing Nothing = impossible -- zipTrees should never return this---treeDiff :: forall m w prim . (Functor m, Monad m, Gap w, PrimPatch prim)- => (FilePath -> FileType)- -> Tree m- -> Tree m- -> m (w (FL prim))-treeDiff ft t1 t2 = do- (from, to) <- diffTrees t1 t2- diffs <- mapM (uncurry diff) $ sortBy organise $ zipTrees getDiff from to- return $ foldr (joinGap (+>+)) (emptyGap NilFL) diffs- where- -- sort into removes, changes, adds, with removes in reverse-path order- -- and everything else in forward order- organise :: (AnchoredPath, Diff m) -> (AnchoredPath, Diff m) -> Ordering-- organise (p1, Changed _ _ ) (p2, Changed _ _) = compare p1 p2- organise (p1, Added _) (p2, Added _) = compare p1 p2- organise (p1, Removed _) (p2, Removed _) = compare p2 p1-- organise (_, Removed _) _ = LT- organise _ (_, Removed _) = GT-- organise (_, Changed _ _) _ = LT- organise _ (_, Changed _ _) = GT-- diff :: AnchoredPath -> Diff m -> m (w (FL prim))- diff _ (Changed (SubTree _) (SubTree _)) = return (emptyGap NilFL)- diff p (Removed (SubTree _)) =- return $ freeGap (rmdir (anchorPath "" p) :>: NilFL)- diff p (Added (SubTree _)) =- return $ freeGap (adddir (anchorPath "" p) :>: NilFL)- diff p (Added b'@(File _)) =- do diff' <- diff p (Changed (File emptyBlob) b')- return $ joinGap (:>:) (freeGap (addfile (anchorPath "" p))) diff'- diff p (Removed a'@(File _)) =- do diff' <- diff p (Changed a' (File emptyBlob))- return $ joinGap (+>+) diff' (freeGap (rmfile (anchorPath "" p) :>: NilFL))- diff p (Changed (File a') (File b')) =- do a <- readBlob a'- b <- readBlob b'- let path = anchorPath "" p- case ft path of- TextFile | no_bin a && no_bin b ->- return $ text_diff path a b- _ -> return $ if a /= b- then freeGap (binary path (strict a) (strict b) :>: NilFL)- else emptyGap NilFL- diff p _ = fail $ "Missing case at path " ++ show p-- text_diff p a b- | BL.null a && BL.null b = emptyGap NilFL- | BL.null a = freeGap (diff_from_empty p b)- | BL.null b = freeGap (diff_to_empty p a)- | otherwise = freeGap (line_diff p (linesB a) (linesB b))-- line_diff p a b = canonize (hunk p 1 a b)-- diff_to_empty p x | BLC.last x == '\n' = line_diff p (init $ linesB x) []- | otherwise = line_diff p (linesB x) [BS.empty]-- diff_from_empty p x = invert (diff_to_empty p x)-- no_bin = not . isFunky . strict . BL.take 4096-- linesB = map strict . BLC.split '\n'-- strict = BS.concat . BL.toChunks-
− src/Darcs/Email.hs
@@ -1,248 +0,0 @@-{-# LANGUAGE CPP #-}-module Darcs.Email ( makeEmail, readEmail, formatHeader ) where--import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper )-import Data.List ( isInfixOf )-import Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS)--import ByteStringUtils ( packStringToUTF8, dropSpace, linesPS, betweenLinesPS )-import qualified Data.ByteString as B (ByteString, length, null, tail- ,drop, head, concat, singleton- ,pack, append, empty, unpack- )-import qualified Data.ByteString.Char8 as BC (index, head, pack)-import Data.ByteString.Internal as B (c2w, createAndTrim)-import System.IO.Unsafe ( unsafePerformIO )-import Foreign.Ptr ( Ptr, plusPtr )-import Foreign.Storable ( poke )-import Data.Word ( Word8 )-import Data.Maybe ( fromMaybe )---- lineMax is maximum number of characters in an e-mail line excluding the CRLF--- at the end. qlineMax is the number of characters in a q-encoded or--- quoted-printable-encoded line.-lineMax, qlineMax :: Int-lineMax = 78-qlineMax = 75---- | Formats an e-mail header by encoding any non-ascii characters using UTF-8--- and Q-encoding, and folding lines at appropriate points. It doesn't do--- more than that, so the header name and header value should be--- well-formatted give or take line length and encoding. So no non-ASCII--- characters within quoted-string, quoted-pair, or atom; no semantically--- meaningful signs in names; no non-ASCII characters in the header name;--- etcetera.-formatHeader :: String -> String -> B.ByteString-formatHeader headerName headerValue =- B.append nameColon encodedValue- where nameColon = B.pack (map B.c2w (headerName ++ ":")) -- space for folding- encodedValue = foldAndEncode (' ':headerValue)- (B.length nameColon) False False---- run through a string and encode non-ascii words and fold where appropriate.--- the integer argument is the current position in the current line.--- the string in the first argument must begin with whitespace, or be empty.-foldAndEncode :: String -> Int -> Bool -> Bool -> B.ByteString-foldAndEncode [] _ _ _ = B.empty-foldAndEncode s p lastWordEncoded inMidWord =- let newline = B.singleton 10- space = B.singleton 32- s2bs = B.pack . map B.c2w- -- the twelve there is the max number of ASCII chars to encode a single- -- character: 4 * 3, 4 UTF-8 bytes times 3 ASCII chars per byte- safeEncChunkLength = (qlineMax - B.length encodedWordStart- - B.length encodedWordEnd) `div` 12- (curSpace, afterCurSpace) = span (== ' ') s- (curWord, afterCurWord) = break (== ' ') afterCurSpace- qEncWord | lastWordEncoded = qEncode (curSpace ++ curWord)- | otherwise = qEncode curWord- mustEncode = inMidWord- || any (\c -> not (isPrint c) || (ord c) > 127) curWord- || length curWord > lineMax - 1- || isInfixOf "=?" curWord- mustFold- | mustEncode && lastWordEncoded- = p + 1 + B.length qEncWord > lineMax- | mustEncode- = p + length curSpace + B.length qEncWord > lineMax- | otherwise- = p + length curSpace + length curWord > lineMax- mustSplit = (B.length qEncWord > qlineMax && mustEncode)- || length curWord > lineMax - 1- spaceToInsert | mustEncode && lastWordEncoded = space- | otherwise = s2bs curSpace- wordToInsert- | mustEncode && mustSplit = qEncode (take safeEncChunkLength curWord)- | mustEncode = qEncWord- | otherwise = s2bs curWord- doneChunk | mustFold = B.concat [newline, spaceToInsert, wordToInsert]- | otherwise = B.concat [spaceToInsert, wordToInsert]- (rest, nextP)- | mustSplit- = (drop safeEncChunkLength curWord ++ afterCurWord, qlineMax + 1)- | mustEncode && mustFold- = (afterCurWord, B.length spaceToInsert + B.length wordToInsert)- | otherwise- = (afterCurWord, p + B.length doneChunk)- in B.append doneChunk (foldAndEncode rest nextP mustEncode mustSplit)---- | Turns a piece of string into a q-encoded block--- Applies q-encoding, for use in e-mail header values, as defined in RFC 2047.--- It just takes a string and builds an encoded-word from it, it does not check--- length or necessity.-qEncode :: String -> B.ByteString-qEncode s = B.concat [encodedWordStart,- encodedString,- encodedWordEnd]- where encodedString = B.concat (map qEncodeChar s)--encodedWordStart, encodedWordEnd :: B.ByteString-encodedWordStart = B.pack (map B.c2w "=?UTF-8?Q?")-encodedWordEnd = B.pack (map B.c2w "?=")---- turns a character into its q-encoded bytestring value. For most printable--- ASCII characters, that's just the singleton bytestring with that char.-qEncodeChar :: Char -> B.ByteString-qEncodeChar c- | c == ' ' = c2bs '_'- | isPrint c- && not (c `elem` ['?', '=', '_'])- && ord c < 128 = c2bs c- | otherwise = B.concat- (map qbyte- (B.unpack- (packStringToUTF8 [c])))- where c2bs = B.singleton . B.c2w- -- qbyte turns a byte into its q-encoded "=hh" representation- qbyte b = B.pack (map B.c2w ['='- ,word8ToUDigit (b `div` 16)- ,word8ToUDigit (b `mod` 16)- ])- word8ToUDigit :: Word8 -> Char- word8ToUDigit = toUpper . intToDigit . fromIntegral---- TODO is this doing mime encoding??-qpencode :: B.ByteString -> B.ByteString-qpencode s = unsafePerformIO- -- Really only (3 + 2/75) * length or something in the worst case- $ B.createAndTrim (4 * B.length s) (\buf -> encode s qlineMax buf 0)--encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int-encode ps _ _ bufi | B.null ps = return bufi-encode ps n buf bufi = case B.head ps of- c | c == newline ->- do poke (buf `plusPtr` bufi) newline- encode ps' qlineMax buf (bufi+1)- | n == 0 && B.length ps > 1 ->- do poke (buf `plusPtr` bufi) equals- poke (buf `plusPtr` (bufi+1)) newline- encode ps qlineMax buf (bufi + 2)- | (c == tab || c == space) ->- if B.null ps' || B.head ps' == newline- then do poke (buf `plusPtr` bufi) c- poke (buf `plusPtr` (bufi+1)) equals- poke (buf `plusPtr` (bufi+2)) newline- encode ps' qlineMax buf (bufi + 3)- else do poke (buf `plusPtr` bufi) c- encode ps' (n - 1) buf (bufi + 1)- | (c >= bang && c /= equals && c <= tilde) ->- do poke (buf `plusPtr` bufi) c- encode ps' (n - 1) buf (bufi + 1)- | n < 3 ->- encode ps 0 buf bufi- | otherwise ->- do let (x, y) = c `divMod` 16- h1 = intToUDigit x- h2 = intToUDigit y- poke (buf `plusPtr` bufi) equals- poke (buf `plusPtr` (bufi+1)) h1- poke (buf `plusPtr` (bufi+2)) h2- encode ps' (n - 3) buf (bufi + 3)- where ps' = B.tail ps- newline = B.c2w '\n'- tab = B.c2w '\t'- space = B.c2w ' '- bang = B.c2w '!'- tilde = B.c2w '~'- equals = B.c2w '='- intToUDigit i- | i >= 0 && i <= 9 = B.c2w '0' + i- | i >= 10 && i <= 15 = B.c2w 'A' + i - 10- | otherwise = error $ "intToUDigit: '"++show i++"'not a digit"--qpdecode :: B.ByteString -> B.ByteString-qpdecode s = unsafePerformIO- -- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n"- $ B.createAndTrim (B.length s + 1) (\buf -> decode (linesPS s) buf 0)--decode :: [B.ByteString] -> Ptr Word8 -> Int -> IO Int-decode [] _ bufi = return bufi-decode (ps:pss) buf bufi- | B.null (dropSpace ps)- = do poke (buf `plusPtr` bufi) newline- decode pss buf (bufi+1)- | is_equals && B.length ps >= 3 && isHexDigit c1 && isHexDigit c2- = do poke (buf `plusPtr` bufi)- (toWord8 $ digitToInt c1 * 16 + digitToInt c2)- decode (B.drop 3 ps:pss) buf (bufi+1)- | is_equals && B.null (dropSpace (B.tail ps)) = decode pss buf bufi- | otherwise = do poke (buf `plusPtr` bufi) (B.head ps)- decode (B.tail ps:pss) buf (bufi+1)- where is_equals = BC.head ps == '='- c1 = BC.index ps 1- c2 = BC.index ps 2- newline = B.c2w '\n'- toWord8 :: Int -> Word8- toWord8 = fromIntegral--makeEmail :: String -> [(String, String)] -> (Maybe Doc) -> Maybe String -> Doc -> (Maybe String) -> Doc-makeEmail repodir headers mcontents mcharset bundle mfilename =- text "DarcsURL:" <+> text repodir- $$ foldl (\m (h,v) -> m $$ (text (h ++ ":") <+> text v)) empty headers- $$ text "MIME-Version: 1.0"- $$ text "Content-Type: multipart/mixed; boundary=\"=_\""- $$ text ""- $$ text "--=_"- $$ (case mcontents of- Just contents ->- text ("Content-Type: text/plain; charset=\"" ++- fromMaybe "x-unknown" mcharset ++ "\"")- $$ text "Content-Transfer-Encoding: quoted-printable"- $$ text ""- $$ packedString (qpencode (renderPS contents))- $$ text ""- $$ text "--=_"- Nothing -> empty)- $$ text "Content-Type: text/x-darcs-patch; name=\"patch-preview.txt\""- $$ text "Content-Disposition: inline"- $$ text "Content-Transfer-Encoding: quoted-printable"- $$ text "Content-Description: Patch preview"- $$ text ""- $$ (case betweenLinesPS (BC.pack "New patches:") (BC.pack "Context:") (renderPS bundle) of- Just s -> packedString $ qpencode s- -- this should not happen, but in case it does, keep everything- Nothing -> packedString $ qpencode $ renderPS bundle)- $$ text "--=_"- $$ text "Content-Type: application/x-darcs-patch" <>- (case mfilename of- Just filename -> text "; name=\"" <> text filename <> text "\""- Nothing -> empty)- $$ text "Content-Transfer-Encoding: quoted-printable"- $$ text "Content-Disposition: attachment"- $$ text "Content-Description: A darcs patch for your repository!"- $$ text ""- $$ packedString (qpencode (renderPS bundle))- $$ text "--=_--"- $$ text ""- $$ text "."- $$ text ""- $$ text ""--readEmail :: B.ByteString -> B.ByteString-readEmail s =- case betweenLinesPS- (BC.pack "Content-Description: A darcs patch for your repository!")- (BC.pack "--=_--") s of- Nothing -> s -- if it wasn't an email in the first place, just pass along.- Just s' -> qpdecode s'-
− src/Darcs/External.hs
@@ -1,632 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--module Darcs.External (- backupByRenaming, backupByCopying,- copyFileOrUrl, speculateFileOrUrl, copyLocal, cloneFile,- cloneTree, cloneTreeExcept,- fetchFilePS, fetchFileLazyPS, gzFetchFilePS,- sendEmail, generateEmail, sendEmailDoc, resendEmail,- signString, verifyPS,- execDocPipe, execPipeIgnoreError,- getTermNColors,- pipeDoc, pipeDocSSH, execSSH,- maybeURLCmd,- Cachable(Cachable, Uncachable, MaxAge),- viewDoc, viewDocWith,- haveSendmail,- sendmailPath, diffProgram, darcsProgram- ) where--import Prelude hiding ( catch )--import qualified Ratified-import Data.Maybe ( isJust, isNothing, maybeToList )-import Control.Monad ( when, zipWithM_, filterM, liftM2 )-import System.Exit ( ExitCode(..) )-import System.Environment ( getEnv, getProgName )-import System.IO ( hSetBinaryMode, hPutStr, hPutStrLn, hClose,- openBinaryFile, IOMode( ReadMode ),- openBinaryTempFile,- hIsTerminalDevice, stdout, stderr, Handle )-import System.IO.Error ( isDoesNotExistError )-import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory )-import System.Directory ( createDirectory, getDirectoryContents,- doesFileExist, doesDirectoryExist,- renameFile, renameDirectory, copyFile,- findExecutable )-import System.Process ( runProcess, runInteractiveProcess, waitForProcess )-import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )-import Control.Exception.Extensible- ( bracket, try, finally, catch, IOException, SomeException )-import Data.Char ( toUpper )-#if defined (HAVE_MAPI)-import Foreign.C ( CString, withCString )-#endif-#ifdef HAVE_MAPI-import Foreign.Ptr ( nullPtr )-import Darcs.Lock ( canonFilename, writeDocBinFile )-#endif-#ifdef HAVE_TERMINFO-import System.Console.Terminfo( tiGetNum, setupTermFromEnv, getCapability )-#endif-import System.Posix.Files ( createLink )-import System.FilePath.Posix ( (</>), normalise )--import Darcs.Flags ( DarcsFlag( SignAs, Sign, SignSSL,- Verify, VerifySSL )- , RemoteDarcs(..) )-import Darcs.RepoPath ( AbsolutePath, toFilePath )-import Darcs.Utils ( breakCommand, getViewer, ortryrunning, )-import Progress ( withoutProgress, debugMessage )--import ByteStringUtils (gzReadFilePS, linesPS, unlinesPS)-import qualified Data.ByteString as B (ByteString, empty, null, readFile- ,hGetContents, writeFile, hPut, length- ,take, concat, drop, isPrefixOf, singleton, append)-import qualified Data.ByteString.Char8 as BC (unpack, pack)-import qualified Data.ByteString.Lazy as BL--import Darcs.Lock ( withTemp, withOpenTemp, tempdirLoc, removeFileMayNotExist )-import CommandLine ( parseCmd, addUrlencoded )-import URL ( copyUrl, copyUrlFirst, waitUrl )-import URL ( Cachable(..) )-import Exec ( exec, Redirect(..), withoutNonBlock )-import Darcs.Ssh ( getSSH, copySSH, SSHCmd(..) )-import Darcs.URL ( isFile, isHttpUrl, isSshUrl, splitSshUrl, SshFilePath, sshUhost )-import Darcs.Utils ( catchall )-import Printer ( Doc, Printers, putDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS,- simplePrinters,- text, empty, packedString, vcat, renderString )-import Darcs.Email ( formatHeader )--#ifdef HAVE_HTTP-import Network.Browser ( browse, request, setErrHandler, setOutHandler- , setAllowRedirects )-import Network.HTTP ( RequestMethod(GET), rspCode, rspBody, rspReason- , mkRequest )-import Network.URI ( parseURI, uriScheme )-#endif--sendmailPath :: IO String-sendmailPath = do- l <- filterM doesFileExist $ liftM2 (</>)- [ "/usr/sbin", "/sbin", "/usr/lib" ]- [ "sendmail" ]- ex <- findExecutable "sendmail"- when (isNothing ex && null l) $ fail "Cannot find the \"sendmail\" program."- return $ head $ maybeToList ex ++ l--diffProgram :: IO String-diffProgram = do- l <- filterM (fmap isJust . findExecutable) [ "gdiff", "gnudiff", "diff" ]- when (null l) $ fail "Cannot find the \"diff\" program."- return $ head l---- |Get the name of the darcs executable (as supplied by @getProgName@)-darcsProgram :: IO String-darcsProgram = getProgName--- Another option: getEnv "DARCS" `catch` \(_ :: IOException) -> getProgName--backupByRenaming :: FilePath -> IO ()-backupByRenaming = backupBy rename- where rename x y = do- isD <- doesDirectoryExist x- if isD then renameDirectory x y else renameFile x y--backupByCopying :: FilePath -> IO ()-backupByCopying = backupBy copy- where- copy x y = do- isD <- doesDirectoryExist x- if isD then do createDirectory y- cloneTree (normalise x) (normalise y)- else copyFile x y--backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()-backupBy backup f =- do hasBF <- doesFileExist f- hasBD <- doesDirectoryExist f- when (hasBF || hasBD) $ helper 0- where- helper :: Int -> IO ()- helper i = do existsF <- doesFileExist next- existsD <- doesDirectoryExist next- if (existsF || existsD)- then helper (i + 1)- else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"- backup f next- where next = f ++ suffix- suffix = ".~" ++ show i ++ "~"--copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a-copyAndReadFile readfn fou _ | isFile fou = readfn fou-copyAndReadFile readfn fou cache = withTemp $ \t -> do copyFileOrUrl DefaultRemoteDarcs fou t cache- readfn t---- | @fetchFile fileOrUrl cache@ returns the content of its argument (either a--- file or an URL). If it has to download an url, then it will use a cache as--- required by its second argument.------ We always use default remote darcs, since it is not fatal if the remote--- darcs does not exist or is too old -- anything that supports transfer-mode--- should do, and if not, we will fall back to SFTP or SCP.-fetchFilePS :: String -> Cachable -> IO B.ByteString-fetchFilePS = copyAndReadFile B.readFile---- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of its argument--- (either a file or an URL). Warning: this function may constitute a fd leak;--- make sure to force consumption of file contents to avoid that. See--- "fetchFilePS" for details.-fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString-#ifdef HAVE_HTTP-fetchFileLazyPS x c = case parseURI x of- Just x' | uriScheme x' == "http:" -> do- rsp <- fmap snd . browse $ do- setErrHandler . const $ return ()- setOutHandler . const $ return ()- setAllowRedirects True- request $ mkRequest GET x'- if rspCode rsp /= (2, 0, 0)- then fail $ "fetchFileLazyPS: " ++ rspReason rsp- else return $ rspBody rsp- _ -> copyAndReadFile BL.readFile x c-#else-fetchFileLazyPS x c = copyAndReadFile BL.readFile x c-#endif--gzFetchFilePS :: String -> Cachable -> IO B.ByteString-gzFetchFilePS = copyAndReadFile gzReadFilePS--copyFileOrUrl :: RemoteDarcs -> FilePath -> FilePath -> Cachable -> IO ()-copyFileOrUrl _ fou out _ | isFile fou = copyLocal fou out-copyFileOrUrl _ fou out cache | isHttpUrl fou = copyRemote fou out cache-copyFileOrUrl rd fou out _ | isSshUrl fou = copySSH rd (splitSshUrl fou) out-copyFileOrUrl _ fou _ _ = fail $ "unknown transport protocol: " ++ fou--speculateFileOrUrl :: String -> FilePath -> IO ()-speculateFileOrUrl fou out | isHttpUrl fou = speculateRemote fou out- | otherwise = return ()--copyLocal :: String -> FilePath -> IO ()-copyLocal fou out = createLink fou out `catchall` cloneFile fou out--cloneTree :: FilePath -> FilePath -> IO ()-cloneTree = cloneTreeExcept []--cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()-cloneTreeExcept except source dest =- do fs <- getSymbolicLinkStatus source- if isDirectory fs then do- fps <- getDirectoryContents source- let fps' = filter (`notElem` (".":"..":except)) fps- mk_source fp = source </> fp- mk_dest fp = dest </> fp- zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')- else fail ("cloneTreeExcept: Bad source " ++ source)- `catch` (\(_ :: IOException) -> fail ("cloneTreeExcept: Bad source " ++ source))--cloneSubTree :: FilePath -> FilePath -> IO ()-cloneSubTree source dest =- do fs <- getSymbolicLinkStatus source- if isDirectory fs then do- createDirectory dest- fps <- getDirectoryContents source- let fps' = filter (`notElem` [".", ".."]) fps- mk_source fp = source </> fp- mk_dest fp = dest </> fp- zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')- else if isRegularFile fs then- cloneFile source dest- else fail ("cloneSubTree: Bad source "++ source)- `catch` (\e -> if isDoesNotExistError e- then return ()- else ioError e)--cloneFile :: FilePath -> FilePath -> IO ()-cloneFile = copyFile--maybeURLCmd :: String -> String -> IO(Maybe(String))-maybeURLCmd what url =- do let prot = map toUpper $ takeWhile (/= ':') url- fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot))- `catch` \(_ :: IOException) -> return Nothing--speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable-#if defined(HAVE_CURL) || defined(HAVE_HTTP)-speculateRemote u v =- do maybeget <- maybeURLCmd "GET" u- case maybeget of- Just _ -> return () -- can't pipeline these- Nothing -> copyUrl u v Cachable-#else-speculateRemote u _ = maybeURLCmd "GET" u >> return ()-#endif--copyRemote :: String -> FilePath -> Cachable -> IO ()-copyRemote u v cache =- do maybeget <- maybeURLCmd "GET" u- case maybeget of- Nothing -> copyRemoteNormal u v cache- Just get ->- do let (cmd,args) = breakCommand get- r <- exec cmd (args++[u]) (Null, File v, AsIs)- when (r /= ExitSuccess) $- fail $ "(" ++ get ++ ") failed to fetch: " ++ u--copyRemoteNormal :: String -> FilePath -> Cachable -> IO ()-copyRemoteNormal u v cache = copyUrlFirst u v cache >> waitUrl u---- | Run a command on a remote location without passing it any input or--- reading its output. Return its ExitCode-execSSH :: SshFilePath -> String -> IO ExitCode-execSSH remoteAddr command =- do (ssh, ssh_args) <- getSSH SSH- debugMessage $ unwords (ssh:ssh_args++[sshUhost remoteAddr,command])- withoutProgress $ do hid <- runProcess ssh (ssh_args++[sshUhost remoteAddr,command])- Nothing Nothing Nothing Nothing Nothing- waitForProcess hid--pipeDoc :: String -> [String] -> Doc -> IO ExitCode-pipeDoc c args inp = withoutNonBlock $ withoutProgress $- do debugMessage $ unwords (c:args)- (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing- hSetBinaryMode i True- hSetBinaryMode o True- mvare <- newEmptyMVar--- Warning: A do-notation statement discarded a result of type GHC.Conc.ThreadId.- _ <- forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed- hPutStr stderr)- `finally` putMVar mvare ())- mvaro <- newEmptyMVar--- Warning: A do-notation statement discarded a result of type GHC.Conc.ThreadId.- _ <- forkIO ((Ratified.hGetContents o >>= -- ratify: immediately consumed- hPutStr stdout)- `finally` putMVar mvaro ())- hPutDoc i inp- hClose i- rval <- waitForProcess pid- takeMVar mvare- takeMVar mvaro- when (rval == ExitFailure 127) $- putStrLn $ "Command not found:\n "++ show (c:args)- return rval--pipeDocSSH :: SshFilePath -> [String] -> Doc -> IO ExitCode-pipeDocSSH remoteAddr args input =- do (ssh, ssh_args) <- getSSH SSH- pipeDoc ssh (ssh_args++ (sshUhost remoteAddr:args)) input--sendEmail :: String -> String -> String -> String -> String -> String -> IO ()-sendEmail f t s cc scmd body =- sendEmailDoc f t s cc scmd Nothing (text body)---generateEmail- :: Handle -- ^ handle to write email to- -> String -- ^ From- -> String -- ^ To- -> String -- ^ Subject- -> String -- ^ CC- -> Doc -- ^ body- -> IO ()-generateEmail h f t s cc body = do- putHeader "To" t- putHeader "From" f- putHeader "Subject" s- when (not (null cc)) (putHeader "Cc" cc)- putHeader "X-Mail-Originator" "Darcs Version Control System"- hPutDocLn h body- where putHeader field value- = B.hPut h (B.append (formatHeader field value) newline)- newline = B.singleton 10--haveSendmail :: IO Bool-haveSendmail = (sendmailPath >> return True) `catch` (\(_ :: IOException) -> return False)---- | Send an email, optionally containing a patch bundle--- (more precisely, its description and the bundle itself)-sendEmailDoc- :: String -- ^ from- -> String -- ^ to- -> String -- ^ subject- -> String -- ^ cc- -> String -- ^ send command- -> Maybe (Doc, Doc) -- ^ (content,bundle)- -> Doc -- ^ body- -> IO ()-sendEmailDoc _ "" _ "" _ _ _ = return ()-sendEmailDoc f "" s cc scmd mbundle body =- sendEmailDoc f cc s "" scmd mbundle body-sendEmailDoc f t s cc scmd mbundle body = do- use_sendmail <- haveSendmail- if use_sendmail || scmd /= "" then- withOpenTemp $ \(h,fn) -> do- generateEmail h f t s cc body- hClose h- withOpenTemp $ \(hat,at) -> do- ftable' <- case mbundle of- Just (content,bundle) -> do- hPutDocLn hat $ bundle- return [ ('b', renderString content) , ('a', at) ]- Nothing ->- return [ ('b', renderString body) ]- hClose hat- let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable'- r <- execSendmail ftable scmd fn- when (r /= ExitSuccess) $ fail ("failed to send mail to: "- ++ t ++ cc_list cc- ++ "\nPerhaps sendmail is not configured.")-#ifdef HAVE_MAPI- else do- r <- withCString t $ \tp ->- withCString f $ \fp ->- withCString cc $ \ccp ->- withCString s $ \sp ->- withOpenTemp $ \(h,fn) -> do- hPutDoc h body- hClose h- writeDocBinFile "mailed_patch" body- cfn <- canonFilename fn- withCString cfn $ \pcfn ->- c_send_email fp tp ccp sp nullPtr pcfn- when (r /= 0) $ fail ("failed to send mail to: " ++ t)-#else- else fail $ "no mail facility (sendmail or mapi) located at configure time!"-#endif- where addressOnly a =- case dropWhile (/= '<') a of- ('<':a2) -> takeWhile (/= '>') a2- _ -> a-- cc_list [] = []- cc_list c = " and cc'ed " ++ c--resendEmail :: String -> String -> B.ByteString -> IO ()-resendEmail "" _ _ = return ()-resendEmail t scmd body = do- use_sendmail <- haveSendmail- if use_sendmail || scmd /= ""- then- withOpenTemp $ \(h,fn) -> do- hPutStrLn h $ "To: "++ t- hPutStrLn h $ find_from (linesPS body)- hPutStrLn h $ find_subject (linesPS body)- hPutDocLn h $ fixit $ linesPS body- hClose h- let ftable = [('t',t)]- r <- execSendmail ftable scmd fn- when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t)- else-#ifdef HAVE_MAPI- fail "Don't know how to resend email with MAPI"-#else- fail "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!"-#endif- where br = BC.pack "\r"- darcsurl = BC.pack "DarcsURL:"- content = BC.pack "Content-"- from_start = BC.pack "From:"- subject_start = BC.pack "Subject:"- fixit (l:ls)- | B.null l = packedString B.empty $$ vcat (map packedString ls)- | l == br = packedString B.empty $$ vcat (map packedString ls)- | B.take 9 l == darcsurl || B.take 8 l == content- = packedString l $$ fixit ls- | otherwise = fixit ls- fixit [] = empty- find_from (l:ls) | B.take 5 l == from_start = BC.unpack l- | otherwise = find_from ls- find_from [] = "From: unknown"- find_subject (l:ls) | B.take 8 l == subject_start = BC.unpack l- | otherwise = find_subject ls- find_subject [] = "Subject: (no subject)"--execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode-execSendmail ftable scmd fn =- if scmd == "" then do- cmd <- sendmailPath- exec cmd ["-i", "-t"] (File fn, Null, AsIs)- else case parseCmd (addUrlencoded ftable) scmd of- Right (arg0:opts, wantstdin) ->- do let stdin = if wantstdin then File fn else Null- exec arg0 opts (stdin, Null, AsIs)- Left e -> fail $ ("failed to send mail, invalid sendmail-command: "++(show e))- _ -> fail $ ("failed to send mail, invalid sendmail-command")--#ifdef HAVE_MAPI-foreign import ccall "win32/send_email.h send_email" c_send_email- :: CString -> {- sender -}- CString -> {- recipient -}- CString -> {- cc -}- CString -> {- subject -}- CString -> {- body -}- CString -> {- path -}- IO Int-#endif--execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString-execPSPipe c args ps = fmap renderPS- $ execDocPipe c args- $ packedString ps--execDocPipe :: String -> [String] -> Doc -> IO Doc-execDocPipe c args instr = withoutProgress $- do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing--- Warning: A do-notation statement discarded a result of type GHC.Conc.ThreadId.- _ <- forkIO $ hPutDoc i instr >> hClose i- mvare <- newEmptyMVar--- Warning: A do-notation statement discarded a result of type GHC.Conc.ThreadId.- _ <- forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed- hPutStr stderr)- `finally` putMVar mvare ())- out <- B.hGetContents o- rval <- waitForProcess pid- takeMVar mvare- case rval of- ExitFailure ec ->fail $ "External program '"++c++- "' failed with exit code "++ show ec- ExitSuccess -> return $ packedString out---- The following is needed for diff, which returns non-zero whenever--- the files differ.-execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc-execPipeIgnoreError c args instr = withoutProgress $- do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing--- Warning: A do-notation statement discarded a result of type GHC.Conc.ThreadId.- _ <- forkIO $ hPutDoc i instr >> hClose i- mvare <- newEmptyMVar--- Warning: A do-notation statement discarded a result of type GHC.Conc.ThreadId.- _ <- forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed- hPutStr stderr)- `finally` putMVar mvare ())- out <- B.hGetContents o--- Warning: A do-notation statement discarded a result of type ExitCode.- _ <- waitForProcess pid- takeMVar mvare- return $ if B.null out then empty else packedString out--signString :: [DarcsFlag] -> Doc -> IO Doc-signString [] d = return d-signString (Sign:_) d = signPGP [] d-signString (SignAs keyid:_) d = signPGP ["--local-user", keyid] d-signString (SignSSL idf:_) d = signSSL idf d-signString (_:os) d = signString os d--signPGP :: [String] -> Doc -> IO Doc-signPGP args t = execDocPipe "gpg" ("--clearsign":args) t--signSSL :: String -> Doc -> IO Doc-signSSL idfile t =- withTemp $ \cert -> do- opensslPS ["req", "-new", "-key", idfile,- "-outform", "PEM", "-days", "365"]- (BC.pack "\n\n\n\n\n\n\n\n\n\n\n")- >>= opensslPS ["x509", "-req", "-extensions",- "v3_ca", "-signkey", idfile,- "-outform", "PEM", "-days", "365"]- >>= opensslPS ["x509", "-outform", "PEM"]- >>= B.writeFile cert- opensslDoc ["smime", "-sign", "-signer", cert,- "-inkey", idfile, "-noattr", "-text"] t- where opensslDoc = execDocPipe "openssl"- opensslPS = execPSPipe "openssl"---verifyPS :: [DarcsFlag] -> B.ByteString -> IO (Maybe B.ByteString)-verifyPS [] ps = return $ Just ps-verifyPS (Verify pks:_) ps = verifyGPG pks ps-verifyPS (VerifySSL auks:_) ps = verifySSL auks ps-verifyPS (_:os) ps = verifyPS os ps--verifyGPG :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)-verifyGPG goodkeys s =- withOpenTemp $ \(th,tn) -> do- B.hPut th s- hClose th- rval <- exec "gpg" ["--batch","--no-default-keyring",- "--keyring",fix_path $ toFilePath goodkeys, "--verify"]- (File tn, Null, Null)- case rval of- ExitSuccess -> return $ Just gpg_fixed_s- _ -> return Nothing- where gpg_fixed_s = let- not_begin_signature x =- x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"- &&- x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----\r"- in unlinesPS $ map fix_line $ tail $ dropWhile not_begin_signature $ linesPS s- fix_line x | B.length x < 3 = x- | BC.pack "- -" `B.isPrefixOf` x = B.drop 2 x- | otherwise = x-#if defined(WIN32)- fix_sep c | c=='/' = '\\' | otherwise = c- fix_path p = map fix_sep p-#else- fix_path p = p-#endif--verifySSL :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)-verifySSL goodkeys s = do- certdata <- opensslPS ["smime", "-pk7out"] s- >>= opensslPS ["pkcs7", "-print_certs"]- cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata- let key_used = B.concat $ tail $- takeWhile (/= BC.pack"-----END PUBLIC KEY-----")- $ linesPS cruddy_pk- in do allowed_keys <- linesPS `fmap` B.readFile (toFilePath goodkeys)- if not $ key_used `elem` allowed_keys- then return Nothing -- Not an allowed key!- else withTemp $ \cert ->- withTemp $ \on ->- withOpenTemp $ \(th,tn) -> do- B.hPut th s- hClose th- B.writeFile cert certdata- rval <- exec "openssl" ["smime", "-verify", "-CAfile",- cert, "-certfile", cert]- (File tn, File on, Null)- case rval of- ExitSuccess -> Just `fmap` B.readFile on- _ -> return Nothing- where opensslPS = execPSPipe "openssl"---{-- - This function returns number of colors supported by current terminal- - or -1 if color output not supported or error occured.- - Terminal type determined by TERM env. variable.- -}-getTermNColors :: IO Int-#ifdef HAVE_TERMINFO-getTermNColors = do- t <- setupTermFromEnv- return $ case getCapability t $ tiGetNum "colors" of- Nothing -> (-1)- Just x -> x-#else-getTermNColors = return (-1)-#endif--viewDoc :: Doc -> IO ()-viewDoc = viewDocWith simplePrinters--viewDocWith :: Printers -> Doc -> IO ()-viewDocWith pr msg = do- isTerminal <- hIsTerminalDevice stdout--- Warning: A do-notation statement discarded a result of type ExitCode.- _ <- if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg)- then do viewerPlusArgs <- getViewer- let (viewer:args) = words viewerPlusArgs- pipeDocToPager viewer args pr msg- `ortryrunning` pipeDocToPager "less" [] pr msg- `ortryrunning` pipeDocToPager "more" [] pr msg-#ifdef WIN32- `ortryrunning` pipeDocToPager "more.com" [] pr msg-#endif- `ortryrunning` pipeDocToPager "" [] pr msg- else pipeDocToPager "" [] pr msg- return ()- where lengthGreaterThan n _ | n <= 0 = True- lengthGreaterThan _ [] = False- lengthGreaterThan n (_:xs) = lengthGreaterThan (n-1) xs--pipeDocToPager :: String -> [String] -> Printers -> Doc -> IO ExitCode--pipeDocToPager "" _ pr inp = do- putDocLnWith pr inp- return ExitSuccess--pipeDocToPager c args pr inp = withoutNonBlock $ withoutProgress $ do- tmp <- tempdirLoc- bracket (openBinaryTempFile tmp "darcs-pager") cleanup $ \(fn,fh) ->- do hPutDocWith pr fh inp- hClose fh- bracket (openBinaryFile fn ReadMode) hClose $ \h ->- do x <- do waitForProcess =<< runProcess c args Nothing Nothing (Just h) Nothing Nothing- when (x == ExitFailure 127) $- putStrLn $ "Command not found:\n "++ show (c:args)- return x- where--- Warning: A do-notation statement discarded a result of type Either SomeException ().- cleanup (f,h) = do _ <- try (hClose h) :: IO (Either SomeException ())- removeFileMayNotExist f
− src/Darcs/Flags.hs
@@ -1,279 +0,0 @@--- Copyright (C) 2002-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Flags- ( DarcsFlag( .. )- , Compression( .. )- , UseIndex(..)- , ScanKnown(..)- , RemoteDarcs(..)- , compression- , remoteDarcs- , diffingOpts- , wantExternalMerge- , wantGuiPause- , isInteractive- , maxCount- , willIgnoreTimes- , willRemoveLogFile- , isUnified- , isNotUnified- , doHappyForwarding- , includeBoring- , doAllowCaseOnly- , doAllowWindowsReserved- , doReverse- , usePacks- , showChangesOnlyToFiles- , rollbackInWorkingDir- , removeFromAmended- , defaultFlag- ) where---import Data.List ( find )-import Data.Maybe( fromMaybe, isJust )-import Darcs.Patch.MatchData ( PatchMatch )-import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd )----- | The 'DarcsFlag' type is a list of all flags that can ever be--- passed to darcs, or to one of its commands.-data DarcsFlag = Help | ListOptions | NoTest | Test- | OnlyChangesToFiles | ChangesToAllFiles- | LeaveTestDir | NoLeaveTestDir- | Timings | Debug | DebugVerbose | DebugHTTP- | Verbose | NormalVerbosity | Quiet- | Target String | Cc String- | Output AbsolutePathOrStd | OutputAutoName AbsolutePath- | Subject String | InReplyTo String | Charset String- | SendmailCmd String | Author String | PatchName String- | OnePatch String | SeveralPatch String- | AfterPatch String | UpToPatch String- | TagName String | LastN Int | MaxCount Int | PatchIndexRange Int Int- | NumberPatches- | OneTag String | AfterTag String | UpToTag String- | GenContext | Context AbsolutePath | Count- | LogFile AbsolutePath | RmLogFile | DontRmLogFile- | DistName String | All- | Recursive | NoRecursive | Reorder- | RestrictPaths | DontRestrictPaths- | AskDeps | NoAskDeps | IgnoreTimes | DontIgnoreTimes- | LookForAdds | NoLookForAdds- | AnyOrder | CreatorHash String- | Intersection | Union | Complement- | Sign | SignAs String | NoSign | SignSSL String- | HappyForwarding | NoHappyForwarding- | Verify AbsolutePath | VerifySSL AbsolutePath- | RemoteDarcsOpt String- | EditDescription | NoEditDescription- | Toks String- | EditLongComment | NoEditLongComment | PromptLongComment- | KeepDate | NoKeepDate- | AllowConflicts | MarkConflicts | NoAllowConflicts- | SkipConflicts- | Boring | SkipBoring- | AllowCaseOnly | DontAllowCaseOnly- | AllowWindowsReserved | DontAllowWindowsReserved- | DontGrabDeps | DontPromptForDependencies | PromptForDependencies- | Compress | NoCompress | UnCompress- | WorkRepoDir String | WorkRepoUrl String | RemoteRepo String- | NewRepo String- | Reply String | ApplyAs String- | MachineReadable | HumanReadable- | Pipe | Interactive- | DiffCmd String- | ExternalMerge String | Summary | NoSummary- | PauseForGui | NoPauseForGui- | Unified | NonUnified | Reverse | Forward- | Complete | Lazy- | FixFilePath AbsolutePath AbsolutePath | DiffFlags String- | XMLOutput- | ForceReplace- | OnePattern PatchMatch | SeveralPattern PatchMatch- | AfterPattern PatchMatch | UpToPattern PatchMatch- | NonApply | NonVerify | NonForce- | DryRun-- -- The Bool parameters are a bit of a hack so that we can tell- -- whether the user explicitly set the option or not.- -- A more general mechanism would be better.- -- True = explicitly set by user (on command-line or in prefs/defaults),- -- False = defaulted by darcs- | SetDefault Bool | NoSetDefault Bool-- | Disable | SetScriptsExecutable | DontSetScriptsExecutable | Bisect- | UseHashedInventory- | UseFormat2 | UseNoWorkingDir | UseWorkingDir- | NoUpdateWorking- | Sibling AbsolutePath | Relink- | OptimizePristine | OptimizeHTTP- | UpgradeFormat- | Files | NoFiles | Directories | NoDirectories- | Pending | NoPending- | PosthookCmd String | NoPosthook | AskPosthook | RunPosthook- | PrehookCmd String | NoPrehook | AskPrehook | RunPrehook- | UMask String- | StoreInMemory | ApplyOnDisk- | NoHTTPPipelining- | Packs | NoPacks- | NoCache- | AllowUnrelatedRepos- | Check | Repair | JustThisRepo- | NullFlag- | RecordRollback | NoRecordRollback- | NoAmendUnrecord | AmendUnrecord- deriving ( Eq, Show )---- ADTs for selecting specific behaviour... FIXME These should be eventually--- moved out from this module, closer to where they are actually used--data Compression = NoCompression- | GzipCompression--data UseIndex = UseIndex- | IgnoreIndex--data ScanKnown = ScanKnown -- ^Just files already known to darcs- | ScanAll -- ^All files, i.e. look for new ones- | ScanBoring -- ^All files, even boring ones--data RemoteDarcs = RemoteDarcs String- | DefaultRemoteDarcs---compression :: [DarcsFlag]- -> Compression-compression f- | NoCompress `elem` f = NoCompression- | otherwise = GzipCompression---remoteDarcs :: [DarcsFlag]- -> RemoteDarcs-remoteDarcs f- | (x:_) <- [ c | RemoteDarcsOpt c <- f ] = RemoteDarcs x- | otherwise = DefaultRemoteDarcs---diffingOpts :: [DarcsFlag]- -> (UseIndex, ScanKnown)-diffingOpts opts = (index, scan)- where- index = if willIgnoreTimes opts- then IgnoreIndex- else UseIndex- scan =- if LookForAdds `elem` opts- then- if Boring `elem` opts- then ScanBoring- else ScanAll- else ScanKnown---wantExternalMerge :: [DarcsFlag] -> Maybe String-wantExternalMerge [] = Nothing-wantExternalMerge (ExternalMerge c:_) = Just c-wantExternalMerge (_:fs) = wantExternalMerge fs---wantGuiPause :: [DarcsFlag] -> Bool-wantGuiPause fs = (hasDiffCmd || hasExternalMerge) && hasPause- where- hasDiffCmd = any isDiffCmd fs- hasExternalMerge = isJust $ wantExternalMerge fs- isDiffCmd (DiffCmd _) = True- isDiffCmd _ = False- hasPause = maybe True (==PauseForGui) $ find isPauseFlag $ reverse fs- isPauseFlag f = (f==PauseForGui) || (f==NoPauseForGui)---isInteractive :: [DarcsFlag] -> Bool-isInteractive = isInteractive_ True- where- isInteractive_ def [] = def- isInteractive_ _ (Interactive:_) = True- isInteractive_ _ (All:_) = False- isInteractive_ _ (DryRun:fs) = isInteractive_ False fs- isInteractive_ def (_:fs) = isInteractive_ def fs--maxCount :: [DarcsFlag] -> Maybe Int-maxCount (MaxCount n : _) = Just n-maxCount (_:xs) = maxCount xs-maxCount [] = Nothing---- | @lastWord [(flag, value)] default opts@ scans @opts@ for a flag--- in the list and returns the value of the first match, or @default@--- if none is found.------ We call this the \"last\" word because we assume that flags are--- *prepended* in the order they arrive, so what is first internally--- is last from the user's point of view.-lastWord :: [(DarcsFlag,a)] -> a -> [DarcsFlag] -> a-lastWord known_flags = foldr . flip $ \ def -> fromMaybe def . flip lookup known_flags--getBoolFlag :: DarcsFlag -> DarcsFlag -> [DarcsFlag] -> Bool-getBoolFlag t f = lastWord [(t, True), (f, False)] False--willIgnoreTimes :: [DarcsFlag] -> Bool-willIgnoreTimes = getBoolFlag IgnoreTimes DontIgnoreTimes--willRemoveLogFile :: [DarcsFlag] -> Bool-willRemoveLogFile = getBoolFlag RmLogFile DontRmLogFile--isUnified :: [DarcsFlag] -> Bool-isUnified = getBoolFlag Unified NonUnified--isNotUnified :: [DarcsFlag] -> Bool-isNotUnified = getBoolFlag NonUnified Unified--doHappyForwarding :: [DarcsFlag] -> Bool-doHappyForwarding = getBoolFlag HappyForwarding NoHappyForwarding--includeBoring :: [DarcsFlag] -> Bool-includeBoring = getBoolFlag Boring SkipBoring--doAllowCaseOnly :: [DarcsFlag] -> Bool-doAllowCaseOnly = getBoolFlag AllowCaseOnly DontAllowCaseOnly---doAllowWindowsReserved :: [DarcsFlag] -> Bool-doAllowWindowsReserved = getBoolFlag AllowWindowsReserved DontAllowWindowsReserved--doReverse :: [DarcsFlag] -> Bool-doReverse = getBoolFlag Reverse Forward--usePacks :: [DarcsFlag] -> Bool-usePacks = getBoolFlag Packs NoPacks--showChangesOnlyToFiles :: [DarcsFlag] -> Bool-showChangesOnlyToFiles = getBoolFlag OnlyChangesToFiles ChangesToAllFiles---- | Set flags to a default value, but only one has not already been provided-defaultFlag :: [DarcsFlag] -- ^ distractors- -> DarcsFlag -- ^ default- -> [DarcsFlag] -- ^ flags- -> [DarcsFlag] -- ^ updated flags-defaultFlag alts def flags =- if any (`elem` flags) alts then flags else def : flags--rollbackInWorkingDir :: [DarcsFlag] -> Bool-rollbackInWorkingDir = getBoolFlag NoRecordRollback RecordRollback--removeFromAmended :: [DarcsFlag] -> Bool-removeFromAmended = getBoolFlag AmendUnrecord NoAmendUnrecord
− src/Darcs/Global.hs
@@ -1,286 +0,0 @@--- Copyright (C) 2005 Tomasz Zielonka------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}---- |--- Module : Darcs.Global--- Copyright : 2005 Tomasz Zielonka--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable------ This was originally Tomasz Zielonka's AtExit module, slightly generalised--- to include global variables. Here, we attempt to cover broad, global--- features, such as exit handlers. These features slightly break the Haskellian--- purity of darcs, in favour of programming convenience.--module Darcs.Global- (- atexit- , withAtexit- , SshSettings(..)- , defaultSsh- , timingsMode- , setTimingsMode- , whenDebugMode- , withDebugMode- , setDebugMode- , debugMessage- , debugFail- , putTiming- , addCRCWarning- , getCRCWarnings- , resetCRCWarnings- , addBadSource- , getBadSourcesList- , isBadSource- , darcsdir- , isReachableSource- , addReachableSource- , windows- ) where---import Control.Applicative ( (<$>), (<*>) )-import Control.Monad ( when )-import Control.Concurrent.MVar-import Control.Exception.Extensible ( bracket_, catch, catchJust, SomeException- )-#if (MIN_VERSION_base(4,4,0))-import Control.Exception.Extensible ( mask )-#else-import Control.Exception.Extensible ( block, unblock )-#endif-import Data.IORef ( IORef, newIORef, readIORef, writeIORef )-import Data.IORef ( modifyIORef )-import Data.List ( isPrefixOf )-import System.Info ( os )-import System.IO.Unsafe (unsafePerformIO)-import System.IO (hPutStrLn, hPutStr, stderr)-import System.IO.Error ( ioeGetErrorType, isDoesNotExistErrorType )-import System.Process ( readProcessWithExitCode )-import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )-import System.Environment ( getEnv )-import Prelude hiding (catch)--#if !(MIN_VERSION_base(4,4,0))-mask f = block (f unblock)-#endif--windows :: Bool-windows = "mingw" `isPrefixOf` os---atexitActions :: MVar (Maybe [IO ()])-atexitActions = unsafePerformIO (newMVar (Just []))-{-# NOINLINE atexitActions #-}----- | Registers an IO action to run just before darcs exits. Useful for removing--- temporary files and directories, for example. Referenced in Issue1914.-atexit :: IO ()- -> IO ()-atexit action =- modifyMVar_ atexitActions $ \ml ->- case ml of- Just l ->- return (Just (action : l))- Nothing -> do- hPutStrLn stderr "It's too late to use atexit"- return Nothing---withAtexit :: IO a -> IO a-withAtexit prog =- bracket_- (return ())- exit- prog- where- exit = mask $ \unmask -> do- Just actions <- swapMVar atexitActions Nothing- -- from now on atexit will not register new actions- mapM_ (runAction unmask) actions- runAction unmask action =- catch (unmask action) $ \(exn :: SomeException) -> do- hPutStrLn stderr $ "Exception thrown by an atexit registered action:"- hPutStrLn stderr $ show exn----- Write-once-read-many global variables make it easier to implement flags, such--- as --no-ssh-cm. Using global variables reduces the number of parameters that--- we have to pass around, but it is rather unsafe and should be used sparingly.---_debugMode :: IORef Bool-_debugMode = unsafePerformIO $ newIORef False-{-# NOINLINE _debugMode #-}---setDebugMode :: IO ()-setDebugMode = writeIORef _debugMode True---whenDebugMode :: IO () -> IO ()-whenDebugMode j = do b <- readIORef _debugMode- when b j---withDebugMode :: (Bool -> IO a) -> IO a-withDebugMode j = readIORef _debugMode >>= j---debugMessage :: String -> IO ()-debugMessage m = whenDebugMode $ do putTiming; hPutStrLn stderr m---debugFail :: String -> IO a-debugFail m = debugMessage m >> fail m---putTiming :: IO ()-putTiming = when timingsMode $ do- t <- getClockTime >>= toCalendarTime- hPutStr stderr (calendarTimeToString t++": ")---_timingsMode :: IORef Bool-_timingsMode = unsafePerformIO $ newIORef False-{-# NOINLINE _timingsMode #-}---setTimingsMode :: IO ()-setTimingsMode = writeIORef _timingsMode True---timingsMode :: Bool-timingsMode = unsafePerformIO $ readIORef _timingsMode-{-# NOINLINE timingsMode #-}---data SshSettings = SshSettings- { ssh :: String- , scp :: String- , sftp :: String- } deriving (Show, Eq)---_defaultSsh :: IORef SshSettings-_defaultSsh = unsafePerformIO $ newIORef =<< detectSsh----- | Expected properties:------ * only ever runs once in the lifetime of the program--- * environment variables override all--- * tries Putty first on Windows--- * falls back to plain old ssh-detectSsh :: IO SshSettings-detectSsh = do- whenDebugMode (putStrLn "Detecting SSH settings")- vanilla <- if windows- then do- plinkStr <- (snd3 <$> readProcessWithExitCode "plink" [] "")- `catch` \(e :: SomeException) -> return (show e)- whenDebugMode $ putStrLn $- "SSH settings (plink): " ++- (concat . take 1 . lines $ plinkStr)- if "PuTTY" `isPrefixOf` plinkStr- then return (SshSettings "plink" "pscp -q" "psftp")- else return rawVanilla- else return rawVanilla- settings <- SshSettings <$> fromEnv (ssh vanilla) "DARCS_SSH"- <*> fromEnv (scp vanilla) "DARCS_SCP"- <*> fromEnv (sftp vanilla) "DARCS_SFTP"- whenDebugMode (putStrLn $ "SSH settings: " ++ show settings)- return settings- where- snd3 (_, x, _) = x- rawVanilla = SshSettings "ssh" "scp -q" "sftp"- fromEnv :: String -> String -> IO String- fromEnv d v = catchJust notFound- (getEnv v)- (const (return d))- notFound e = if isDoesNotExistErrorType (ioeGetErrorType e)- then Just ()- else Nothing---defaultSsh :: SshSettings-defaultSsh = unsafePerformIO $ readIORef _defaultSsh---type CRCWarningList = [FilePath]-_crcWarningList :: IORef CRCWarningList-_crcWarningList = unsafePerformIO $ newIORef []-{-# NOINLINE _crcWarningList #-}---addCRCWarning :: FilePath -> IO ()-addCRCWarning fp = modifyIORef _crcWarningList (fp:)---getCRCWarnings :: IO [FilePath]-getCRCWarnings = readIORef _crcWarningList---resetCRCWarnings :: IO ()-resetCRCWarnings = writeIORef _crcWarningList []---_badSourcesList :: IORef [String]-_badSourcesList = unsafePerformIO $ newIORef []-{-# NOINLINE _badSourcesList #-}---addBadSource :: String -> IO ()-addBadSource cache = modifyIORef _badSourcesList (cache:)---getBadSourcesList :: IO [String]-getBadSourcesList = readIORef _badSourcesList---isBadSource :: IO (String -> Bool)-isBadSource = do- badSources <- getBadSourcesList- return (`elem` badSources)---_reachableSourcesList :: IORef [String]-_reachableSourcesList = unsafePerformIO $ newIORef []-{-# NOINLINE _reachableSourcesList #-}---addReachableSource :: String -> IO ()-addReachableSource src = modifyIORef _reachableSourcesList (src:)---getReachableSources :: IO [String]-getReachableSources = readIORef _reachableSourcesList---isReachableSource :: IO (String -> Bool)-isReachableSource = do- reachableSources <- getReachableSources- return (`elem` reachableSources)---darcsdir :: String-darcsdir = "_darcs"
− src/Darcs/IO.hs
@@ -1,184 +0,0 @@--- Copyright (C) 2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Darcs.IO ( runTolerantly, runSilently ) where--import Prelude hiding ( catch )-import Data.Char ( toLower )-import Data.List ( isSuffixOf )-import System.IO.Error ( isDoesNotExistError, isPermissionError )-import Control.Exception.Extensible ( catch, SomeException, IOException )-import Control.Monad.Error-import System.Directory ( createDirectory,- removeDirectory, removeFile,- renameFile, renameDirectory,- doesDirectoryExist, doesFileExist- )-import Darcs.Repository.Prefs( changePrefval )--import qualified Data.ByteString as B (empty, null, readFile)--import Darcs.Utils ( prettyException )-import Darcs.External ( backupByCopying, backupByRenaming )-import Darcs.Patch.FileName ( FileName, fn2fp )-import Darcs.Lock ( writeAtomicFilePS )-import Darcs.Patch.ApplyMonad( ApplyMonad(..) )-import Storage.Hashed.Tree( Tree )--instance ApplyMonad IO Tree where- type ApplyMonadBase IO = IO- mDoesDirectoryExist = doesDirectoryExist . fn2fp- mChangePref = changePrefval- mModifyFilePS f j = B.readFile (fn2fp f) >>= j >>= writeAtomicFilePS (fn2fp f)- mCreateDirectory = createDirectory . fn2fp- mCreateFile f = do exf <- doesFileExist (fn2fp f)- if exf then fail $ "File '"++fn2fp f++"' already exists!"- else do exd <- doesDirectoryExist $ fn2fp f- if exd then fail $ "File '"++fn2fp f++"' already exists!"- else writeAtomicFilePS (fn2fp f) B.empty- mRemoveFile f = do let fp = fn2fp f- x <- B.readFile fp- when (not $ B.null x) $- fail $ "Cannot remove non-empty file "++fp- removeFile fp- mRemoveDirectory = removeDirectory . fn2fp- mRename a b = catch- (renameDirectory x y `mplus` renameFile x y)- -- We need to catch does not exist errors, since older- -- versions of darcs allowed users to rename nonexistent- -- files. :(- (\e -> if isDoesNotExistError e- then return ()- else ioError e)- where x = fn2fp a- y = fn2fp b--class Monad m => TolerantMonad m where- warning :: IO () -> m ()- runIO :: m a -> IO a- runTM :: IO a -> m a--newtype TolerantIO a = TIO { runTolerantly :: IO a }-instance TolerantMonad TolerantIO where- warning io = TIO $ io `catch` \e -> putStrLn $ "Warning: " ++ prettyException e- runIO (TIO io) = io- runTM io = TIO io--newtype SilentIO a = SIO { runSilently :: IO a }-instance TolerantMonad SilentIO where- warning io = SIO $ io `catch` \(_ :: SomeException) -> return ()- runIO (SIO io) = io- runTM io = SIO io---- NOTE: The following instance declarations are duplicated merely to avoid--- enabling -fallow-undecidable-instances. If we used--- -fallow-undecidable-instances, we would write instead:---- instance TolerantMonad m => Monad m where--- ...---- etc.-instance Functor TolerantIO where- fmap f m = m >>= return . f--instance Monad TolerantIO where- f >>= g = runTM $ runIO f >>= runIO . g- f >> g = runTM $ runIO f >> runIO g- fail s = runTM $ fail s- return x = runTM $ return x--instance Functor SilentIO where- fmap f m = m >>= return . f--instance Monad SilentIO where- f >>= g = runTM $ runIO f >>= runIO . g- f >> g = runTM $ runIO f >> runIO g- fail s = runTM $ fail s- return x = runTM $ return x--instance ApplyMonad TolerantIO Tree where- type ApplyMonadBase TolerantIO = IO- mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d- mReadFilePS f = runTM $ mReadFilePS f- mChangePref a b c = warning $ mChangePref a b c- mModifyFilePS f j = warning $ mModifyFilePS f (runIO . j)- mCreateFile f = warning $ backup f >> mCreateFile f- mCreateDirectory d = warning $ backup d >> mCreateDirectory d- mRemoveFile f = warning $ mRemoveFile f- mRemoveDirectory d = warning $ catch- (mRemoveDirectory d)- (\(e :: IOException) ->- if "(Directory not empty)" `isSuffixOf` show e- then ioError $ userError $- "Not deleting " ++ fn2fp d ++ " because it is not empty."- else ioError $ userError $- "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)- mRename a b = warning $ catch- (let do_backup = if (map toLower x == map toLower y)- then backupByCopying (fn2fp b) -- avoid making the original vanish- else backupByRenaming (fn2fp b)- in do_backup >> mRename a b)- (\e -> case () of- _ | isPermissionError e -> ioError $ userError $- couldNotRename ++ "."- | isDoesNotExistError e -> ioError $ userError $- couldNotRename ++ " because " ++ x ++ " does not exist."- | otherwise -> ioError e- )- where- x = fn2fp a- y = fn2fp b- couldNotRename = "Could not rename " ++ x ++ " to " ++ y--instance ApplyMonad SilentIO Tree where- type ApplyMonadBase SilentIO = IO- mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d- mReadFilePS f = runTM $ mReadFilePS f- mChangePref a b c = warning $ mChangePref a b c- mModifyFilePS f j = warning $ mModifyFilePS f (runIO . j)- mCreateFile f = warning $ backup f >> mCreateFile f- mCreateDirectory d = warning $ backup d >> mCreateDirectory d- mRemoveFile f = warning $ mRemoveFile f- mRemoveDirectory d = warning $ catch- (mRemoveDirectory d)- (\(e :: SomeException) ->- if "(Directory not empty)" `isSuffixOf` show e- then ioError $ userError $- "Not deleting " ++ fn2fp d ++ " because it is not empty."- else ioError $ userError $- "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)- mRename a b = warning $ catch- (let do_backup = if (map toLower x == map toLower y)- then backupByCopying (fn2fp b) -- avoid making the original vanish- else backupByRenaming (fn2fp b)- in do_backup >> mRename a b)- (\e -> case () of- _ | isPermissionError e -> ioError $ userError $- couldNotRename ++ "."- | isDoesNotExistError e -> ioError $ userError $- couldNotRename ++ " because " ++ x ++ " does not exist."- | otherwise -> ioError e- )- where- x = fn2fp a- y = fn2fp b- couldNotRename = "Could not rename " ++ x ++ " to " ++ y--backup :: FileName -> IO ()-backup f = backupByRenaming (fn2fp f)
− src/Darcs/Lock.hs
@@ -1,346 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, ForeignFunctionInterface #-}--module Darcs.Lock ( withLock, withLockCanFail,- withTemp, withOpenTemp, withStdoutTemp,- withTempDir, withPermDir, withDelayedDir, withNamedTemp,- writeToFile, appendToFile,- writeBinFile, writeLocaleFile, writeDocBinFile,- appendBinFile, appendDocBinFile,- readBinFile, readLocaleFile, readDocBinFile,- writeAtomicFilePS,- gzWriteAtomicFilePS, gzWriteAtomicFilePSs, gzWriteDocFile,- rmRecursive, removeFileMayNotExist,- canonFilename, maybeRelink,- worldReadableTemp, tempdirLoc,- editText,- environmentHelpTmpdir, environmentHelpKeepTmpdir- ) where--import Prelude hiding ( catch )-import Data.List ( inits )-import Data.Maybe ( isJust, listToMaybe )-import System.Exit ( exitWith, ExitCode(..) )-import System.IO ( openBinaryFile, openBinaryTempFile,- hClose, hPutStr, Handle,- IOMode(WriteMode, AppendMode), hFlush, stdout )-import System.IO.Error ( isDoesNotExistError, isAlreadyExistsError )-import Control.Exception.Extensible- ( bracket, throwIO, catch, try, SomeException )-import System.Directory ( removeFile, removeDirectory,- doesFileExist, doesDirectoryExist,- getDirectoryContents, createDirectory,- getTemporaryDirectory,- )-import System.FilePath.Posix ( splitDirectories )-import Workaround ( renameFile )-import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO, runEditor )-import Control.Monad ( unless, when )--import Darcs.URL ( isRelative )-import Darcs.Utils ( catchall, addToErrorLoc )-import Darcs.RepoPath ( AbsolutePath, FilePathLike, toFilePath,- getCurrentDirectory, setCurrentDirectory )--import ByteStringUtils ( gzWriteFilePSs, decodeLocale, encodeLocale )-import qualified Data.ByteString as B (null, readFile, writeFile, hPut, ByteString)-import qualified Data.ByteString.Char8 as BC (unpack)--import Darcs.SignalHandler ( withSignalsBlocked )-import Printer ( Doc, hPutDoc, packedString, empty, renderPSs )-import Darcs.Global ( atexit, darcsdir )-import Darcs.Compat ( mkStdoutTemp, canonFilename, maybeRelink,- atomicCreate, sloppyAtomicCreate )-import System.Posix.Files ( getSymbolicLinkStatus, isDirectory,- fileMode, getFileStatus, setFileMode )-import System.Posix ( sleep )-#include "impossible.h"--withLock :: String -> IO a -> IO a-releaseLock :: String -> IO ()--withLock s job = bracket (getlock s 30) releaseLock (\_ -> job)---- | Tries to perform some task if it can obtain the lock,--- Otherwise, just gives up without doing the task-withLockCanFail :: String -> IO a -> IO (Either () a)-withLockCanFail s job =- bracket (takeLock s)- (\l -> when l $ releaseLock s)- (\l -> if l then job >>= (return.Right)- else return $ Left ())--getlock :: String -> Int -> IO String-getlock l 0 = do putStrLn $ "Couldn't get lock "++l- exitWith $ ExitFailure 1-getlock lbad tl = do l <- canonFilename lbad- gotit <- takeLock l- if gotit then return l- else do putStrLn $ "Waiting for lock "++l- hFlush stdout -- for Windows- done <- sleep 2- if done == 0- then getlock l (tl - 1)- else getlock l 0--removeFileMayNotExist :: FilePathLike p => p -> IO ()-removeFileMayNotExist f = catchNonExistence (removeFile $ toFilePath f) ()--catchNonExistence :: IO a -> a -> IO a-catchNonExistence job nonexistval =- catch job $- \e -> if isDoesNotExistError e then return nonexistval- else ioError e--releaseLock s = removeFileMayNotExist s--takeLock :: FilePathLike p => p -> IO Bool-takeLock fp =- do atomicCreate $ toFilePath fp- return True- `catch` \e -> if isAlreadyExistsError e- then return False- else do pwd <- getCurrentDirectory- throwIO $ addToErrorLoc e- ("takeLock "++toFilePath fp++" in "++toFilePath pwd)--takeFile :: FilePath -> IO Bool-takeFile fp =- do sloppyAtomicCreate fp- return True- `catch` \e -> if isAlreadyExistsError e- then return False- else do pwd <- getCurrentDirectory- throwIO $ addToErrorLoc e- ("takeFile "++fp++" in "++toFilePath pwd)---- |'withTemp' safely creates an empty file (not open for writing) and--- returns its name.------ The temp file operations are rather similar to the locking operations, in--- that they both should always try to clean up, so exitWith causes trouble.-withTemp :: (String -> IO a) -> IO a-withTemp = bracket get_empty_file removeFileMayNotExist- where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs"- hClose h- return f---- |'withOpenTemp' creates a temporary file, and opens it.--- Both of them run their argument and then delete the file. Also,--- both of them (to my knowledge) are not susceptible to race conditions on--- the temporary file (as long as you never delete the temporary file; that--- would reintroduce a race condition).-withOpenTemp :: ((Handle, String) -> IO a) -> IO a-withOpenTemp = bracket get_empty_file cleanup--- Warning: A do-notation statement discarded a result of type Either SomeException ().- where cleanup (h,f) = do _ <- try (hClose h) :: IO (Either SomeException ())- removeFileMayNotExist f- get_empty_file = invert `fmap` openBinaryTempFile "." "darcs"- invert (a,b) = (b,a)--withStdoutTemp :: (String -> IO a) -> IO a-withStdoutTemp = bracket (mkStdoutTemp "stdout_") removeFileMayNotExist--tempdirLoc :: IO FilePath-tempdirLoc = firstJustIO [ readBinFile (darcsdir++"/prefs/tmpdir") >>= return . Just . head.words >>= chkdir,- maybeGetEnv "DARCS_TMPDIR" >>= chkdir,- getTemporaryDirectory >>= chkdir . Just,- getCurrentDirectorySansDarcs,- return $ Just "." -- always returns a Just- ]- >>= return . fromJust- where chkdir Nothing = return Nothing- chkdir (Just d) = doesDirectoryExist d >>= return . \e -> if e then Just (d++"/") else Nothing--environmentHelpTmpdir :: ([String], [String])-environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [- "Darcs often creates temporary directories. For example, the `darcs",- "diff' command creates two for the working trees to be diffed. By",- "default temporary directories are created in /tmp, or if that doesn't",- "exist, in _darcs (within the current repo). This can be overridden by",- "specifying some other directory in the file _darcs/prefs/tmpdir or the",- "environment variable $DARCS_TMPDIR or $TMPDIR."])--getCurrentDirectorySansDarcs :: IO (Maybe FilePath)-getCurrentDirectorySansDarcs = do- c <- getCurrentDirectory- return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits $ toFilePath c- where no_darcs x = not $ darcsdir `elem` splitDirectories x--data WithDirKind = Perm | Temp | Delayed--withDir :: WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a-withDir _ "" _ = bug "withDir called with empty directory name"-withDir kind abs_or_relative_name job = do- absolute_name <- if isRelative abs_or_relative_name- then fmap (++ abs_or_relative_name) tempdirLoc- else return abs_or_relative_name- formerdir <- getCurrentDirectory- bracket (create_directory absolute_name 0)- (\dir -> do setCurrentDirectory formerdir- k <- keep_tmpdir- unless k $ do case kind of- Perm -> return ()- Temp -> rmRecursive (toFilePath dir)- Delayed -> atexit $ rmRecursive (toFilePath dir))- job- where newname name 0 = name- newname name n = name ++ "-" ++ show n- create_directory :: FilePath -> Int -> IO AbsolutePath- create_directory name n- = do createDirectory $ newname name n- setCurrentDirectory $ newname name n- getCurrentDirectory- `catch` (\e -> if isAlreadyExistsError e- then create_directory name (n+1)- else throwIO e)- keep_tmpdir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR"--environmentHelpKeepTmpdir :: ([String], [String])-environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[- "If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will",- "not remove the temporary directories it creates. This is intended",- "primarily for debugging Darcs itself, but it can also be useful, for",- "example, to determine why your test preference (see `darcs setpref')",- "is failing when you run `darcs record', but working when run manually."])---- |'withPermDir' is like 'withTempDir', except that it doesn't--- delete the directory afterwards.-withPermDir :: String -> (AbsolutePath -> IO a) -> IO a-withPermDir = withDir Perm---- |'withTempDir' creates an empty directory and then removes it when it--- is no longer needed. withTempDir creates a temporary directory. The--- location of that directory is determined by the contents of--- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if--- that doesn't exist then whatever your operating system considers to be a--- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under--- Windows).------ If none of those exist it creates the temporary directory--- in the current directory, unless the current directory is under a _darcs--- directory, in which case the temporary directory in the parent of the highest--- _darcs directory to avoid accidentally corrupting darcs's internals.--- This should not fail, but if it does indeed fail, we go ahead and use the--- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set--- temporary directory is not removed, this can be useful for debugging.-withTempDir :: String -> (AbsolutePath -> IO a) -> IO a-withTempDir = withDir Temp--withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a-withDelayedDir = withDir Delayed--doesDirectoryReallyExist :: FilePath -> IO Bool-doesDirectoryReallyExist f =- catchNonExistence (isDirectory `fmap` getSymbolicLinkStatus f) False--rmRecursive :: FilePath -> IO ()-rmRecursive d =- do isd <- doesDirectoryReallyExist d- if not isd- then removeFile d- else do conts <- actual_dir_contents- withCurrentDirectory d $- mapM_ rmRecursive conts- removeDirectory d- where actual_dir_contents = -- doesn't include . or ..- do c <- getDirectoryContents d- return $ filter (/=".") $ filter (/="..") c--worldReadableTemp :: String -> IO String-worldReadableTemp f = wrt 0- where wrt :: Int -> IO String- wrt 100 = fail $ "Failure creating temp named "++f- wrt n = let f_new = f++"-"++show n- in do ok <- takeFile f_new- if ok then return f_new- else wrt (n+1)--withNamedTemp :: String -> (String -> IO a) -> IO a-withNamedTemp n = bracket get_empty_file removeFileMayNotExist- where get_empty_file = worldReadableTemp n--editText :: String -> B.ByteString -> IO B.ByteString-editText desc txt = withNamedTemp desc $ \f -> do- B.writeFile f txt--- Warning: A do-notation statement discarded a result of type ExitCode.- _ <- runEditor f- B.readFile f--readBinFile :: FilePathLike p => p -> IO String-readBinFile = fmap BC.unpack . B.readFile . toFilePath---- | Reads a file. Differs from readBinFile in that it interprets the file in--- the current locale instead of as ISO-8859-1.-readLocaleFile :: FilePathLike p => p -> IO String-readLocaleFile f = decodeLocale `fmap` B.readFile (toFilePath f)--readDocBinFile :: FilePathLike p => p -> IO Doc-readDocBinFile fp = do ps <- B.readFile $ toFilePath fp- return $ if B.null ps then empty else packedString ps--appendBinFile :: FilePathLike p => p -> String -> IO ()-appendBinFile f s = appendToFile f $ \h -> hPutStr h s--appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()-appendDocBinFile f d = appendToFile f $ \h -> hPutDoc h d--writeBinFile :: FilePathLike p => p -> String -> IO ()-writeBinFile f s = writeToFile f $ \h -> hPutStr h s---- | Writes a file. Differs from writeBinFile in that it writes the string--- encoded with the current locale instead of what GHC thinks is right.-writeLocaleFile :: FilePathLike p => p -> String -> IO ()-writeLocaleFile f s = writeToFile f $ \h -> B.hPut h (encodeLocale s)--writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()-writeDocBinFile f d = writeToFile f $ \h -> hPutDoc h d--writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()-writeAtomicFilePS f ps = writeToFile f $ \h -> B.hPut h ps--gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()-gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps]--gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO ()-gzWriteAtomicFilePSs f pss =- withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do- gzWriteFilePSs newf pss- already_exists <- doesFileExist $ toFilePath f- when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)- setFileMode newf mode- `catchall` return ()- renameFile newf (toFilePath f)--gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()-gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs d--writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()-writeToFile f job =- withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do- bracket (openBinaryFile newf WriteMode) hClose job- already_exists <- doesFileExist (toFilePath f)- when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)- setFileMode newf mode- `catchall` return ()- renameFile newf (toFilePath f)--appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()-appendToFile f job = withSignalsBlocked $- bracket (openBinaryFile (toFilePath f) AppendMode) hClose job
− src/Darcs/Match.hs
@@ -1,463 +0,0 @@--- Copyright (C) 2004-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, Rank2Types #-}--#include "gadts.h"---- | /First matcher, Second matcher and Nonrange matcher/------ When we match for patches, we have a PatchSet, of which we want a--- subset. This subset is formed by the patches in a given interval--- which match a given criterion. If we represent time going left to--- right, then we have (up to) three 'Matcher's:------ * the 'firstMatcher' is the left bound of the interval,------ * the 'secondMatcher' is the right bound, and------ * the 'nonrangeMatcher' is the criterion we use to select among--- patches in the interval.------- Each of these matchers can be present or not according to the--- options. The patches we want would then be the ones that all--- present matchers have in common.------ (Implementation note: keep in mind that the PatchSet is written--- backwards with respect to the timeline, ie., from right to left)-module Darcs.Match ( matchFirstPatchset, matchSecondPatchset,- matchPatch,- matchAPatch, matchAPatchread,- getFirstMatch, getNonrangeMatch, getNonrangeMatchS,- getPartialFirstMatch, getPartialSecondMatch,- getPartialNonrangeMatch,- firstMatch, secondMatch, haveNonrangeMatch,- havePatchsetMatch, getOnePatchset,- checkMatchSyntax, applyInvToMatcher, nonrangeMatcher,- InclusiveOrExclusive(..), matchExists, applyNInv, hasIndexRange- ) where--import Text.Regex ( mkRegex, matchRegex )-import Control.Monad ( when )-import Data.Maybe ( isJust )-import Data.List ( isPrefixOf )--import Darcs.MonadProgress ( MonadProgress )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, piap,- conscientiously, hopefully )-import Darcs.Patch.Info ( justName )-import Darcs.Patch ( RepoPatch, Patchy, Named, invert, invertRL, patch2patchinfo, apply )-import Darcs.Patch.Dummy ( DummyPatch )-import Darcs.Repository ( Repository, readRepo, createPristineDirectoryTree )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL )-import Darcs.Patch.Apply( ApplyState )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Repository.ApplyPatches ( applyPatches )-import Darcs.Patch.Depends ( getPatchesBeyondTag, splitOnTag )-import Darcs.Witnesses.Ordered ( RL(..), consRLSealed, (:>)(..) )--import ByteStringUtils ( mmapFilePS )--import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context,- AfterPatch, UpToPatch, LastN, PatchIndexRange,- OneTag, AfterTag, UpToTag,- OnePattern, SeveralPattern,- AfterPattern, UpToPattern ) )-import Darcs.Patch.Bundle ( scanContext )-import Darcs.Patch.Match ( Matcher, MatchFun, matchPattern, applyMatcher, makeMatcher, parseMatch )-import Darcs.Patch.MatchData ( PatchMatch )-import Printer ( text, ($$) )--import Darcs.RepoPath ( toFilePath )-import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )-import Darcs.Patch.FileName ( FileName )-import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed2(..),- seal, flipSeal, seal2, unsealFlipped, unseal2, unseal )-import Storage.Hashed.Tree ( Tree )-#include "impossible.h"--data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq---- | @haveNonrangeMatch flags@ tells whether there is a flag in--- @flags@ which corresponds to a match that is "non-range". Thus,--- @--match@, @--patch@ and @--index@ make @haveNonrangeMatch@--- true, but not @--from-patch@ or @--to-patch@.-haveNonrangeMatch :: [DarcsFlag] -> Bool-haveNonrangeMatch fs = isJust (hasIndexRange fs) || isJust (nonrangeMatcher fs::Maybe (Matcher DummyPatch))---- | @havePatchsetMatch flags@ tells whether there is a "patchset--- match" in the flag list. A patchset match is @--match@ or--- @--patch@, or @--context@, but not @--from-patch@ nor (!)--- @--index@.--- Question: Is it supposed not to be a subset of @haveNonrangeMatch@?-havePatchsetMatch :: [DarcsFlag] -> Bool-havePatchsetMatch fs = isJust (nonrangeMatcher fs::Maybe (Matcher DummyPatch)) || hasC fs- where hasC [] = False- hasC (Context _:_) = True- hasC (_:xs) = hasC xs--getNonrangeMatch :: (ApplyMonad IO (ApplyState p), RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> [DarcsFlag] -> IO ()-getNonrangeMatch r fs = withRecordedMatch r (getNonrangeMatchS fs)--getPartialNonrangeMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)- => Repository p C(r u t)- -> [DarcsFlag] -> [FileName] -> IO ()-getPartialNonrangeMatch r fs _ =- withRecordedMatch r (getNonrangeMatchS fs)--getNonrangeMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, RepoPatch p, ApplyState p ~ Tree) =>- [DarcsFlag] -> PatchSet p C(Origin x) -> m ()-getNonrangeMatchS fs repo =- case nonrangeMatcher fs of- Just m -> if nonrangeMatcherIsTag fs- then getTagS m repo- else getMatcherS Exclusive m repo- Nothing -> fail "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--- than against all patches since the creation of the repository.-firstMatch :: [DarcsFlag] -> Bool-firstMatch fs = isJust (hasLastn fs)- || isJust (firstMatcher fs::Maybe (Matcher DummyPatch))- || isJust (hasIndexRange fs)--getFirstMatch :: (ApplyMonad IO (ApplyState p), RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> [DarcsFlag] -> IO ()-getFirstMatch r fs = withRecordedMatch r (getFirstMatchS fs)--getPartialFirstMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)- => Repository p C(r u t)- -> [DarcsFlag] -> Maybe [FileName] -> IO ()-getPartialFirstMatch r fs _ =- withRecordedMatch r (getFirstMatchS fs)--getFirstMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, RepoPatch p) =>- [DarcsFlag] -> PatchSet p C(Origin x) -> m ()-getFirstMatchS fs repo =- case hasLastn fs of- Just n -> unpullLastN repo n- Nothing ->- case hasIndexRange fs of- Just (_,b) -> unpullLastN repo b -- b is chronologically earlier than a- Nothing ->- case firstMatcher fs of- Nothing -> fail "Pattern not specified in getFirstMatch."- Just m -> if firstMatcherIsTag fs- then getTagS m repo- else getMatcherS Inclusive m repo---- | @secondMatch fs@ tells whether @fs@ implies a "second match", that--- is if we match against patches up to a point in the past on, rather--- than against all patches until now.-secondMatch :: [DarcsFlag] -> Bool-secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher DummyPatch)) || isJust (hasIndexRange fs)--getPartialSecondMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)- => Repository p C(r u t)- -> [DarcsFlag] -> Maybe [FileName] -> IO ()-getPartialSecondMatch r fs _ =- withRecordedMatch r $ \repo ->- case secondMatcher fs of- Nothing -> case hasIndexRange fs of- Just (a,_) -> unpullLastN repo (a-1)- Nothing -> fail "Two patterns not specified in get_second_match."- Just m -> if secondMatcherIsTag fs- then getTagS m repo- else getMatcherS Exclusive m repo--unpullLastN :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p) => PatchSet p C(x y) -> Int -> m ()-unpullLastN repo n = applyInvRL `unsealFlipped` (safetake n $ newset2RL repo)--checkMatchSyntax :: [DarcsFlag] -> IO ()-checkMatchSyntax opts =- case getMatchPattern opts of- Nothing -> return ()- Just p -> either fail (const $ return ()) $ (parseMatch p::Either String (MatchFun DummyPatch))--getMatchPattern :: [DarcsFlag] -> Maybe PatchMatch-getMatchPattern [] = Nothing-getMatchPattern (OnePattern m:_) = Just m-getMatchPattern (SeveralPattern m:_) = Just m-getMatchPattern (_:fs) = getMatchPattern fs--tagmatch :: String -> Matcher p-tagmatch r = makeMatcher ("tag-name "++r) tm- where tm (Sealed2 p) =- let n = justName (info p) in- "TAG " `isPrefixOf` n && isJust (matchRegex (mkRegex r) $ drop 4 n)--mymatch :: String -> Matcher p-mymatch r = makeMatcher ("patch-name "++r) mm- where mm (Sealed2 p) = isJust . matchRegex (mkRegex r) . justName . info $ p----- | strictJust is a strict version of the Just constructor, used to ensure--- that if we claim we've got a pattern match, that the pattern will--- actually match (rathern than fail to compile properly).-strictJust :: a -> Maybe a-strictJust x = Just $! x---- | @nonrangeMatcher@ is the criterion that is used to match against--- patches in the interval. It is 'Just m' when the @--patch@, @--match@,--- @--tag@ options are passed (or their plural variants).-nonrangeMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)-nonrangeMatcher [] = Nothing-nonrangeMatcher (OnePattern m:_) = strictJust $ matchPattern m-nonrangeMatcher (OneTag t:_) = strictJust $ tagmatch t-nonrangeMatcher (OnePatch p:_) = strictJust $ mymatch p-nonrangeMatcher (SeveralPattern m:_) = strictJust $ matchPattern m-nonrangeMatcher (SeveralPatch p:_) = strictJust $ mymatch p-nonrangeMatcher (_:fs) = nonrangeMatcher fs---- | @nonrangeMatcherIsTag@ returns true if the matching option was--- '--tag'-nonrangeMatcherIsTag :: [DarcsFlag] -> Bool-nonrangeMatcherIsTag [] = False-nonrangeMatcherIsTag (OneTag _:_) = True-nonrangeMatcherIsTag (_:fs) = nonrangeMatcherIsTag fs---- | @firstMatcher@ returns the left bound of the matched interval.--- This left bound is also specified when we use the singular versions--- of @--patch@, @--match@ and @--tag@. Otherwise, @firstMatcher@--- returns @Nothing@.-firstMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)-firstMatcher [] = Nothing-firstMatcher (OnePattern m:_) = strictJust $ matchPattern m-firstMatcher (AfterPattern m:_) = strictJust $ matchPattern m-firstMatcher (AfterTag t:_) = strictJust $ tagmatch t-firstMatcher (OnePatch p:_) = strictJust $ mymatch p-firstMatcher (AfterPatch p:_) = strictJust $ mymatch p-firstMatcher (_:fs) = firstMatcher fs--firstMatcherIsTag :: [DarcsFlag] -> Bool-firstMatcherIsTag [] = False-firstMatcherIsTag (AfterTag _:_) = True-firstMatcherIsTag (_:fs) = firstMatcherIsTag fs--secondMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)-secondMatcher [] = Nothing-secondMatcher (OnePattern m:_) = strictJust $ matchPattern m-secondMatcher (UpToPattern m:_) = strictJust $ matchPattern m-secondMatcher (OnePatch p:_) = strictJust $ mymatch p-secondMatcher (UpToPatch p:_) = strictJust $ mymatch p-secondMatcher (UpToTag t:_) = strictJust $ tagmatch t-secondMatcher (_:fs) = secondMatcher fs--secondMatcherIsTag :: [DarcsFlag] -> Bool-secondMatcherIsTag [] = False-secondMatcherIsTag (UpToTag _:_) = True-secondMatcherIsTag (_:fs) = secondMatcherIsTag fs---- | @matchAPatchread fs p@ tells whether @p@ matches the matchers in--- the flags listed in @fs@.-matchAPatchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool-matchAPatchread fs = case nonrangeMatcher fs of- Nothing -> const True- Just m -> applyMatcher m---- | @matchAPatch fs p@ tells whether @p@ matches the matchers in--- the flags @fs@-matchAPatch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool-matchAPatch fs p =- case nonrangeMatcher fs of- Nothing -> True- Just m -> applyMatcher m (patch2patchinfo p `piap` p)--matchPatch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> Sealed2 (Named p)-matchPatch fs ps =- case hasIndexRange fs of- Just (a,a') | a == a' -> case (unseal myhead) $ dropn (a-1) ps of- Just (Sealed2 p) -> seal2 $ hopefully p- Nothing -> error "Patch out of range!"- | otherwise -> bug ("Invalid index range match given to matchPatch: "++- show (PatchIndexRange a a'))- where myhead :: PatchSet p C(start x) -> Maybe (Sealed2 (PatchInfoAnd p))- myhead (PatchSet NilRL (Tagged t _ _ :<: _)) = Just $ seal2 t- myhead (PatchSet (x:<:_) _) = Just $ seal2 x- myhead _ = Nothing- Nothing -> case nonrangeMatcher fs of- Nothing -> bug "Couldn't matchPatch"- Just m -> findAPatch m ps--getOnePatchset :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> [DarcsFlag] ->- IO (SealedPatchSet p C(Origin))-getOnePatchset repository fs =- case nonrangeMatcher fs of- Just m -> do ps <- readRepo repository- if nonrangeMatcherIsTag fs- then return $ getMatchingTag m ps- else return $ matchAPatchset m ps- Nothing -> (seal . scanContext) `fmap` mmapFilePS (toFilePath $ context_f fs)- where context_f [] = bug "Couldn't match_nonrange_patchset"- context_f (Context f:_) = f- context_f (_:xs) = context_f xs---- | @hasLastn fs@ return the @--last@ argument in @fs@, if any.-hasLastn :: [DarcsFlag] -> Maybe Int-hasLastn [] = Nothing-hasLastn (LastN (-1):_) = error "--last requires a positive integer argument."-hasLastn (LastN n:_) = Just n-hasLastn (_:fs) = hasLastn fs--hasIndexRange :: [DarcsFlag] -> Maybe (Int,Int)-hasIndexRange [] = Nothing-hasIndexRange (PatchIndexRange x y:_) = Just (x,y)-hasIndexRange (_:fs) = hasIndexRange fs---- | @matchFirstPatchset fs ps@ returns the part of @ps@ before its--- first matcher, ie the one that comes first dependencywise. Hence,--- patches in @matchFirstPatchset fs ps@ are the context for the ones--- we don't want.-matchFirstPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x)- -> SealedPatchSet p C(start)-matchFirstPatchset fs patchset =- case hasLastn fs of- Just n -> dropn n patchset- Nothing ->- case hasIndexRange fs of- Just (_,b) -> dropn b patchset- Nothing ->- case firstMatcher fs of- Nothing -> bug "Couldn't matchFirstPatchset"- Just m -> unseal (dropn 1) $ if firstMatcherIsTag fs- then getMatchingTag m patchset- else matchAPatchset m patchset---- | @dropn n ps@ drops the @n@ last patches from @ps@.-dropn :: Int -> PatchSet p C(start x) -> SealedPatchSet p C(start)-dropn n ps | n <= 0 = seal ps-dropn n (PatchSet NilRL (Tagged t _ ps :<: ts)) = dropn n $ PatchSet (t:<:ps) ts-dropn _ (PatchSet NilRL NilRL) = seal $ PatchSet NilRL NilRL-dropn n (PatchSet (_:<:ps) ts) = dropn (n-1) $ PatchSet ps ts---- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its--- second matcher, ie the one that comes last dependencywise.-matchSecondPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x)- -> SealedPatchSet p C(start)-matchSecondPatchset fs ps =- case hasIndexRange fs of- Just (a,_) -> dropn (a-1) ps- Nothing ->- case secondMatcher fs of- Nothing -> bug "Couldn't matchSecondPatchset"- Just m -> if secondMatcherIsTag fs- then getMatchingTag m ps- else matchAPatchset m ps---- | @findAPatch m ps@ returns the last patch in @ps@ matching @m@, and--- calls 'error' if there is none.-findAPatch :: RepoPatch p => Matcher p -> PatchSet p C(start x) -> Sealed2 (Named p)-findAPatch m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m-findAPatch m (PatchSet NilRL (Tagged t _ ps :<: ts)) = findAPatch m (PatchSet (t:<:ps) ts)-findAPatch m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal2 $ hopefully p- | otherwise = findAPatch m (PatchSet ps ts)---- | @matchAPatchset m ps@ returns a (the largest?) subset of @ps@--- ending in patch which matches @m@. Calls 'error' if there is none.-matchAPatchset :: RepoPatch p => Matcher p -> PatchSet p C(start x)- -> SealedPatchSet p C(start)-matchAPatchset m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m-matchAPatchset m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchAPatchset m (PatchSet (t:<:ps) ts)-matchAPatchset m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal (PatchSet (p:<:ps) ts)- | otherwise = matchAPatchset m (PatchSet ps ts)---- | @getMatchingTag m ps@, where @m@ is a 'Matcher' which matches tags--- returns a 'SealedPatchSet' containing all patches in the last tag which--- matches @m@. Last tag means the most recent tag in repository order,--- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls--- 'error' if there is no matching tag.-getMatchingTag :: RepoPatch p => Matcher p -> PatchSet p C(start x) -> SealedPatchSet p C(start)-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 =- -- 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--- @m@ in @ps@-matchExists :: Matcher p -> PatchSet p C(start x) -> Bool-matchExists _ (PatchSet NilRL NilRL) = False-matchExists m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchExists m (PatchSet (t:<:ps) ts)-matchExists m (PatchSet (p:<:ps) ts) | applyMatcher m $ p = True- | otherwise = matchExists m (PatchSet ps ts)--applyInvToMatcher :: (RepoPatch p, ApplyMonad m (ApplyState p))- => InclusiveOrExclusive -> Matcher p -> PatchSet p C(Origin x) -> m ()-applyInvToMatcher _ _ (PatchSet NilRL NilRL) = impossible-applyInvToMatcher ioe m (PatchSet NilRL (Tagged t _ ps :<: ts)) = applyInvToMatcher ioe m- (PatchSet (t:<:ps) ts)-applyInvToMatcher ioe m (PatchSet (p:<:ps) xs)- | applyMatcher m p = when (ioe == Inclusive) (applyInvp p)- | otherwise = applyInvp p >> applyInvToMatcher ioe m (PatchSet ps xs)---- | @applyNInv@ n ps applies the inverse of the last @n@ patches of @ps@.-applyNInv :: (RepoPatch p, ApplyMonad m (ApplyState p)) => Int -> PatchSet p C(Origin x) -> m ()-applyNInv n _ | n <= 0 = return ()-applyNInv _ (PatchSet NilRL NilRL) = error "Index out of range."-applyNInv n (PatchSet NilRL (Tagged t _ ps :<: ts)) =- applyNInv n (PatchSet (t :<: ps) ts)-applyNInv n (PatchSet (p :<: ps) xs) =- applyInvp p >> applyNInv (n - 1) (PatchSet ps xs)---getMatcherS :: (ApplyMonad m (ApplyState p), RepoPatch p) =>- InclusiveOrExclusive -> Matcher p -> PatchSet p C(Origin x) -> m ()-getMatcherS ioe m repo =- if matchExists m repo- then applyInvToMatcher ioe m repo- else fail $ "Couldn't match pattern "++ show m--getTagS :: (ApplyMonad m (ApplyState p), MonadProgress m, RepoPatch p) =>- Matcher p -> PatchSet p C(Origin x) -> m ()-getTagS match repo = do- let pinfo = patch2patchinfo `unseal2` (findAPatch match repo)- case getPatchesBeyondTag pinfo repo of- FlippedSeal extras -> applyInvRL extras---- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd--- patch', and to apply its inverse. If we fail to fetch the patch--- (presumably in a partial repositiory), then we share our sorrow--- with the user.-applyInvp :: (Patchy p, ApplyMonad m (ApplyState p)) => PatchInfoAnd p C(x y) -> m ()-applyInvp hp = apply (invert $ fromHopefully hp)- where fromHopefully = conscientiously $ \e ->- text "Sorry, partial repository problem. Patch not available:"- $$ e- $$ text ""- $$ text "If you think what you're trying to do is ok then"- $$ text "report this as a bug on the darcs-user list."---- | a version of 'take' for 'RL' lists that cater for contexts.-safetake :: Int -> RL a C(x y) -> FlippedSeal (RL a) C(y)-safetake 0 _ = flipSeal NilRL-safetake _ NilRL = error "There aren't that many patches..."-safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as--withRecordedMatch :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t)- -> (PatchSet p C(Origin r) -> IO ()) -> IO ()-withRecordedMatch r job = do createPristineDirectoryTree r "."- readRepo r >>= job--applyInvRL :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p) => RL (PatchInfoAnd p) C(x r) -> m ()-applyInvRL = applyPatches . invertRL -- this gives nicer feedback
− src/Darcs/MonadProgress.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}--- Copyright (C) 2011 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.--module Darcs.MonadProgress ( MonadProgress(..), ProgressAction(..)- , 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---- |a monadic action, annotated with a progress message that could be printed out--- while running the action, and a message that could be printed out on error.--- Actually printing out these messages is optional to allow non-IO monads to--- just run the action.-data ProgressAction m a =- ProgressAction- {paAction :: m a- ,paMessage :: Doc- ,paOnError :: Doc- }--class Monad m => MonadProgress m where- -- |run a list of 'ProgressAction's. In some monads (typically IO-based ones),- -- the progress and error messages will be used. In others they will be- -- ignored and just the actions will be run.- runProgressActions :: String -> [ProgressAction m ()] -> m ()--instance MonadProgress IO where- runProgressActions _ [] = return ()- runProgressActions what items =- do beginTedious what- tediousSize what (length items)- mapM_ go items- endTedious what- where go item =- do finishedOneIO what (show $ paMessage item)- paAction item `catch` \e ->- do hPutDocLn stderr $ paOnError item- ioError e---- |run a list of 'ProgressAction's without any feedback messages-silentlyRunProgressActions :: Monad m => String -> [ProgressAction m ()] -> m ()-silentlyRunProgressActions _ = mapM_ paAction--instance (Functor m, Monad m) => MonadProgress (HSM.TreeMonad m) where- runProgressActions = silentlyRunProgressActions
src/Darcs/Patch.hs view
@@ -18,14 +18,12 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP, UndecidableInstances #-} -- XXX Undecidable only in GHC < 7 -#include "gadts.h" module Darcs.Patch ( RepoPatch , PrimOf , Named , Patchy- , joinPatches , fromPrim , fromPrims , rmfile@@ -60,8 +58,6 @@ , Effect , effect , primIsBinary- , gzWritePatch- , writePatch , primIsAdddir , invert , invertFL@@ -92,13 +88,11 @@ ) where -import Darcs.Patch.Apply ( applyToFilePaths, effectOnFilePaths, applyToTree )-import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Apply ( applyToFilePaths, effectOnFilePaths, applyToTree,+ ApplyState ) import Darcs.Patch.Commute ( commuteFLorComplain, commuteRL )-import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts, listConflictedFiles, resolveConflicts )+import Darcs.Patch.Conflict ( listConflictedFiles, resolveConflicts ) import Darcs.Patch.Effect ( Effect(effect) )-import Darcs.Patch.FileHunk ( IsHunk )-import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Invert ( invertRL, invertFL ) import Darcs.Patch.Named ( Named, adddeps, namepatch,@@ -114,7 +108,7 @@ description, summary, summaryFL, commute, listTouchedFiles, hunkMatches )-import Darcs.Patch.Prim ( FromPrims, fromPrims, joinPatches, FromPrim, fromPrim,+import Darcs.Patch.Prim ( fromPrims, fromPrim, canonize, sortCoalesceFL, rmdir, rmfile, tokreplace, adddir, addfile,@@ -124,9 +118,9 @@ tryToShrink, PrimPatch, PrimPatchBase(..) ) import Darcs.Patch.Read ( readPatch, readPatchPartial )+import Darcs.Patch.Rebase.NameHack ( NameHack ) import Darcs.Patch.Repair ( isInconsistent ) import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.Show ( writePatch, gzWritePatch ) import Darcs.Patch.Summary ( xmlSummary, plainSummary, plainSummaryPrims ) import Darcs.Patch.TokenReplace ( forceTokReplace ) import Darcs.Patch.V1.Commute ( merge )@@ -134,5 +128,4 @@ import Storage.Hashed.Tree( Tree ) -instance (CommuteNoConflicts p, Conflict p, IsHunk p, PatchListFormat p,- PrimPatchBase p, Patchy p, ApplyState p ~ Tree) => Patchy (Named p)+instance (Patchy p, NameHack p, ApplyState p ~ Tree) => Patchy (Named p)
+ src/Darcs/Patch/Annotate.hs view
@@ -0,0 +1,282 @@+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# LANGUAGE CPP, OverloadedStrings, TypeSynonymInstances, MultiParamTypeClasses #-}++-- Copyright (C) 2010 Petr Rockai+--+-- 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.++-- |+-- Module : Darcs.Patch.Annotate+-- Copyright : 2010 Petr Rockai+-- License : MIT+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++module Darcs.Patch.Annotate+ (+ annotate+ , annotateDirectory+ , format+ , machineFormat+ , AnnotateResult+ ) where++import Prelude hiding ( pi )++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.Map as M+import qualified Data.Vector as V++import Data.Function ( on )+import Data.List( nub, groupBy )+import Data.Maybe( isJust, mapMaybe )++import Control.Monad.State ( modify, when, gets, State, execState )+import Control.Applicative( (<$>) )++import Darcs.Patch.ApplyMonad( ApplyMonad(..) )+import Darcs.Patch.Apply ( Apply, apply, ApplyState )+import Darcs.Patch.Info ( PatchInfo(..), showPatchInfoUI, piAuthor, makePatchname )+import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd )+import Darcs.Patch.Witnesses.Ordered++import Storage.Hashed.Tree( Tree )+import Darcs.Util.Path ( FileName, movedirfilename, fn2ps, ps2fn )+import Darcs.Util.Printer( renderString, RenderMode(..) )+import Darcs.Util.ByteString ( linesPS, unlinesPS )+import Darcs.Util.Diff ( getChanges )+import qualified Darcs.Util.Diff as D ( DiffAlgorithm )++#include "impossible.h"+++data FileOrDirectory = File+ | Directory+ deriving (Show, Eq)++data Annotated = Annotated+ { annotated :: V.Vector (Maybe PatchInfo, B.ByteString)+ , current :: [(Int, B.ByteString)]+ , path :: Maybe FileName+ , what :: FileOrDirectory+ , currentInfo :: PatchInfo+ , diffAlgorithm :: D.DiffAlgorithm+ } deriving Show++type AnnotateResult = V.Vector (Maybe PatchInfo, B.ByteString)++type AnnotatedM = State Annotated++-- XXX: No explicit method nor default method for 'editFile', 'editDirectory'+instance ApplyMonad AnnotatedM Tree where+ type ApplyMonadBase AnnotatedM = AnnotatedM++ nestedApply _ _ = undefinedFun "nestedApply"+ liftApply _ _ = undefinedFun "liftApply"+ getApplyState = undefinedFun "getApplyState"+ putApplyState _ = undefinedFun "putApplyState"+ mReadFilePS = undefinedFun "mReadFilePS"++ mDoesFileExist _ = return True+ mDoesDirectoryExist _ = return True+ mCreateDirectory _ = return ()+ mCreateFile _ = return ()++ mRemoveFile f = do+ p <- gets path+ when (p == Just f) $ modify (\x -> x { path = Nothing })+ updateDirectory f++ mRemoveDirectory = mRemoveFile++ mRename a b = do+ p <- gets path+ w <- gets what+ when (isJust p) $+ modify $ \st -> st { path = Just $ movedirfilename a b (fromJust p) }+ when (w == Directory) $ do+ let fix (i, x) = (i, fn2ps $ movedirfilename a b (ps2fn x))+ modify $ \st -> st { current = map fix $ current st }++ mModifyFilePS f job = do+ p <- gets path+ when (p == Just f) $ updateFile (fmap linesPS . job . unlinesPS)++ mModifyFilePSs f job = do+ p <- gets path+ when (p == Just f) $ updateFile job++undefinedFun :: Monad m+ => String+ -> m a+undefinedFun name = fail $ name ++ " undefined for Annotated"+++updateFile :: ([B.ByteString]+ -> AnnotatedM [B.ByteString])+ -> AnnotatedM ()+updateFile job = (==File) <$> gets what >>= flip when go+ where+ go = do+ before <- map snd `fmap` gets current+ after <- job before+ da <- gets diffAlgorithm+ reannotate $ getChanges da before after++ reannotate [] = return ()+ reannotate ((off, remove, add):rest) = do+ i <- gets currentInfo+ c <- gets current+ a <- gets annotated+ modify $ \s -> s { current = take off c ++ [ (-1, x) | x <- add ] +++ drop (off + length remove) c+ , annotated = merge i a $ take (length remove) $ drop off c+ }+ reannotate rest++ merge i a l = a V.// [ (line, (Just i, B.empty))+ | (line, _) <- l, line >= 0 && line < V.length a]+++updateDirectory :: FileName -> AnnotatedM ()+updateDirectory p = (==Directory) <$> gets what >>= flip when go+ where+ go = do let line = fn2ps p+ files <- gets current+ case filter ((==line) . snd) files of+ [match@(ident, _)] -> reannotate ident match line+ _ -> return ()+ reannotate ident match line =+ modify $ \x -> x { annotated = annotated x V.// [ (ident, update line $ currentInfo x) ]+ , current = filter (/= match) $ current x }+ update line inf = (Just inf, BC.concat [ " -- created as: ", line ])+++complete :: Annotated -> Bool+complete x = V.all (isJust . fst) $ annotated x+++annotate' :: (Apply p, ApplyState p ~ Tree)+ => FL (PatchInfoAnd p) wX wY+ -> Annotated+ -> Annotated+annotate' NilFL ann = ann+annotate' (p :>: ps) ann+ | complete ann = ann+ | otherwise = annotate' ps $ execState (apply p) (ann { currentInfo = info p })+++annotate :: (Apply p, ApplyState p ~ Tree)+ => D.DiffAlgorithm+ -> FL (PatchInfoAnd p) wX wY+ -> FileName+ -> B.ByteString+ -> AnnotateResult+annotate da patches inipath inicontent = annotated $ annotate' patches initial+ where+ initial = Annotated { path = Just inipath+ , currentInfo = error "There is no currentInfo."+ , current = zip [0..] (linesPS inicontent)+ , what = File+ , annotated = V.replicate (length $ breakLines inicontent)+ (Nothing, B.empty)+ , diffAlgorithm = da+ }+++annotateDirectory :: (Apply p, ApplyState p ~ Tree)+ => D.DiffAlgorithm+ -> FL (PatchInfoAnd p) wX wY+ -> FileName+ -> [FileName]+ -> AnnotateResult+annotateDirectory da patches inipath inicontent = annotated $ annotate' patches initial+ where+ initial = Annotated { path = Just inipath+ , currentInfo = error "There is no currentInfo."+ , current = zip [0..] (map fn2ps inicontent)+ , what = Directory+ , annotated = V.replicate (length inicontent) (Nothing, B.empty)+ , diffAlgorithm = da+ }+++machineFormat :: B.ByteString -> AnnotateResult -> String+machineFormat d a = unlines [ case i of+ Just inf -> show $ makePatchname inf+ Nothing -> -- make unknowns uniform, for easier parsing+ take 40 ( repeat '0' ) -- fake hash of the right size+ ++ " | " ++ BC.unpack line ++ " " ++ BC.unpack add+ | ((i, add), line) <- zip (V.toList a) (breakLines d) ]+++format :: B.ByteString+ -> AnnotateResult+ -> String+format d a = pi_list ++ "\n" ++ numbered+ where+ numberedLines = zip [(1 :: Int)..] . lines $ file++ prependNum (lnum, annLine) =+ let maxDigits = length . show . length $ numberedLines+ lnumStr = show lnum+ paddingNum = maxDigits - length lnumStr+ in replicate paddingNum ' ' ++ lnumStr ++ ": " ++ annLine++ numbered = unlines . map prependNum $ numberedLines++ pi_list = unlines [ show n ++ ": " ++ renderString Encode (showPatchInfoUI i)+ | (n :: Int, i) <- zip [1..] pis ]++ file = concat [ annotation (fst $ head chunk) ++ " | " ++ line (head chunk) +++ "\n" ++ unlines [ indent 25 (" | " ++ line l) | l <- tail chunk ]+ | chunk <- file_ann ]++ pis = nub $ mapMaybe fst $ V.toList a++ pi_map = M.fromList (zip pis [1 :: Int ..])++ file_ann = groupBy ((==) `on` fst) $ zip (V.toList a) (breakLines d)++ line ((_, add), l) = BC.unpack $ BC.concat [l, " ", add]++ annotation (Just i, _) | Just n <- M.lookup i pi_map =+ pad 20 (piMail i) ++ " " ++ pad 4 ('#' : show n)+ annotation _ = pad 25 "unknown"++ pad n str = replicate (n - length str) ' ' ++ take n str++ indent n str = replicate n ' ' ++ str++ piMail pi+ | '<' `elem` piAuthor pi = takeWhile (/= '>') . drop 1 . dropWhile (/= '<') $ piAuthor pi+ | otherwise = piAuthor pi+++breakLines :: BC.ByteString+ -> [BC.ByteString]+breakLines s = case BC.split '\n' s of+ [] -> []+ split | BC.null (last split) -> init split+ | otherwise -> split+
src/Darcs/Patch/Apply.hs view
@@ -18,7 +18,6 @@ {-# LANGUAGE CPP, MultiParamTypeClasses #-} -#include "gadts.h" -- | -- Module : Darcs.Patch.Apply@@ -34,11 +33,14 @@ , applyToFilePaths , applyToTree , applyToState+ , applyToFileMods , effectOnFilePaths ) where import Prelude hiding ( catch, pi ) +import Data.Set ( Set )+ import Control.Applicative ( (<$>) ) import Control.Arrow ( (***) ) @@ -46,13 +48,14 @@ import Storage.Hashed.Monad( virtualTreeMonad ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..), withFileNames, ApplyMonadTrans(..) )-import Darcs.Patch.FileName( fn2fp, fp2fn )-import Darcs.Witnesses.Ordered ( FL(..), RL(..) )-+import Darcs.Util.Path( FileName, fn2fp, fp2fn )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )+import Darcs.Patch.Index.Monad ( withPatchMods )+import Darcs.Patch.Index.Types ( PatchMod ) class Apply p where type ApplyState p :: (* -> *) -> *- apply :: ApplyMonad m (ApplyState p) => p C(x y) -> m ()+ apply :: ApplyMonad m (ApplyState p) => p wX wY -> m () instance Apply p => Apply (FL p) where type ApplyState (FL p) = ApplyState p@@ -66,7 +69,7 @@ effectOnFilePaths :: (Apply p, ApplyState p ~ Tree)- => p C(x y)+ => p wX wY -> [FilePath] -> [FilePath] effectOnFilePaths p fps = fps' where@@ -74,7 +77,7 @@ applyToFilePaths :: (Apply p, ApplyState p ~ Tree)- => p C(x y)+ => p wX wY -> Maybe [(FilePath, FilePath)] -> [FilePath] -> ([FilePath], [FilePath], [(FilePath, FilePath)])@@ -87,14 +90,20 @@ -- | Apply a patch to a 'Tree', yielding a new 'Tree'. applyToTree :: (Apply p, Functor m, Monad m, ApplyState p ~ Tree)- => p C(x y)+ => p wX wY -> Tree m -> m (Tree m) applyToTree patch t = snd <$> virtualTreeMonad (apply patch) t -applyToState :: forall p m C(x y). (Apply p, ApplyMonadTrans m (ApplyState p))- => p C(x y)+applyToState :: forall p m wX wY. (Apply p, ApplyMonadTrans m (ApplyState p))+ => p wX wY -> (ApplyState p) m -> m ((ApplyState p) m) applyToState patch t = snd <$> runApplyMonad (apply patch) t+++--------------------------------------------------------------------------------+-- | Apply a patch to set of 'FileName's, yielding the new set of 'FileName's and 'PatchMod's+applyToFileMods :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Set FileName -> (Set FileName, [PatchMod FileName])+applyToFileMods patch = withPatchMods (apply patch)
src/Darcs/Patch/ApplyMonad.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-} {-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-} -- Copyright (C) 2010, 2011 Petr Rockai --@@ -26,13 +27,14 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M import qualified Storage.Hashed.Monad as HSM+import Data.Maybe ( fromMaybe ) import Storage.Hashed.Tree ( Tree )-import ByteStringUtils( linesPS, unlinesPS )-import Darcs.Patch.FileName( FileName, movedirfilename, fn2fp, isParentOrEqOf )-import Storage.Hashed.AnchoredPath( floatPath, AnchoredPath )+import Darcs.Util.ByteString( linesPS, unlinesPS )+import Darcs.Util.Path ( FileName, movedirfilename, fn2fp, isParentOrEqOf,+ floatPath, AnchoredPath ) import Control.Monad.State.Strict import Control.Monad.Identity( Identity )-import Darcs.MonadProgress+import Darcs.Patch.MonadProgress -- TODO should UUID/Object live somewhere more central? import Darcs.Patch.Prim.V3.ObjectMap ( UUID, ObjectMap, DirContent )@@ -131,10 +133,10 @@ -- filenames and an action, and returns the resulting triple of affected files, -- updated filename list and new rename details. If the rename-pairs are not -- present, a new list is generated from the filesnames.-withFileNames :: (Maybe [OrigFileNameOf]) -> [FileName] -> FilePathMonad a+withFileNames :: Maybe [OrigFileNameOf] -> [FileName] -> FilePathMonad a -> FilePathMonadState withFileNames mbofnos fps x = execState x ([], fps, ofnos) where- ofnos = maybe (map (\y -> (y, y)) fps) id mbofnos+ ofnos = fromMaybe (map (\y -> (y, y)) fps) mbofnos instance ApplyMonad FilePathMonad Tree where type ApplyMonadBase FilePathMonad = Identity
+ src/Darcs/Patch/ApplyPatches.hs view
@@ -0,0 +1,23 @@+module Darcs.Patch.ApplyPatches+ ( applyPatches+ ) where++import Darcs.Patch.Info ( showPatchInfoUI )+import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Patchy ( Patchy )+import Darcs.Patch.MonadProgress ( MonadProgress, ProgressAction(..), runProgressActions)++import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL )+import Darcs.Util.Printer ( text, ($$) )++applyPatches :: (MonadProgress m, ApplyMonad m (ApplyState p), Patchy p)+ => FL (PatchInfoAnd p) wX wY -> m ()+applyPatches ps = runProgressActions "Applying patch" (mapFL doApply ps)+ where+ doApply hp = ProgressAction { paAction = apply (hopefully hp)+ , paMessage = showPatchInfoUI (info hp)+ , paOnError = text "Unapplicable patch:" $$+ showPatchInfoUI (info hp)+ }
src/Darcs/Patch/Bracketed.hs view
@@ -1,12 +1,11 @@ module Darcs.Patch.Bracketed ( Bracketed(..), mapBracketed, unBracketed- , BracketedFL, mapBracketedFL_FL, unBracketedFL+ , BracketedFL, mapBracketedFLFL, unBracketedFL ) where -#include "gadts.h" import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Witnesses.Ordered ( FL(..), mapFL_FL, concatFL )+import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, concatFL ) -- |This type exists for legacy support of on-disk format patch formats. -- It is a wrapper type that explicitly tracks the nesting of braces and parens@@ -14,27 +13,27 @@ -- form when reading such patches normally, and also for round-tripping such -- patches when checking the hash in bundles. -- It shouldn't be used for anything else.-data Bracketed p C(x y) where- Singleton :: p C(x y) -> Bracketed p C(x y) -- A single patch, not wrapped in anything- Braced :: BracketedFL p C(x y) -> Bracketed p C(x y) -- A list of patches, wrapped in {}- Parens :: BracketedFL p C(x y) -> Bracketed p C(x y) -- A list of patches, wrapped in ()+data Bracketed p wX wY where+ Singleton :: p wX wY -> Bracketed p wX wY -- A single patch, not wrapped in anything+ Braced :: BracketedFL p wX wY -> Bracketed p wX wY -- A list of patches, wrapped in {}+ Parens :: BracketedFL p wX wY -> Bracketed p wX wY -- A list of patches, wrapped in () -type BracketedFL p C(x y) = FL (Bracketed p) C(x y)+type BracketedFL p wX wY = FL (Bracketed p) wX wY -unBracketed :: Bracketed p C(x y) -> FL p C(x y)+unBracketed :: Bracketed p wX wY -> FL p wX wY unBracketed (Singleton p) = p :>: NilFL unBracketed (Braced ps) = unBracketedFL ps unBracketed (Parens ps) = unBracketedFL ps -unBracketedFL :: BracketedFL p C(x y) -> FL p C(x y)+unBracketedFL :: BracketedFL p wX wY -> FL p wX wY unBracketedFL = concatFL . mapFL_FL unBracketed -mapBracketed :: (FORALL(a b) p C(a b) -> q C(a b)) -> Bracketed p C(x y) -> Bracketed q C(x y)+mapBracketed :: (forall wA wB . p wA wB -> q wA wB) -> Bracketed p wX wY -> Bracketed q wX wY mapBracketed f (Singleton p) = Singleton (f p)-mapBracketed f (Braced ps) = Braced (mapBracketedFL_FL f ps)-mapBracketed f (Parens ps) = Parens (mapBracketedFL_FL f ps)+mapBracketed f (Braced ps) = Braced (mapBracketedFLFL f ps)+mapBracketed f (Parens ps) = Parens (mapBracketedFLFL f ps) -mapBracketedFL_FL :: (FORALL(a b) p C(a b) -> q C(a b)) -> BracketedFL p C(x y) -> BracketedFL q C(x y)-mapBracketedFL_FL f ps = mapFL_FL (mapBracketed f) ps+mapBracketedFLFL :: (forall wA wB . p wA wB -> q wA wB) -> BracketedFL p wX wY -> BracketedFL q wX wY+mapBracketedFLFL f = mapFL_FL (mapBracketed f) instance PatchListFormat (Bracketed p)
src/Darcs/Patch/Bracketed/Instances.hs view
@@ -4,11 +4,10 @@ import Darcs.Patch.Bracketed ( Bracketed(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..) ) -import Darcs.Witnesses.Ordered ( FL(NilFL), mapFL )+import Darcs.Patch.Witnesses.Ordered ( FL(NilFL), mapFL ) -import Printer ( vcat, blueText, ($$) )+import Darcs.Util.Printer ( vcat, blueText, ($$) ) -#include "gadts.h" instance ShowPatchBasic p => ShowPatchBasic (Bracketed p) where showPatch (Singleton p) = showPatch p
src/Darcs/Patch/Bundle.hs view
@@ -17,56 +17,63 @@ {-# LANGUAGE CPP #-} -#include "gadts.h"--module Darcs.Patch.Bundle ( hashBundle, makeBundle2, makeBundleN, scanBundle,- contextPatches, scanContext, patchFilename, getContext,- parseBundle- ) where+module Darcs.Patch.Bundle+ ( hashBundle+ , makeBundle2+ , makeBundleN+ , scanBundle+ , contextPatches+ , scanContextFile+ , patchFilename+ , getContext+ , minContext+ , parseBundle+ ) where import Data.Char ( isAlpha, toLower, isDigit, isSpace )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, piap, fmapFL_PIAP,- patchInfoAndPatch,- unavailable, hopefully )-import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, readPatchPartial )+import qualified Data.ByteString as B ( ByteString, length, null, drop,+ isPrefixOf )+import qualified Data.ByteString.Char8 as BC ( unpack, break, pack )++import Storage.Hashed.Tree( Tree )+import Storage.Hashed.Monad( virtualTreeIO )++import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch,+ readPatchPartial ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Bracketed ( Bracketed, unBracketedFL ) import Darcs.Patch.Bracketed.Instances ()-import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, humanFriendly, isTag )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet )-import Darcs.Patch.Show ( ShowPatchBasic )+import Darcs.Patch.Commute( commute ) import Darcs.Patch.Depends ( slightlyOptimizePatchset )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo,+ showPatchInfoUI, isTag )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, piap, fmapFLPIAP, info,+ patchInfoAndPatch, unavailable, hopefully ) import Darcs.Patch.ReadMonads ( parseStrictly )-import Darcs.Patch.PatchInfoAnd( info )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( RL(..), FL(..), (:>)(..),- reverseFL, (+<+), mapFL, mapFL_FL, mapRL )-import Printer ( Doc, renderPS, newline, text, ($$),- (<>), vcat, vsep, renderString )--import ByteStringUtils ( linesPS, unlinesPS, dropSpace, substrPS)-import qualified Data.ByteString as B (ByteString, length, null, drop, isPrefixOf)-import qualified Data.ByteString.Char8 as BC (unpack, break, pack)--import SHA1( sha1PS )-import Darcs.Witnesses.Sealed ( Sealed(Sealed))+import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin )+import Darcs.Patch.Show ( ShowPatchBasic )+import Darcs.Patch.Witnesses.Ordered+ ( RL(..), FL(..), (:>)(..), reverseFL, (+<+),+ mapFL, mapFL_FL, mapRL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) -import Storage.Hashed.Tree( Tree )-import Storage.Hashed.Monad( virtualTreeIO )+import Darcs.Util.ByteString ( mmapFilePS, linesPS, unlinesPS, dropSpace, substrPS)+import Darcs.Util.Crypt.SHA1 ( sha1PS )+import Darcs.Util.Printer ( Doc, renderPS, newline, text, ($$),+ (<>), vcat, vsep, renderString, RenderMode(..) ) -- |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 -- modified in transit.-hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (Named p) C(x y) -> String-hashBundle to_be_sent = sha1PS $ renderPS- $ vcat (mapFL showPatch to_be_sent) <> newline+hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (Named p) wX wY+ -> String+hashBundle to_be_sent =+ show $ sha1PS $ renderPS Standard $ vcat (mapFL showPatch to_be_sent) <> newline makeBundleN :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO)- -> PatchSet p C(start x) -> FL (Named p) C(x y) -> IO Doc+ -> PatchSet p wStart wX -> FL (Named p) wX wY -> IO Doc makeBundleN the_s (PatchSet ps (Tagged t _ _ :<: _)) to_be_sent = makeBundle2 the_s (ps +<+ (t :<: NilRL)) to_be_sent to_be_sent makeBundleN the_s (PatchSet ps NilRL) to_be_sent =@@ -77,87 +84,90 @@ -- patch sequences are passed, a bundle with a mismatched hash will be -- generated, which is not the end of the world, but isn't very useful -- either.-makeBundle2 :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO) -> RL (PatchInfoAnd p) C(start x)- -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> IO Doc-makeBundle2 the_s common' to_be_sent to_be_sent2 =- do patches <- case the_s of- Just tree -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) tree- Nothing -> return (vsep $ mapFL showPatch to_be_sent)- return $ format patches- where format the_new = text ""- $$ text "New patches:"- $$ text ""- $$ the_new- $$ text ""- $$ text "Context:"- $$ text ""- $$ (vcat $ map showPatchInfo common)- $$ text "Patch bundle hash:"- $$ text (hashBundle to_be_sent2)- $$ text ""- common = mapRL info common'+makeBundle2 :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO)+ -> RL (PatchInfoAnd p) wStart wX -> FL (Named p) wX wY+ -> FL (Named p) wX wY -> IO Doc+makeBundle2 the_s common' to_be_sent to_be_sent2 = do+ patches <- case the_s of+ Just tree -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) tree+ Nothing -> return (vsep $ mapFL showPatch to_be_sent)+ return $ format patches+ where+ format the_new = text ""+ $$ text "New patches:"+ $$ text ""+ $$ the_new+ $$ text ""+ $$ text "Context:"+ $$ text ""+ $$ vcat (map showPatchInfo common)+ $$ text "Patch bundle hash:"+ $$ text (hashBundle to_be_sent2)+ $$ text ""+ common = mapRL info common' -parseBundle ::forall p. RepoPatch p => B.ByteString- -> Either String (Sealed ((PatchSet p :> FL (PatchInfoAnd p)) C(Origin)))-parseBundle ps- | B.null ps = Left "Bad patch bundle!"- | otherwise =- case sillyLex ps of- ("New patches:",rest) ->- case getPatches rest of- (Sealed bracketedPatches, rest') ->- case sillyLex rest' of- ("Context:", rest'') ->- case getContext rest'' of- (cont,maybe_hash) ->- case substrPS (BC.pack "Patch bundle hash:")- maybe_hash of- Just n ->- if hashBundle (mapFL_FL hopefully bracketedPatches)- == fst (sillyLex $ snd $ sillyLex $- B.drop n maybe_hash)- then Right $ sealContextWithPatches cont bracketedPatches- else Left $- "Patch bundle failed hash!\n" ++- "This probably means that the patch has been "++- "corrupted by a mailer.\n"++- "The most likely culprit is CRLF newlines."- Nothing -> Right $ sealContextWithPatches cont bracketedPatches- (a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'"- ++ "\n" ++ BC.unpack r- ("Context:",rest) ->- case getContext rest of- (cont, rest') ->- case sillyLex rest' of- ("New patches:", rest'') ->- case getPatches rest'' of- (Sealed bracketedPatches, _) -> Right $ sealContextWithPatches cont bracketedPatches- (a,_) -> Left $ "Malformed patch bundle: '" ++ a ++- "' is not 'New patches:'"+parseBundle :: forall p. RepoPatch p => B.ByteString+ -> Either String+ (Sealed ((PatchSet p :> FL (PatchInfoAnd p)) Origin))+parseBundle input | B.null input = Left "Bad patch bundle!"+parseBundle input = case sillyLex input of+ ("New patches:", rest) -> case getPatches rest of+ (Sealed bracketedPatches, rest') -> case sillyLex rest' of+ ("Context:", rest'') -> case getContext rest'' of+ (cont, maybe_hash) ->+ let sealedCtxAndPs = sealCtxAndPs cont bracketedPatches in+ case substrPS (BC.pack "Patch bundle hash:") maybe_hash of+ Just n ->+ let hPs = mapFL_FL hopefully bracketedPatches+ realHash = hashBundle hPs+ getHash = fst . sillyLex . snd . sillyLex+ bundleHash = getHash $ B.drop n maybe_hash in+ if realHash == bundleHash+ then sealedCtxAndPs+ else Left hashFailureMessage+ Nothing -> sealedCtxAndPs+ (a, r) -> Left $ "Malformed patch bundle: '" ++ a+ ++ "' is not 'Context:'\n" ++ BC.unpack r+ ("Context:", rest) -> case getContext rest of+ (cont, rest') -> case sillyLex rest' of+ ("New patches:", rest'') -> case getPatches rest'' of+ (Sealed bracketedPatches, _) ->+ Right $ sealContextWithPatches cont bracketedPatches+ (a, _) -> Left $ "Malformed patch bundle: '" ++ a+ ++ "' is not 'New patches:'" ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->- parseBundle $ filterGpgDashes rest- (_,rest) -> parseBundle rest- where sealContextWithPatches :: RepoPatch p => [PatchInfo] -> FL (PatchInfoAnd (Bracketed p)) C(x y) -> Sealed ((PatchSet p :> FL (PatchInfoAnd p)) C(Origin))- sealContextWithPatches context bracketedPatches =- let patches = mapFL_FL (fmapFL_PIAP unBracketedFL) bracketedPatches in- case reverse context of- (x:ry) | isTag x ->- Sealed $ (PatchSet- (unavailablePatches (reverse ry))- (Tagged (piUnavailable x) Nothing NilRL :<: NilRL)- :> patches)- _ -> Sealed ((PatchSet (unavailablePatches context)- NilRL) :> patches)- -- The above NilRLs aren't quite right, because ther *are*- -- earlier patches, but we can't set this to undefined- -- because there are situations where we look at the rest.- -- :{+ parseBundle $ filterGpgDashes rest+ (_, rest) -> parseBundle rest+ where+ hashFailureMessage = "Patch bundle failed hash!\n"+ ++ "This probably means that the patch has been "+ ++ "corrupted by a mailer.\n"+ ++ "The most likely culprit is CRLF newlines." + sealCtxAndPs ctx ps = Right $ sealContextWithPatches ctx ps -scanBundle ::forall p . RepoPatch p => B.ByteString- -> Either String (SealedPatchSet p C(Origin))+ sealContextWithPatches :: RepoPatch p => [PatchInfo]+ -> FL (PatchInfoAnd (Bracketed p)) wX wY+ -> Sealed+ ((PatchSet p :> FL (PatchInfoAnd p)) Origin)+ sealContextWithPatches context bracketedPatches =+ let patches = mapFL_FL (fmapFLPIAP unBracketedFL) bracketedPatches in+ case reverse context of+ (x : ry) | isTag x ->+ let ps = unavailablePatches (reverse ry)+ t = Tagged (piUnavailable x) Nothing NilRL in+ Sealed $ PatchSet ps (t :<: NilRL) :> patches+ _ -> let ps = PatchSet (unavailablePatches context) NilRL in+ Sealed $ ps :> patches+ -- The above NilRLs aren't quite right, because ther *are*+ -- earlier patches, but we can't set this to undefined+ -- because there are situations where we look at the rest.+ -- :{++scanBundle :: forall p . RepoPatch p => B.ByteString+ -> Either String (SealedPatchSet p Origin) scanBundle bundle = do- Sealed ((PatchSet recent tagged):>ps) <- parseBundle bundle+ Sealed (PatchSet recent tagged :> ps) <- parseBundle bundle return . Sealed $ PatchSet (reverseFL ps +<+ recent) tagged -- |filterGpgDashes unescapes a clearsigned patch, which will have had any@@ -167,90 +177,117 @@ unlinesPS $ map drop_dashes $ takeWhile (/= BC.pack "-----END PGP SIGNED MESSAGE-----") $ dropWhile not_context_or_newpatches $ linesPS ps- where drop_dashes x = if B.length x < 2 then x- else if BC.pack "- " `B.isPrefixOf` x- then B.drop 2 x- else x- not_context_or_newpatches s = (s /= BC.pack "Context:") &&- (s /= BC.pack "New patches:")+ where+ drop_dashes x+ | B.length x < 2 = x+ | BC.pack "- " `B.isPrefixOf` x = B.drop 2 x+ | otherwise = x + not_context_or_newpatches s = (s /= BC.pack "Context:") &&+ (s /= BC.pack "New patches:")+ -- |unavailablePatches converts a list of PatchInfos into a RL of PatchInfoAnd -- Unavailable patches. This is used to represent the Context of a patchBundle.-unavailablePatches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd p) C(x y)-unavailablePatches [] = unsafeCoerceP NilRL-unavailablePatches (x:xs) = piUnavailable x :<: unavailablePatches xs+unavailablePatches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd p) wX wY+unavailablePatches = foldr ((:<:) . piUnavailable) (unsafeCoerceP NilRL) -- |piUnavailable returns an Unavailable within a PatchInfoAnd given a -- PatchInfo.-piUnavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd p C(x y)-piUnavailable i = (i `patchInfoAndPatch`- unavailable ("Patch not stored in patch bundle:\n" ++- renderString (humanFriendly i)))+piUnavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd p wX wY+piUnavailable i = patchInfoAndPatch i . unavailable $+ "Patch not stored in patch bundle:\n" ++ renderString Encode (showPatchInfoUI i) -- |getContext parses a context list, returning a tuple containing the list, -- and remaining ByteString input. getContext :: B.ByteString -> ([PatchInfo],B.ByteString)-getContext ps =- case parseStrictly readPatchInfo ps of- Just (pinfo,r') ->- case getContext r' of- (pis,r'') -> (pinfo:pis, r'')- Nothing -> ([],ps)+getContext ps = case parseStrictly readPatchInfo ps of+ Just (pinfo, r') -> case getContext r' of+ (pis, r'') -> (pinfo : pis, r'')+ Nothing -> ([], ps) -- |(-:-) is used to build up a Sealed FL of patches and tuple it, along with -- any unconsumed input.-(-:-) :: a C(x y) -> (Sealed (FL a C(y)),b) -> (Sealed (FL a C(x)),b)-p -:- (Sealed ps, r) = (Sealed (p:>:ps), r)+(-:-) :: a wX wY -> (Sealed (FL a wY), b) -> (Sealed (FL a wX), b)+p -:- (Sealed ps, r) = (Sealed (p :>: ps), r) -- |getPatches attempts to parse a sequence of patches from a ByteString, -- returning the FL of as many patches-with-info as were successfully parsed, -- along with any unconsumed input.-getPatches :: RepoPatch p => B.ByteString -> (Sealed (FL (PatchInfoAnd (Bracketed p)) C(x)), B.ByteString)-getPatches ps =- case parseStrictly readPatchInfo ps of+getPatches :: RepoPatch p => B.ByteString+ -> (Sealed (FL (PatchInfoAnd (Bracketed p)) wX), B.ByteString)+getPatches ps = case parseStrictly readPatchInfo ps of Nothing -> (Sealed NilFL, ps)- Just (pinfo,_) ->- case readPatchPartial ps of+ Just (pinfo, _) -> case readPatchPartial ps of Nothing -> (Sealed NilFL, ps) Just (Sealed p, r) -> (pinfo `piap` p) -:- getPatches r -- |sillyLex takes a ByteString and breaks it upon the first newline, having -- removed any leading spaces. The before-newline part is unpacked to a String,--- and tupled up with the remaining ByteString. +-- and tupled up with the remaining ByteString. sillyLex :: B.ByteString -> (String, B.ByteString) sillyLex ps = (BC.unpack a, b)- where- (a, b) = BC.break (== '\n') (dropSpace ps)+ where+ (a, b) = BC.break (== '\n') (dropSpace ps) -contextPatches :: RepoPatch p => PatchSet p C(Origin x) ->- (PatchSet p :> (RL (PatchInfoAnd p))) C(Origin x)+contextPatches :: RepoPatch p => PatchSet p Origin wX+ -> (PatchSet p :> RL (PatchInfoAnd p)) Origin wX contextPatches set = case slightlyOptimizePatchset set of- PatchSet ps (Tagged t _ ps' :<: ts)- -> (PatchSet ps' ts) :> (ps +<+ (t :<: NilRL))- PatchSet ps NilRL -> (PatchSet NilRL NilRL :> ps)+ PatchSet ps (Tagged t _ ps' :<: ts) ->+ PatchSet ps' ts :> (ps +<+ (t :<: NilRL))+ PatchSet ps NilRL -> PatchSet NilRL NilRL :> ps --- are the type witnesses sensible?-scanContext :: RepoPatch p => B.ByteString -> PatchSet p C(Origin x)-scanContext ps- | B.null ps = error "Bad context!"- | otherwise =- case sillyLex ps of- ("Context:",rest) ->- case getContext rest of- (cont@(_:_), _) | isTag (last cont) ->- PatchSet (unavailablePatches $ init cont)- (Tagged (piUnavailable $ last cont) Nothing NilRL :<: NilRL)- (cont, _) -> PatchSet (unavailablePatches cont) NilRL- ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->- scanContext $ filterGpgDashes rest- (_,rest) -> scanContext rest+-- |'scanContextFile' scans the context in the file of the given name.+scanContextFile :: RepoPatch p => FilePath -> IO (PatchSet p Origin wX)+scanContextFile filename = scanContext `fmap` mmapFilePS filename+ where+ -- are the type witnesses sensible?+ scanContext :: RepoPatch p => B.ByteString -> PatchSet p Origin wX+ scanContext input+ | B.null input = error "Bad context!"+ | otherwise = case sillyLex input of+ ("Context:",rest) -> case getContext rest of+ (cont@(_ : _), _) | isTag (last cont) ->+ let ps = unavailablePatches $ init cont+ t = Tagged (piUnavailable $ last cont) Nothing NilRL in+ PatchSet ps (t :<: NilRL)+ (cont, _) -> PatchSet (unavailablePatches cont) NilRL+ ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->+ scanContext $ filterGpgDashes rest+ (_, rest) -> scanContext rest +-- | Minimize the context of a bundle to be sent, taking into account+-- the patches selected to be sent +minContext :: (RepoPatch p)+ => PatchSet p wStart wB+ -> FL (PatchInfoAnd p) wB wC+ -> Sealed ((PatchSet p :> FL (PatchInfoAnd p)) wStart)+minContext (PatchSet topCommon behindTag) to_be_sent =+ case go topCommon NilFL to_be_sent of+ Sealed (c :> to_be_sent') -> seal (PatchSet c behindTag :> to_be_sent') + where+ go :: (RepoPatch p)+ => RL (PatchInfoAnd p) wA wB -- context we attempt to minimize+ -> FL (PatchInfoAnd p) wB wC -- patches we cannot remove from context+ -> FL (PatchInfoAnd p) wC wD -- patches to be included in the bundle+ -> Sealed (( RL (PatchInfoAnd p) :> FL (PatchInfoAnd p) ) wA )+ go NilRL necessary to_be_sent' = seal (reverseFL necessary :> to_be_sent')+ go (candidate :<: rest) necessary to_be_sent' =+ let fl1 = (candidate :>: NilFL) in+ case commute (fl1 :> necessary) of+ Nothing -> go rest (candidate :>: necessary) to_be_sent'+ Just (necessary' :> fl1') ->+ case commute (fl1' :> to_be_sent') of+ Nothing -> go rest (candidate :>: necessary) to_be_sent'+ Just (to_be_sent'' :> _) -> -- commutation work, we can drop the patch+ go rest necessary' to_be_sent''+ -- |patchFilename maps a patch description string to a safe (lowercased, spaces -- removed and ascii-only characters) patch filename. patchFilename :: String -> String patchFilename the_summary = name ++ ".dpatch"- where name = map safeFileChar the_summary- safeFileChar c | isAlpha c = toLower c- | isDigit c = c- | isSpace c = '-'- safeFileChar _ = '_'+ where+ name = map safeFileChar the_summary+ safeFileChar c | isAlpha c = toLower c+ | isDigit c = c+ | isSpace c = '-'+ safeFileChar _ = '_'
src/Darcs/Patch/Choices.hs view
@@ -17,7 +17,6 @@ {-# LANGUAGE CPP #-} -#include "gadts.h" -- | PatchChoices divides a sequence of patches into three sets: "first", -- "middle" and "last", such that all patches can be applied, if you first@@ -45,8 +44,8 @@ -- Some patch marked "middle" may in fact be unselectable because of -- dependencies: when a patch is marked "last", its dependencies are -- not updated until patchSlot is called on them.-module Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTps,- patchChoicesTpsSub,+module Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesLps,+ patchChoicesLpsSub, patchSlot, patchSlot', getChoices, refineChoices, separateFirstMiddleFromLast,@@ -55,7 +54,7 @@ forceMatchingFirst, forceMatchingLast, selectAllMiddles, makeUncertain, makeEverythingLater, makeEverythingSooner,- TaggedPatch, Tag, tag, tpPatch,+ LabelledPatch, Label, label, lpPatch, Slot(..), substitute ) where@@ -71,77 +70,79 @@ import Darcs.Patch.Merge ( Merge ) import Darcs.Patch.Permutations ( commuteWhatWeCanRL, commuteWhatWeCanFL ) import Darcs.Patch.Patchy ( Invert, Commute, PatchInspect )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( FL(..), RL(..),- (:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..),- zipWithFL, mapFL_FL, concatFL,- (+>+), reverseRL, anyFL )-import Darcs.Witnesses.Sealed ( Sealed2(..) )+import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), RL(..),+ (:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..),+ zipWithFL, mapFL_FL, concatFL,+ (+>+), reverseRL, anyFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) ) #include "impossible.h" --- | 'TG' @mp i@ acts as a temporary identifier to help us keep track of patches+-- | 'Label' @mp i@ acts as a temporary identifier to help us keep track of patches -- during the selection process. These are useful for finding patches that -- may have moved around during patch selection (being pushed forwards or -- backwards as dependencies arise). ----- The identifier is implemented as a tuple @TG mp i@. The @i@ is just some+-- The identifier is implemented as a tuple @Label mp i@. The @i@ is just some -- arbitrary label, expected to be unique within the patches being -- scrutinised. The @mp@ is motivated by patch splitting; it -- provides a convenient way to generate a new identifier from the patch--- being split. For example, if we split a patch identified as @TG Nothing--- 5@, the resulting sub-patches could be identified as @TG (TG Nothing 5)--- 1@, @TG (TG Nothing 5) 2@, etc.-data Tag = TG (Maybe Tag) Integer deriving ( Eq, Ord )-data TaggedPatch p C(x y) = TP Tag (p C(x y))+-- being split. For example, if we split a patch identified as @Label Nothing+-- 5@, the resulting sub-patches could be identified as @Label (Label Nothing 5)+-- 1@, @Label (Label Nothing 5) 2@, etc.+data Label = Label (Maybe Label) Integer deriving ( Eq, Ord )+data LabelledPatch p wX wY = LP Label (p wX wY) -- | The @Bool@ parameter indicates whether the patch has been explicitely -- selected (or rejected) by the user.-data PatchChoice p C(x y) = PC { pcPatch :: (TaggedPatch p C(x y))+data PatchChoice p wX wY = PC { pcPatch :: (LabelledPatch p wX wY) , _pcChoice :: Bool} -data PatchChoices p C(x y) where- PCs { pcsFirsts :: FL (TaggedPatch p) C(x m)- , pcsLasts :: FL (PatchChoice p) C(m y)} :: PatchChoices p C(x y)+data PatchChoices p wX wY where+ PCs :: { pcsFirsts :: FL (LabelledPatch p) wX wM+ , pcsLasts :: FL (PatchChoice p) wM wY}+ -> PatchChoices p wX wY -- | See module documentation for 'Darcs.Patch.Choices' data Slot = InFirst | InMiddle | InLast -tag :: TaggedPatch p C(x y) -> Tag-tag (TP tg _) = tg+label :: LabelledPatch p wX wY -> Label+label (LP tg _) = tg -tpPatch :: TaggedPatch p C(x y) -> p C(x y)-tpPatch (TP _ p) = p+lpPatch :: LabelledPatch p wX wY -> p wX wY+lpPatch (LP _ p) = p -liftTP :: (p C(x y) -> p C(a b)) -> (TaggedPatch p C(x y) -> TaggedPatch p C(a b))-liftTP f (TP t p) = TP t (f p)+liftLP :: (p wX wY -> p wA wB) -> (LabelledPatch p wX wY -> LabelledPatch p wA wB)+liftLP f (LP t p) = LP t (f p) --- This is dangerous if two patches from different tagged series are compared--- ideally Tag (and hence TaggedPatch/PatchChoices) would have a witness type--- to represent the originally tagged sequence.-compareTags :: TaggedPatch p C(a b) -> TaggedPatch p C(c d) -> EqCheck C((a, b) (c, d))-compareTags (TP t1 _) (TP t2 _) = if t1 == t2 then unsafeCoerceP IsEq else NotEq+-- This is dangerous if two patches from different labelled series are compared+-- ideally Label (and hence LabelledPatch/PatchChoices) would have a witness type+-- to represent the originally labelled sequence.+compareLabels :: LabelledPatch p wA wB -> LabelledPatch p wC wD -> EqCheck (wA, wB) (wC, wD)+compareLabels (LP l1 _) (LP l2 _) = if l1 == l2 then unsafeCoerceP IsEq else NotEq -instance MyEq p => MyEq (TaggedPatch p) where- unsafeCompare (TP t1 p1) (TP t2 p2) = t1 == t2 && unsafeCompare p1 p2+instance MyEq p => MyEq (LabelledPatch p) where+ unsafeCompare (LP l1 p1) (LP l2 p2) = l1 == l2 && unsafeCompare p1 p2 -instance Invert p => Invert (TaggedPatch p) where- invert = liftTP invert+instance Invert p => Invert (LabelledPatch p) where+ invert = liftLP invert -instance Commute p => Commute (TaggedPatch p) where- commute (TP t1 p1 :> TP t2 p2) = do p2' :> p1' <- commute (p1 :> p2)- return (TP t2 p2' :> TP t1 p1')+instance Commute p => Commute (LabelledPatch p) where+ commute (LP l1 p1 :> LP l2 p2) = do p2' :> p1' <- commute (p1 :> p2)+ return (LP l2 p2' :> LP l1 p1') -instance PatchInspect p => PatchInspect (TaggedPatch p) where- listTouchedFiles (TP _ p) = listTouchedFiles p- hunkMatches f (TP _ p) = hunkMatches f p+instance PatchInspect p => PatchInspect (LabelledPatch p) where+ listTouchedFiles (LP _ p) = listTouchedFiles p+ hunkMatches f (LP _ p) = hunkMatches f p -instance Merge p => Merge (TaggedPatch p) where- merge (TP t1 p1 :\/: TP t2 p2) = case merge (p1 :\/: p2) of- p2' :/\: p1' -> TP t2 p2' :/\: TP t1 p1'+instance Merge p => Merge (LabelledPatch p) where+ merge (LP l1 p1 :\/: LP l2 p2) = case merge (p1 :\/: p2) of+ p2' :/\: p1' -> LP l2 p2' :/\: LP l1 p1' instance Commute p => Commute (PatchChoice p) where commute (PC p1 c1 :> PC p2 c2) = do p2' :> p1' <- commute (p1 :> p2)@@ -152,66 +153,66 @@ hunkMatches f (PC p _) = hunkMatches f p instance Merge p => Merge (PatchChoice p) where- merge (PC tp1 c1 :\/: PC tp2 c2) = case merge (tp1 :\/: tp2) of- tp2' :/\: tp1' -> PC tp2' c2 :/\: PC tp1' c1+ merge (PC lp1 c1 :\/: PC lp2 c2) = case merge (lp1 :\/: lp2) of+ lp2' :/\: lp1' -> PC lp2' c2 :/\: PC lp1' c1 -patchChoices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y)-patchChoices = fst . patchChoicesTps+patchChoices :: Patchy p => FL p wX wY -> PatchChoices p wX wY+patchChoices = fst . patchChoicesLps --- |Tag a sequence of patches as subpatches of an existing tag. This is intended for+-- |Label a sequence of patches as subpatches of an existing label. This is intended for -- use when substituting a patch for an equivalent patch or patches.-patchChoicesTpsSub :: Patchy p- => Maybe Tag -> FL p C(x y)- -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))-patchChoicesTpsSub tg ps = let tps = zipWithFL TP (map (TG tg) [1..]) ps- in (PCs NilFL (mapFL_FL (\tp -> PC tp False) tps), tps)+patchChoicesLpsSub :: Patchy p+ => Maybe Label -> FL p wX wY+ -> (PatchChoices p wX wY, FL (LabelledPatch p) wX wY)+patchChoicesLpsSub tg ps = let lps = zipWithFL LP (map (Label tg) [1..]) ps+ in (PCs NilFL (mapFL_FL (\lp -> PC lp False) lps), lps) --- |Tag a sequence of patches.-patchChoicesTps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))-patchChoicesTps = patchChoicesTpsSub Nothing+-- |Label a sequence of patches.+patchChoicesLps :: Patchy p => FL p wX wY -> (PatchChoices p wX wY, FL (LabelledPatch p) wX wY)+patchChoicesLps = patchChoicesLpsSub Nothing instance MyEq p => MyEq (PatchChoice p) where- unsafeCompare (PC tp1 _) (PC tp2 _) = unsafeCompare tp1 tp2+ unsafeCompare (PC lp1 _) (PC lp2 _) = unsafeCompare lp1 lp2 -separateFirstFromMiddleLast :: Patchy p => PatchChoices p C(x z)- -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)-separateFirstFromMiddleLast (PCs f l) = f :> mapFL_FL (\ (PC tp _) -> tp) l+separateFirstFromMiddleLast :: Patchy p => PatchChoices p wX wZ+ -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ+separateFirstFromMiddleLast (PCs f l) = f :> mapFL_FL (\ (PC lp _) -> lp) l -separateFirstMiddleFromLast :: Patchy p => PatchChoices p C(x z)- -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)+separateFirstMiddleFromLast :: Patchy p => PatchChoices p wX wZ+ -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ separateFirstMiddleFromLast (PCs f l) = case pushLasts l of (m :> l') -> f +>+ m :> l' -- | @getChoices@ evaluates a @PatchChoices@ into the first, middle and last sequences -- by doing the commutes that were needed.-getChoices :: Patchy p => PatchChoices p C(x y)- -> (FL (TaggedPatch p) :> FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)+getChoices :: Patchy p => PatchChoices p wX wY+ -> (FL (LabelledPatch p) :> FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY getChoices (PCs f l) = case pushLasts l of (m :> l') -> f :> m :> l' -pushLasts :: Patchy p => FL (PatchChoice p) C(x y)- -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)+pushLasts :: Patchy p => FL (PatchChoice p) wX wY+ -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY pushLasts NilFL = NilFL :> NilFL-pushLasts (PC tp False :>: pcs) =+pushLasts (PC lp False :>: pcs) = case pushLasts pcs of- (m :> l) -> (tp :>: m) :> l-pushLasts (PC tp True :>: pcs) =+ (m :> l) -> (lp :>: m) :> l+pushLasts (PC lp True :>: pcs) = case pushLasts pcs of (m :> l) ->- case commuteWhatWeCanFL (tp :> m) of- (m' :> tp' :> deps) -> m' :> (tp' :>: deps +>+ l)+ case commuteWhatWeCanFL (lp :> m) of+ (m' :> lp' :> deps) -> m' :> (lp' :>: deps +>+ l) -- | @refineChoices act@ performs @act@ on the middle part of a sequence -- of choices, in order to hopefully get more patches into the @first@ and -- @last@ parts of a @PatchChoices@. refineChoices :: (Patchy p, Monad m, Functor m) =>- (FORALL(u v) FL (TaggedPatch p) C(u v) ->- PatchChoices p C(u v) ->- m (PatchChoices p C(u v)))- -> PatchChoices p C(x y) -> m (PatchChoices p C(x y))+ (forall wU wV . FL (LabelledPatch p) wU wV ->+ PatchChoices p wU wV ->+ m (PatchChoices p wU wV))+ -> PatchChoices p wX wY -> m (PatchChoices p wX wY) refineChoices act ps = case getChoices ps of (f :> m :> l) -> do@@ -219,66 +220,66 @@ (PCs f' l') <- act m mchoices return . PCs (f +>+ f') $ l' +>+ mapFL_FL (flip PC True) l -patchSlot :: forall p C(a b x y). Patchy p => TaggedPatch p C(a b)- -> PatchChoices p C(x y) -> (Slot, PatchChoices p C(x y))-patchSlot (TP t _) pc@(PCs f l) =+patchSlot :: forall p wA wB wX wY. Patchy p => LabelledPatch p wA wB+ -> PatchChoices p wX wY -> (Slot, PatchChoices p wX wY)+patchSlot (LP t _) pc@(PCs f l) = if foundIn f then (InFirst, pc) else psLast f NilRL NilRL l where- foundIn = anyFL ((== t) . tag)- psLast :: FORALL(m c l)- FL (TaggedPatch p) C(x m) ->- RL (TaggedPatch p) C(m c) ->- RL (TaggedPatch p) C(c l) ->- FL (PatchChoice p) C(l y) ->- (Slot, PatchChoices p C(x y))- psLast firsts middles bubble (PC tp True :>: ls)- | tag tp == t = (InLast+ foundIn = anyFL ((== t) . label)+ psLast :: forall wM wC wL .+ FL (LabelledPatch p) wX wM ->+ RL (LabelledPatch p) wM wC ->+ RL (LabelledPatch p) wC wL ->+ FL (PatchChoice p) wL wY ->+ (Slot, PatchChoices p wX wY)+ psLast firsts middles bubble (PC lp True :>: ls)+ | label lp == t = (InLast , PCs { pcsFirsts = firsts , pcsLasts = settleM middles +>+ settleB bubble- +>+ PC tp True :>: ls})- psLast firsts middles bubble (PC tp False :>: ls)- | tag tp == t =- case commuteRL (bubble :> tp) of- Just (tp' :> bubble') -> (InMiddle,+ +>+ PC lp True :>: ls})+ psLast firsts middles bubble (PC lp False :>: ls)+ | label lp == t =+ case commuteRL (bubble :> lp) of+ Just (lp' :> bubble') -> (InMiddle, PCs { pcsFirsts = firsts , pcsLasts = settleM middles- +>+ PC tp' False+ +>+ PC lp' False :>: settleB bubble' +>+ ls}) Nothing -> (InLast, PCs { pcsFirsts = firsts , pcsLasts = settleM middles +>+ settleB bubble- +>+ PC tp True+ +>+ PC lp True :>: ls})- psLast firsts middles bubble (PC tp True :>: ls) =- psLast firsts middles (tp :<: bubble) ls- psLast firsts middles bubble (PC tp False :>: ls) =- case commuteRL (bubble :> tp) of- Just (tp' :> bubble') -> psLast firsts (tp' :<: middles) bubble' ls- Nothing -> psLast firsts middles (tp :<: bubble) ls+ psLast firsts middles bubble (PC lp True :>: ls) =+ psLast firsts middles (lp :<: bubble) ls+ psLast firsts middles bubble (PC lp False :>: ls) =+ case commuteRL (bubble :> lp) of+ Just (lp' :> bubble') -> psLast firsts (lp' :<: middles) bubble' ls+ Nothing -> psLast firsts middles (lp :<: bubble) ls psLast _ _ _ NilFL = impossible- settleM middles = mapFL_FL (\tp -> PC tp False) $ reverseRL middles- settleB bubble = mapFL_FL (\tp -> PC tp True) $ reverseRL bubble+ settleM middles = mapFL_FL (\lp -> PC lp False) $ reverseRL middles+ settleB bubble = mapFL_FL (\lp -> PC lp True) $ reverseRL bubble patchSlot' :: Patchy p =>- TaggedPatch p C(a b) -> StateT (PatchChoices p C(x y)) Identity Slot-patchSlot' tp = StateT (return . patchSlot tp)+ LabelledPatch p wA wB -> StateT (PatchChoices p wX wY) Identity Slot+patchSlot' lp = StateT (return . patchSlot lp) -forceMatchingFirst :: forall p C(a b). Patchy p =>- ( FORALL(x y) TaggedPatch p C(x y) -> Bool)- -> PatchChoices p C(a b)- -> PatchChoices p C(a b)+forceMatchingFirst :: forall p wA wB. Patchy p =>+ ( forall wX wY . LabelledPatch p wX wY -> Bool)+ -> PatchChoices p wA wB+ -> PatchChoices p wA wB forceMatchingFirst pred (PCs fn l) = fmfLasts fn NilRL l where- fmfLasts :: FL (TaggedPatch p) C(a m)- -> RL (PatchChoice p) C(m n)- -> FL (PatchChoice p) C(n b)- -> PatchChoices p C(a b)+ fmfLasts :: FL (LabelledPatch p) wA wM+ -> RL (PatchChoice p) wM wN+ -> FL (PatchChoice p) wN wB+ -> PatchChoices p wA wB fmfLasts f l1 (a :>: l2) | pred_pc a = case commuteWhatWeCanRL (l1 :> a) of@@ -289,114 +290,114 @@ fmfLasts f l1 (a :>: l2) = fmfLasts f (a :<: l1) l2 fmfLasts f l1 NilFL = PCs { pcsFirsts = f , pcsLasts = reverseRL l1 }- pred_pc :: FORALL(x y) PatchChoice p C(x y) -> Bool- pred_pc (PC tp _) = pred tp+ pred_pc :: forall wX wY . PatchChoice p wX wY -> Bool+ pred_pc (PC lp _) = pred lp -forceFirsts :: Patchy p => [Tag] -> PatchChoices p C(a b)- -> PatchChoices p C(a b)-forceFirsts ps = forceMatchingFirst ((`elem` ps) . tag)+forceFirsts :: Patchy p => [Label] -> PatchChoices p wA wB+ -> PatchChoices p wA wB+forceFirsts ps = forceMatchingFirst ((`elem` ps) . label) -forceFirst :: Patchy p => Tag -> PatchChoices p C(a b)- -> PatchChoices p C(a b)-forceFirst p = forceMatchingFirst ((== p) . tag)+forceFirst :: Patchy p => Label -> PatchChoices p wA wB+ -> PatchChoices p wA wB+forceFirst p = forceMatchingFirst ((== p) . label) --TODO: stop after having seen the patch we want to force first -selectAllMiddles :: forall p C(x y). Patchy p => Bool- -> PatchChoices p C(x y) -> PatchChoices p C(x y)+selectAllMiddles :: forall p wX wY. Patchy p => Bool+ -> PatchChoices p wX wY -> PatchChoices p wX wY selectAllMiddles True (PCs f l) = PCs f (mapFL_FL g l)- where g (PC tp _) = PC tp True+ where g (PC lp _) = PC lp True selectAllMiddles False (PCs f l) = samf f NilRL NilRL l where- samf :: FORALL(m1 m2 m3)- FL (TaggedPatch p) C(x m1) ->- RL (TaggedPatch p) C(m1 m2) ->- RL (PatchChoice p) C(m2 m3) ->- FL (PatchChoice p) C(m3 y) ->- PatchChoices p C(x y)- samf f1 f2 l1 (pc@(PC tp False) :>: l2) =+ samf :: forall wM1 wM2 wM3 .+ FL (LabelledPatch p) wX wM1 ->+ RL (LabelledPatch p) wM1 wM2 ->+ RL (PatchChoice p) wM2 wM3 ->+ FL (PatchChoice p) wM3 wY ->+ PatchChoices p wX wY+ samf f1 f2 l1 (pc@(PC lp False) :>: l2) = case commuteRL (l1 :> pc) of- Nothing -> samf f1 f2 (PC tp True :<: l1) l2- Just ((PC tp' _) :> l1') -> samf f1 (tp' :<: f2) l1' l2- samf f1 f2 l1 (PC tp True :>: l2) = samf f1 f2 (PC tp True :<: l1) l2+ Nothing -> samf f1 f2 (PC lp True :<: l1) l2+ Just ((PC lp' _) :> l1') -> samf f1 (lp' :<: f2) l1' l2+ samf f1 f2 l1 (PC lp True :>: l2) = samf f1 f2 (PC lp True :<: l1) l2 samf f1 f2 l1 NilFL = PCs (f1 +>+ reverseRL f2) (reverseRL l1) -forceMatchingLast :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)- -> PatchChoices p C(a b)- -> PatchChoices p C(a b)+forceMatchingLast :: Patchy p => (forall wX wY . LabelledPatch p wX wY -> Bool)+ -> PatchChoices p wA wB+ -> PatchChoices p wA wB forceMatchingLast pred (PCs f l) = do fmlFirst pred True NilRL f l -fmlFirst :: forall p C(a b m1 m2) . Patchy p =>- (FORALL(x y) TaggedPatch p C(x y) -> Bool) -> Bool- -> RL (TaggedPatch p) C(a m1)- -> FL (TaggedPatch p) C(m1 m2)- -> FL (PatchChoice p) C(m2 b)- -> PatchChoices p C(a b)+fmlFirst :: forall p wA wB wM1 wM2 . Patchy p =>+ (forall wX wY . LabelledPatch p wX wY -> Bool) -> Bool+ -> RL (LabelledPatch p) wA wM1+ -> FL (LabelledPatch p) wM1 wM2+ -> FL (PatchChoice p) wM2 wB+ -> PatchChoices p wA wB fmlFirst pred b f1 (a :>: f2) l | pred a = case commuteWhatWeCanFL (a :> f2) of (f2' :> a' :> deps) -> let- l' = mapFL_FL (\tp -> PC tp b) (a' :>: deps) +>+ l+ l' = mapFL_FL (\lp -> PC lp b) (a' :>: deps) +>+ l in fmlFirst pred b f1 f2' l' fmlFirst pred b f1 (a :>: f2) l = fmlFirst pred b (a :<: f1) f2 l fmlFirst pred b f1 NilFL l = PCs { pcsFirsts = reverseRL f1 , pcsLasts = mapFL_FL ch l}- where ch (PC tp c) = (PC tp (if pred tp then b else c) )+ where ch (PC lp c) = (PC lp (if pred lp then b else c) ) -forceLasts :: Patchy p => [Tag]- -> PatchChoices p C(a b) -> PatchChoices p C(a b)-forceLasts ps = forceMatchingLast ((`elem` ps) . tag)+forceLasts :: Patchy p => [Label]+ -> PatchChoices p wA wB -> PatchChoices p wA wB+forceLasts ps = forceMatchingLast ((`elem` ps) . label) -forceLast :: Patchy p => Tag- -> PatchChoices p C(a b) -> PatchChoices p C(a b)-forceLast p = forceMatchingLast ((== p) . tag)+forceLast :: Patchy p => Label+ -> PatchChoices p wA wB -> PatchChoices p wA wB+forceLast p = forceMatchingLast ((== p) . label) -makeUncertain :: Patchy p => Tag -> PatchChoices p C(a b) -> PatchChoices p C(a b)-makeUncertain t (PCs f l) = fmlFirst ((== t) . tag) False NilRL f l+makeUncertain :: Patchy p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB+makeUncertain t (PCs f l) = fmlFirst ((== t) . label) False NilRL f l -makeEverythingLater :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)+makeEverythingLater :: Patchy p => PatchChoices p wX wY -> PatchChoices p wX wY makeEverythingLater (PCs f l) =- let m = mapFL_FL (\tp -> PC tp False) f- l' = mapFL_FL (\(PC tp _) -> PC tp True) l+ let m = mapFL_FL (\lp -> PC lp False) f+ l' = mapFL_FL (\(PC lp _) -> PC lp True) l in PCs NilFL $ m +>+ l' -makeEverythingSooner :: forall p C(x y).- Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)+makeEverythingSooner :: forall p wX wY.+ Patchy p => PatchChoices p wX wY -> PatchChoices p wX wY makeEverythingSooner (PCs f l) = case mes NilRL NilRL l of (m :> l') -> PCs (f +>+ m) l' where- mes :: FORALL(m1 m2 m3)- RL (TaggedPatch p) C(m1 m2) ->- RL (TaggedPatch p) C(m2 m3) ->- FL (PatchChoice p) C(m3 y) ->- (FL (TaggedPatch p) :> FL (PatchChoice p)) C(m1 y)- mes middle bubble (PC tp True :>: ls) = mes middle (tp :<: bubble) ls- mes middle bubble (PC tp False :>: ls) =- case commuteRL (bubble :> tp) of- Nothing -> mes middle (tp :<: bubble) ls- Just (tp' :> bubble') -> mes (tp' :<: middle) bubble' ls- mes middle bubble NilFL = (reverseRL middle) :> mapFL_FL (\tp -> PC tp False) (reverseRL bubble)+ mes :: forall wM1 wM2 wM3 .+ RL (LabelledPatch p) wM1 wM2 ->+ RL (LabelledPatch p) wM2 wM3 ->+ FL (PatchChoice p) wM3 wY ->+ (FL (LabelledPatch p) :> FL (PatchChoice p)) wM1 wY+ mes middle bubble (PC lp True :>: ls) = mes middle (lp :<: bubble) ls+ mes middle bubble (PC lp False :>: ls) =+ case commuteRL (bubble :> lp) of+ Nothing -> mes middle (lp :<: bubble) ls+ Just (lp' :> bubble') -> mes (lp' :<: middle) bubble' ls+ mes middle bubble NilFL = (reverseRL middle) :> mapFL_FL (\lp -> PC lp False) (reverseRL bubble) -- | 'substitute' @(a :||: bs)@ @pcs@ replaces @a@ with @bs@ in @pcs@ preserving the choice -- associated with @a@-substitute :: forall p C(x y)+substitute :: forall p wX wY . Patchy p- => Sealed2 (TaggedPatch p :||: FL (TaggedPatch p))- -> PatchChoices p C(x y)- -> PatchChoices p C(x y)-substitute (Sealed2 (tp :||: new_tps)) (PCs f l) =- PCs (concatFL $ mapFL_FL substTp f) (concatFL $ mapFL_FL substPc l)+ => Sealed2 (LabelledPatch p :||: FL (LabelledPatch p))+ -> PatchChoices p wX wY+ -> PatchChoices p wX wY+substitute (Sealed2 (lp :||: new_lps)) (PCs f l) =+ PCs (concatFL $ mapFL_FL substLp f) (concatFL $ mapFL_FL substPc l) where- substTp :: TaggedPatch p C(a b) -> FL (TaggedPatch p) C(a b)- substTp tp'- | IsEq <- compareTags tp tp' = new_tps- | otherwise = tp' :>: NilFL- substPc :: PatchChoice p C(a b) -> FL (PatchChoice p) C(a b)- substPc (PC tp' c)- | IsEq <- compareTags tp tp' = mapFL_FL (flip PC c) new_tps- | otherwise = PC tp' c :>: NilFL+ substLp :: LabelledPatch p wA wB -> FL (LabelledPatch p) wA wB+ substLp lp'+ | IsEq <- compareLabels lp lp' = new_lps+ | otherwise = lp' :>: NilFL+ substPc :: PatchChoice p wA wB -> FL (PatchChoice p) wA wB+ substPc (PC lp' c)+ | IsEq <- compareLabels lp lp' = mapFL_FL (flip PC c) new_lps+ | otherwise = PC lp' c :>: NilFL
src/Darcs/Patch/Commute.hs view
@@ -1,74 +1,90 @@ module Darcs.Patch.Commute- ( Commute(..),- commuteFL, commuteFLorComplain,- commuteRL, commuteRLFL,- toFwdCommute, toRevCommute- )- where+ ( Commute(..)+ , commuteFL+ , commuteFLorComplain+ , commuteRL+ , commuteRLFL+ , toFwdCommute+ , toRevCommute+ , selfCommuter+ ) where -import Darcs.Witnesses.Ordered (FL(..), RL(..), - reverseFL, reverseRL,- (:>)(..), (:<)(..)- )-import Darcs.Witnesses.Sealed ( Sealed2, seal2 )+import Darcs.Patch.CommuteFn ( CommuteFn ) -#include "gadts.h"+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), RL(..), reverseFL, reverseRL,+ (:>)(..), (:<)(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed2, seal2 ) --- | Things that can commute.+-- | Commute represents things that can be (possibly) commuted. class Commute p where- commute :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))---- | Swaps the ordered pair type so that commute can be--- called directly.-toFwdCommute :: (Commute p, Commute q, Monad m)- => ((p :< q) C(x y) -> m ((q :< p) C(x y)))- -> (q :> p) C(x y) -> m ((p :> q) C(x y))-toFwdCommute c (x :> y) = do x' :< y' <- c (y :< x)- return (y' :> x')---- | Swaps the ordered pair type from the order expected--- by commute to the reverse order.-toRevCommute :: (Commute p, Commute q, Monad m)- => ((p :> q) C(x y) -> m ((q :> p) C(x y)))- -> (q :< p) C(x y) -> m ((p :< q) C(x y))-toRevCommute c (x :< y) = do x' :> y' <- c (y :> x)- return (y' :< x')--+ commute :: (p :> p) wX wY -> Maybe ((p :> p) wX wY) instance Commute p => Commute (FL p) where commute (NilFL :> x) = Just (x :> NilFL) commute (x :> NilFL) = Just (NilFL :> x)- commute (xs :> ys) = do ys' :> rxs' <- commuteRLFL (reverseFL xs :> ys)- return $ ys' :> reverseRL rxs'-+ commute (xs :> ys) = do+ ys' :> rxs' <- commuteRLFL (reverseFL xs :> ys)+ return $ ys' :> reverseRL rxs' -commuteRLFL :: Commute p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))+-- |'commuteRLFL' commutes an 'RL' past an 'FL'.+commuteRLFL :: Commute p => (RL p :> FL p) wX wY+ -> Maybe ((FL p :> RL p) wX wY) commuteRLFL (NilRL :> ys) = Just (ys :> NilRL) commuteRLFL (xs :> NilFL) = Just (NilFL :> xs)-commuteRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteRL (xs :> y)- ys' :> xs'' <- commuteRLFL (xs' :> ys)- return (y' :>: ys' :> xs'')+commuteRLFL (xs :> y :>: ys) = do+ y' :> xs' <- commuteRL (xs :> y)+ ys' :> xs'' <- commuteRLFL (xs' :> ys)+ return (y' :>: ys' :> xs'') -commuteRL :: Commute p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))-commuteRL (z :<: zs :> w) = do w' :> z' <- commute (z :> w)- w'' :> zs' <- commuteRL (zs :> w')- return (w'' :> z' :<: zs')+instance Commute p => Commute (RL p) where+ commute (xs :> ys) = do+ fys' :> xs' <- commuteRLFL (xs :> reverseRL ys)+ return (reverseFL fys' :> xs')++-- |'commuteRL' commutes a RL past a single element.+commuteRL :: Commute p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY)+commuteRL (z :<: zs :> w) = do+ w' :> z' <- commute (z :> w)+ w'' :> zs' <- commuteRL (zs :> w')+ return (w'' :> z' :<: zs') commuteRL (NilRL :> w) = Just (w :> NilRL) -commuteFLorComplain :: Commute p => (p :> FL p) C(x y) -> Either (Sealed2 p) ((FL p :> p) C(x y))+-- |'commuteFL' commutes a single element past a FL.+commuteFL :: Commute p => (p :> FL p) wX wY -> Maybe ((FL p :> p) wX wY)+commuteFL = either (const Nothing) Just . commuteFLorComplain++-- |'commuteFLorComplain' attempts to commute a single element past a FL. If+-- any individual commute fails, then we return the patch that first patch that+-- cannot be commuted past.+commuteFLorComplain :: Commute p => (p :> FL p) wX wY+ -> Either (Sealed2 p) ((FL p :> p) wX wY) commuteFLorComplain (p :> NilFL) = Right (NilFL :> p)-commuteFLorComplain (q :> p :>: ps) = case commute (q :> p) of- Just (p' :> q') ->- case commuteFLorComplain (q' :> ps) of- Right (ps' :> q'') -> Right (p' :>: ps' :> q'')- Left l -> Left l- Nothing -> Left $ seal2 p+commuteFLorComplain (q :> p :>: ps) =+ case commute (q :> p) of+ Just (p' :> q') ->+ case commuteFLorComplain (q' :> ps) of+ Right (ps' :> q'') -> Right (p' :>: ps' :> q'')+ Left l -> Left l+ Nothing -> Left $ seal2 p -commuteFL :: Commute p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y))-commuteFL = either (const Nothing) Just . commuteFLorComplain+-- | Swaps the ordered pair type so that commute can be called directly.+toFwdCommute :: (Commute p, Commute q, Monad m) =>+ ((p :< q) wX wY -> m ((q :< p) wX wY)) -> (q :> p) wX wY+ -> m ((p :> q) wX wY)+toFwdCommute c (x :> y) = do+ x' :< y' <- c (y :< x)+ return (y' :> x') -instance Commute p => Commute (RL p) where- commute (xs :> ys) = do fys' :> xs' <- commuteRLFL (xs :> reverseRL ys)- return (reverseFL fys' :> xs')+-- | Swaps the ordered pair type from the order expected by commute to the+-- reverse order.+toRevCommute :: (Commute p, Commute q, Monad m) =>+ ((p :> q) wX wY -> m ((q :> p) wX wY)) -> (q :< p) wX wY+ -> m ((p :< q) wX wY)+toRevCommute c (x :< y) = do+ x' :> y' <- c (y :> x)+ return (y' :< x') +-- |Build a commuter between a patch and itself using the operation from the type class.+selfCommuter :: Commute p => CommuteFn p p+selfCommuter = commute
+ src/Darcs/Patch/CommuteFn.hs view
@@ -0,0 +1,83 @@+module Darcs.Patch.CommuteFn+ ( CommuteFn,+ commuterIdFL, commuterFLId,+ commuterIdRL, commuterRLId,+ MergeFn,+ mergerIdFL,+ TotalCommuteFn,+ totalCommuterIdFL, totalCommuterFLId, totalCommuterFLFL+ ) where++import Darcs.Patch.Witnesses.Ordered+ ( (:>)(..)+ , (:\/:)(..)+ , (:/\:)(..)+ , FL(..)+ , RL(..)+ )++-- |CommuteFn is the basis of a general framework for building up commutation+-- operations between different patch types in a generic manner. Unfortunately+-- type classes are not well suited to the problem because of the multiple possible+-- routes by which the commuter for (FL p1, FL p2) can be built out of the+-- commuter for (p1, p2) - and more complicated problems when we start building+-- multiple constructors on top of each other. The type class resolution machinery+-- really can't cope with selecting some route, because it doesn't know that all+-- possible routes should be equivalent.+type CommuteFn p1 p2 = forall wX wY . (p1 :> p2) wX wY -> Maybe ((p2 :> p1) wX wY)++type TotalCommuteFn p1 p2 = forall wX wY . (p1 :> p2) wX wY -> (p2 :> p1) wX wY++type MergeFn p1 p2 = forall wX wY . (p1 :\/: p2) wX wY -> (p2 :/\: p1) wX wY++commuterIdRL :: CommuteFn p1 p2 -> CommuteFn p1 (RL p2)+commuterIdRL _ (x :> NilRL) = return (NilRL :> x)+commuterIdRL commuter (x :> (y :<: ys))+ = do ys' :> x' <- commuterIdRL commuter (x :> ys)+ y' :> x'' <- commuter (x' :> y)+ return ((y' :<: ys') :> x'')++commuterIdFL :: CommuteFn p1 p2 -> CommuteFn p1 (FL p2)+commuterIdFL _ (x :> NilFL) = return (NilFL :> x)+commuterIdFL commuter (x :> (y :>: ys))+ = do y' :> x' <- commuter (x :> y)+ ys' :> x'' <- commuterIdFL commuter (x' :> ys)+ return ((y' :>: ys') :> x'')++mergerIdFL :: MergeFn p1 p2 -> MergeFn p1 (FL p2)+mergerIdFL _ (x :\/: NilFL) = NilFL :/\: x+mergerIdFL merger (x :\/: (y :>: ys))+ = case merger (x :\/: y) of+ y' :/\: x' -> case mergerIdFL merger (x' :\/: ys) of+ ys' :/\: x'' -> (y' :>: ys') :/\: x''++totalCommuterIdFL :: TotalCommuteFn p1 p2 -> TotalCommuteFn p1 (FL p2)+totalCommuterIdFL _ (x :> NilFL) = NilFL :> x+totalCommuterIdFL commuter (x :> (y :>: ys)) =+ case commuter (x :> y) of+ y' :> x' -> case totalCommuterIdFL commuter (x' :> ys) of+ ys' :> x'' -> (y' :>: ys') :> x''++commuterFLId :: CommuteFn p1 p2 -> CommuteFn (FL p1) p2+commuterFLId _ (NilFL :> y) = return (y :> NilFL)+commuterFLId commuter ((x :>: xs) :> y)+ = do y' :> xs' <- commuterFLId commuter (xs :> y)+ y'' :> x' <- commuter (x :> y')+ return (y'' :> (x' :>: xs'))++commuterRLId :: CommuteFn p1 p2 -> CommuteFn (RL p1) p2+commuterRLId _ (NilRL :> y) = return (y :> NilRL)+commuterRLId commuter ((x :<: xs) :> y)+ = do y' :> x' <- commuter (x :> y)+ y'' :> xs' <- commuterRLId commuter (xs :> y')+ return (y'' :> (x' :<: xs'))++totalCommuterFLId :: TotalCommuteFn p1 p2 -> TotalCommuteFn (FL p1) p2+totalCommuterFLId _ (NilFL :> y) = y :> NilFL+totalCommuterFLId commuter ((x :>: xs) :> y) =+ case totalCommuterFLId commuter (xs :> y) of+ y' :> xs' -> case commuter (x :> y') of+ y'' :> x' -> y'' :> (x' :>: xs')++totalCommuterFLFL :: TotalCommuteFn p1 p2 -> TotalCommuteFn (FL p1) (FL p2)+totalCommuterFLFL commuter = totalCommuterFLId (totalCommuterIdFL commuter)
src/Darcs/Patch/Conflict.hs view
@@ -7,22 +7,23 @@ import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Permutations () import Darcs.Patch.Prim.Class ( PrimOf )-import Darcs.Witnesses.Ordered+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..) , mapFL, reverseFL, mapRL, reverseRL )-import Darcs.Witnesses.Sealed ( Sealed, unseal )-import Darcs.Utils ( nubsort )+import Darcs.Patch.Witnesses.Sealed ( Sealed, unseal )+import Darcs.Patch.Witnesses.Show ( Show2, showsPrec2 )+import Darcs.Util.Show ( appPrec )+import Data.List.Ordered ( nubSort ) -#include "gadts.h" class (Effect p, PatchInspect (PrimOf p)) => Conflict p where- listConflictedFiles :: p C(x y) -> [FilePath]+ listConflictedFiles :: p wX wY -> [FilePath] listConflictedFiles p =- nubsort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p- resolveConflicts :: p C(x y) -> [[Sealed (FL (PrimOf p) C(y))]]+ nubSort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p+ resolveConflicts :: p wX wY -> [[Sealed (FL (PrimOf p) wY)]] - conflictedEffect :: p C(x y) -> [IsConflictedPrim (PrimOf p)]+ conflictedEffect :: p wX wY -> [IsConflictedPrim (PrimOf p)] conflictedEffect x = case listConflictedFiles x of [] -> mapFL (IsC Okay) $ effect x _ -> mapFL (IsC Conflicted) $ effect x@@ -32,10 +33,10 @@ -- past @y@ without any conflicts. This function is useful for patch types -- for which 'commute' is defined to always succeed; so we need some way to -- pick out the specific cases where commutation succeeds without any conflicts.- commuteNoConflicts :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))+ commuteNoConflicts :: (p :> p) wX wY -> Maybe ((p :> p) wX wY) instance (CommuteNoConflicts p, Conflict p) => Conflict (FL p) where- listConflictedFiles = nubsort . concat . mapFL listConflictedFiles+ listConflictedFiles = nubSort . concat . mapFL listConflictedFiles resolveConflicts NilFL = [] resolveConflicts x = resolveConflicts $ reverseFL x conflictedEffect = concat . mapFL conflictedEffect@@ -47,9 +48,9 @@ return $ ys' :> reverseRL rxs' instance (CommuteNoConflicts p, Conflict p) => Conflict (RL p) where- listConflictedFiles = nubsort . concat . mapRL listConflictedFiles+ listConflictedFiles = nubSort . concat . mapRL listConflictedFiles resolveConflicts x = rcs x NilFL- where rcs :: RL p C(x y) -> FL p C(y w) -> [[Sealed (FL (PrimOf p) C(w))]]+ where rcs :: RL p wX wY -> FL p wY wW -> [[Sealed (FL (PrimOf p) wW)]] rcs NilRL _ = [] rcs (p:<:ps) passedby | (_:_) <- resolveConflicts p = case commuteNoConflictsFL (p:>passedby) of@@ -65,22 +66,28 @@ return $ reverseFL ys' :> rxs' data IsConflictedPrim prim where- IsC :: !ConflictState -> !(prim C(x y)) -> IsConflictedPrim prim+ IsC :: !ConflictState -> !(prim wX wY) -> IsConflictedPrim prim data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read) -commuteNoConflictsFL :: CommuteNoConflicts p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y))+instance Show2 prim => Show (IsConflictedPrim prim) where+ showsPrec d (IsC cs prim) =+ showParen (d > appPrec) $+ showString "IsC " . showsPrec (appPrec + 1) cs .+ showString " " . showsPrec2 (appPrec + 1) prim++commuteNoConflictsFL :: CommuteNoConflicts p => (p :> FL p) wX wY -> Maybe ((FL p :> p) wX wY) commuteNoConflictsFL (p :> NilFL) = Just (NilFL :> p) commuteNoConflictsFL (q :> p :>: ps) = do p' :> q' <- commuteNoConflicts (q :> p) ps' :> q'' <- commuteNoConflictsFL (q' :> ps) return (p' :>: ps' :> q'') -commuteNoConflictsRL :: CommuteNoConflicts p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))+commuteNoConflictsRL :: CommuteNoConflicts p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY) commuteNoConflictsRL (NilRL :> p) = Just (p :> NilRL) commuteNoConflictsRL (p :<: ps :> q) = do q' :> p' <- commuteNoConflicts (p :> q) q'' :> ps' <- commuteNoConflictsRL (ps :> q') return (q'' :> p' :<: ps') -commuteNoConflictsRLFL :: CommuteNoConflicts p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))+commuteNoConflictsRLFL :: CommuteNoConflicts p => (RL p :> FL p) wX wY -> Maybe ((FL p :> RL p) wX wY) commuteNoConflictsRLFL (NilRL :> ys) = Just (ys :> NilRL) commuteNoConflictsRLFL (xs :> NilFL) = Just (NilFL :> xs) commuteNoConflictsRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteNoConflictsRL (xs :> y)
src/Darcs/Patch/ConflictMarking.hs view
@@ -1,27 +1,26 @@ -- Copyright (C) 2002-2003 David Roundy, 2010 Ganesh Sittampalam-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP, ViewPatterns #-} module Darcs.Patch.ConflictMarking ( mangleUnravelled ) where import qualified Data.ByteString.Char8 as BC (pack, last) import qualified Data.ByteString as B (null, ByteString)-import Data.List ( sort, intersperse )+import Data.List ( sort, intercalate ) import Data.Maybe ( isJust ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk, isHunk )-import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn )+import Darcs.Util.Path ( FileName, fn2fp, fp2fn ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Permutations () import Darcs.Patch.Prim ( PrimPatch, is_filepatch, primIsHunk, primFromHunk )-import Darcs.Witnesses.Ordered ( FL(..) )-import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal )+import Darcs.Patch.Witnesses.Ordered ( FL(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) -#include "gadts.h" #include "impossible.h" -applyHunks :: IsHunk prim => [Maybe B.ByteString] -> FL prim C(x y) -> [Maybe B.ByteString]+applyHunks :: IsHunk prim => [Maybe B.ByteString] -> FL prim wX wY -> [Maybe B.ByteString] applyHunks ms ((isHunk -> Just (FileHunk _ l o n)):>:ps) = applyHunks (rls l ms) ps where rls k _ | k <=0 = bug $ "bad hunk: start position <=0 (" ++ show k ++ ")" rls 1 mls = map Just n ++ drop (length o) mls@@ -30,20 +29,19 @@ applyHunks ms NilFL = ms applyHunks _ (_:>:_) = impossible -getAFilename :: PrimPatch prim => [Sealed (FL prim C(x))] -> FileName-getAFilename ((Sealed ((is_filepatch -> Just f):>:_)):_) = f+getAFilename :: PrimPatch prim => [Sealed (FL prim wX)] -> FileName+getAFilename (Sealed ((is_filepatch -> Just f):>:_):_) = f getAFilename _ = fp2fn "" -getOld :: PrimPatch prim => [Maybe B.ByteString] -> [Sealed (FL prim C(x))] -> [Maybe B.ByteString]-getOld mls (ps:pss) = getOld (getHunksOld mls ps) pss-getOld mls [] = mls+getOld :: PrimPatch prim => [Maybe B.ByteString] -> [Sealed (FL prim wX)] -> [Maybe B.ByteString]+getOld = foldl getHunksOld -getHunksOld :: PrimPatch prim => [Maybe B.ByteString] -> Sealed (FL prim C(x))+getHunksOld :: PrimPatch prim => [Maybe B.ByteString] -> Sealed (FL prim wX) -> [Maybe B.ByteString] getHunksOld mls (Sealed ps) = applyHunks (applyHunks mls ps) (invert ps) -getHunksNew :: IsHunk prim => [Maybe B.ByteString] -> Sealed (FL prim C(x))+getHunksNew :: IsHunk prim => [Maybe B.ByteString] -> Sealed (FL prim wX) -> [Maybe B.ByteString] getHunksNew mls (Sealed ps) = applyHunks mls ps @@ -62,22 +60,22 @@ pull_chunk [] = bug "should this be [] in pull_chunk?" -mangleUnravelled :: PrimPatch prim => [Sealed (FL prim C(x))] -> Sealed (FL prim C(x))+mangleUnravelled :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (FL prim wX) mangleUnravelled pss = if onlyHunks pss then (:>: NilFL) `mapSeal` mangleUnravelledHunks pss else head pss -onlyHunks :: forall prim C(x) . PrimPatch prim => [Sealed (FL prim C(x))] -> Bool+onlyHunks :: forall prim wX . PrimPatch prim => [Sealed (FL prim wX)] -> Bool onlyHunks [] = False onlyHunks pss = fn2fp f /= "" && all oh pss where f = getAFilename pss- oh :: Sealed (FL prim C(y)) -> Bool+ oh :: Sealed (FL prim wY) -> Bool oh (Sealed (p:>:ps)) = primIsHunk p && [fn2fp f] == listTouchedFiles p && oh (Sealed ps) oh (Sealed NilFL) = True -mangleUnravelledHunks :: PrimPatch prim => [Sealed (FL prim C(x))] -> Sealed (prim C(x))+mangleUnravelledHunks :: PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (prim wX) --mangleUnravelledHunks [[h1],[h2]] = Deal with simple cases handily? mangleUnravelledHunks pss = if null nchs then bug "mangleUnravelledHunks"@@ -88,7 +86,7 @@ nchs = sort $ map (makeChunk l) newfs filename = getAFilename pss old = makeChunk l oldf- new = [top] ++ old ++ [initial] ++ concat (intersperse [middle] nchs) ++ [bottom]+ new = [top] ++ old ++ [initial] ++ intercalate [middle] nchs ++ [bottom] top = BC.pack $ "v v v v v v v" ++ eol_c initial= BC.pack $ "=============" ++ eol_c middle = BC.pack $ "*************" ++ eol_c
+ src/Darcs/Patch/Debug.hs view
@@ -0,0 +1,20 @@+module Darcs.Patch.Debug ( PatchDebug(..) )where++import Darcs.Patch.Witnesses.Ordered ( FL, RL )++-- | PatchDebug is a hook class for temporarily adding debug information.+-- To use it, add any methods that are required, implement those methods+-- where needed, and then make it available in the relevant contexts.+-- For example it can be temporarily added as a superclass of `Patchy`.+-- The advantage of having it here already is that everything is+-- (or should be) declared as an instance of it, so you can use+-- defaulting or just leave out declarations of instance methods and+-- code will still compile.+class PatchDebug p where+ -- | A dummy method so we can export/import PatchDebug(..) without+ -- triggering warnings+ patchDebugDummy :: p wX wY -> ()+ patchDebugDummy _ = ()++instance PatchDebug p => PatchDebug (FL p)+instance PatchDebug p => PatchDebug (RL p)
src/Darcs/Patch/Depends.hs view
@@ -17,117 +17,189 @@ {-# LANGUAGE CPP , ScopedTypeVariables #-} -#include "gadts.h"+module Darcs.Patch.Depends+ ( getUncovered+ , areUnrelatedRepos+ , findCommonAndUncommon+ , mergeThem+ , findCommonWithThem+ , countUsThem+ , removeFromPatchSet+ , slightlyOptimizePatchset+ , getPatchesBeyondTag+ , splitOnTag+ , newsetUnion+ , newsetIntersection+ , commuteToEnd+ , findUncommon+ , merge2FL+ ) where -module Darcs.Patch.Depends ( getTagsRight,- areUnrelatedRepos,- mergeThem, findCommonWithThem,- countUsThem, removeFromPatchSet,- optimizePatchset, deepOptimizePatchset,- slightlyOptimizePatchset,- getPatchesBeyondTag, getPatchesInTag,- splitOnTag,- newsetUnion, newsetIntersection,- commuteToEnd, findUncommon, merge2FL- ) where+#include "impossible.h"++import Prelude hiding ( pi ) import Data.List ( delete, intersect, (\\) )+import Data.Maybe ( fromMaybe ) -import Darcs.Patch ( RepoPatch, getdeps, commute, commuteFLorComplain, commuteRL )-import Darcs.Patch.Info ( PatchInfo, isTag, humanFriendly )-import Darcs.Patch.Merge ( mergeFL )-import Darcs.Patch.Permutations ( partitionFL, partitionRL, removeSubsequenceRL )+import Darcs.Patch ( Patchy, getdeps, commute, commuteFLorComplain,+ commuteRL )+import Darcs.Patch.Info ( PatchInfo, isTag, showPatchInfoUI )+import Darcs.Patch.Merge ( Merge, mergeFL )+import Darcs.Patch.Permutations ( partitionFL, partitionRL,+ removeSubsequenceRL ) import Darcs.Patch.PatchInfoAnd( PatchInfoAnd, hopefully, hopefullyM, info )-import Darcs.Witnesses.Eq ( EqCheck(..), (=\/=), (=/\=) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart )-import Darcs.Witnesses.Ordered ( (:\/:)(..), (:/\:)(..), (:>)(..), (:>)(..),- (+>+), mapFL,- RL(..), FL(..), isShorterThanRL, (+<+),- reverseFL, reverseRL, mapRL, )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL )-import Darcs.ProgressPatches ( progressRL )-import Darcs.Witnesses.Sealed (Sealed(..), FlippedSeal(..), flipSeal, seal )-import Printer ( renderString, vcat )-#include "impossible.h"+import Darcs.Patch.Rebase.NameHack ( NameHack )+import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL,+ appendPSFL )+import Darcs.Patch.Progress ( progressRL )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=\/=), (=/\=) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart )+import Darcs.Patch.Witnesses.Ordered+ ( (:\/:)(..), (:/\:)(..), (:>)(..), Fork(..),+ (+>+), mapFL, RL(..), FL(..), isShorterThanRL,+ (+<+), reverseFL, reverseRL, mapRL )+import Darcs.Patch.Witnesses.Sealed+ ( Sealed(..), FlippedSeal(..), flipSeal, seal ) +import Darcs.Util.Printer ( renderString, vcat, RenderMode(..) )++{-+ - This module uses the following definitions:+ -+ - Explicit dependencies: the set of patches that a patch depends on "by name",+ - i.e. irrespective of (non-)commutation (non commuting patches are implicit+ - dependencies, or conflicts). In other words, the set of patch names in a tag+ - or patch recorded with --ask-deps.+ -+ - Covered: a patch p covers another, q, if p's explicit dependencies include+ - q. E.g. in a repo [a,b,t] where t is a tag and a,b have no explicit+ - dependencies, then t will cover a and b.+ -+ - "Clean" tag: a tag in a repository is clean if all patches prior to the tag+ - are (transitively-)covered by the tag. An obvious example of obtaining an+ - unclean tag is by pulling from one repo into another - the tag could have+ - been commuted past other patches. When patches are created, they are clean,+ - since they explicitly depend on all uncovered patches.+ -}+ {-|-with_partial_intersection takes two 'PatchSet's and splits them into a /common/+taggedIntersection takes two 'PatchSet's and splits them into a /common/ intersection portion and two sets of patches. The intersection, however, is only lazily determined, so there is no guarantee that all intersecting patches will be included in the intersection 'PatchSet'. This is a pretty efficient function, because it makes use of the already-broken-up nature of 'PatchSet's. -Note that the first argument to with_partial_intersection should be+Note that the first argument to taggedIntersection should be the repository that is more cheaply accessed (i.e. local), as-with_partial_intersection does its best to reduce the number of+taggedIntersection does its best to reduce the number of inventories that are accessed from its rightmost argument. -}+taggedIntersection :: forall p wStart wX wY . (Patchy p, NameHack p) =>+ PatchSet p wStart wX -> PatchSet p wStart wY ->+ Fork (RL (Tagged p))+ (RL (PatchInfoAnd p))+ (RL (PatchInfoAnd p)) wStart wX wY+taggedIntersection (PatchSet ps1 NilRL) s2 = Fork NilRL ps1 (newset2RL s2)+taggedIntersection s1 (PatchSet ps2 NilRL) = Fork NilRL (newset2RL s1) ps2+taggedIntersection s1 (PatchSet ps2 (Tagged t _ _ :<: _))+ | Just (PatchSet ps1 ts1) <- maybeSplitSetOnTag (info t) s1 =+ Fork ts1 ps1 (unsafeCoercePStart ps2)+taggedIntersection s1 s2@(PatchSet ps2 (Tagged t _ p :<: ts2)) =+ case hopefullyM t of+ Just _ -> taggedIntersection s1 (PatchSet (ps2 +<+ t :<: p) ts2)+ Nothing -> case splitOnTag (info t) s1 of+ Just (PatchSet NilRL com :> us) ->+ Fork com us (unsafeCoercePStart ps2)+ Just _ -> impossible+ Nothing -> Fork NilRL (newset2RL s1) (newset2RL s2) -with_partial_intersection- :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y)- -> (FORALL(a c) RL (Tagged p) C(start a)- -> RL (PatchInfoAnd p) C(a x)- -> RL (PatchInfoAnd p) C(a c)- -> ddd)- -> ddd-with_partial_intersection (PatchSet ps1 NilRL) s j = j NilRL ps1 (newset2RL s)-with_partial_intersection s (PatchSet ps2 NilRL) j =- j NilRL (newset2RL s) ps2-with_partial_intersection bbb (PatchSet a (Tagged ta _ _ :<: _)) j- | Just (PatchSet b t) <- simpleTag (info ta) bbb = j t b (unsafeCoerceP a)-with_partial_intersection aaa (PatchSet b (Tagged tb _ pb :<: tbs)) j- = case hopefullyM tb of- Just _ -> with_partial_intersection aaa (PatchSet (b+<+tb:<:pb) tbs) j- Nothing -> case splitOnTag (info tb) aaa of- PatchSet NilRL com :> us -> j com us (unsafeCoerceP b)- _ -> impossible+-- |'maybeSplitSetOnTag' takes a tag's 'PatchInfo', @t0@, and a 'PatchSet' and+-- attempts to find @t0@ in one of the 'Tagged's in the PatchSet. If the tag is+-- found, the PatchSet is split up, on that tag, such that all later patches+-- are in the "since last tag" patch list. If the tag is not found, 'Nothing'+-- is returned.+maybeSplitSetOnTag :: PatchInfo -> PatchSet p wStart wX+ -> Maybe (PatchSet p wStart wX)+maybeSplitSetOnTag t0 origSet@(PatchSet ps (Tagged t _ pst :<: ts))+ | t0 == info t = Just origSet+ | otherwise = do+ PatchSet ps' ts' <- maybeSplitSetOnTag t0 (PatchSet (t :<: pst) ts)+ Just $ PatchSet (ps +<+ ps') ts'+maybeSplitSetOnTag _ _ = Nothing -getPatchesBeyondTag :: RepoPatch p => PatchInfo -> PatchSet p C(start x) -> FlippedSeal (RL (PatchInfoAnd p)) C(x)-getPatchesBeyondTag t (PatchSet ps (Tagged hp _ _ :<:_)) | info hp == t = flipSeal ps-getPatchesBeyondTag t patchset@(PatchSet (hp:<:ps) ts) =+getPatchesBeyondTag :: (Patchy p, NameHack p) => PatchInfo -> PatchSet p wStart wX+ -> FlippedSeal (RL (PatchInfoAnd p)) wX+getPatchesBeyondTag t (PatchSet ps (Tagged hp _ _ :<: _)) | info hp == t =+ flipSeal ps+getPatchesBeyondTag t patchset@(PatchSet (hp :<: ps) ts) = if info hp == t- then if getTagsRight patchset == [info hp]- then flipSeal $ NilRL -- special case to avoid looking at redundant patches- else case splitOnTag t patchset of _ :> e -> flipSeal e- else case getPatchesBeyondTag t (PatchSet ps ts) of- FlippedSeal xxs -> FlippedSeal (hp :<: xxs)-getPatchesBeyondTag t (PatchSet NilRL NilRL) = bug $ "tag\n" ++- renderString (humanFriendly t) ++- "\nis not in the patchset in getPatchesBeyondTag."+ then if getUncovered patchset == [info hp]+ -- special case to avoid looking at redundant patches+ then flipSeal NilRL+ else case splitOnTag t patchset of+ Just (_ :> e) -> flipSeal e+ _ -> impossible+ else case getPatchesBeyondTag t (PatchSet ps ts) of+ FlippedSeal xxs -> FlippedSeal (hp :<: xxs)+getPatchesBeyondTag t (PatchSet NilRL NilRL) =+ bug $ "tag\n" ++ renderString Encode (showPatchInfoUI t)+ ++ "\nis not in the patchset in getPatchesBeyondTag." getPatchesBeyondTag t0 (PatchSet NilRL (Tagged t _ ps :<: ts)) =- getPatchesBeyondTag t0 (PatchSet (t:<:ps) ts)+ getPatchesBeyondTag t0 (PatchSet (t :<: ps) ts) -splitOnTag :: RepoPatch p => PatchInfo -> PatchSet p C(start x) -> (PatchSet p :> RL (PatchInfoAnd p)) C(start x)-splitOnTag t (PatchSet ps (Tagged hp x ps2 :<: ts))- | info hp == t = (PatchSet NilRL (Tagged hp x ps2 :<: ts)) :> ps-splitOnTag t patchset@(PatchSet (hp:<:ps) ts)- | info hp == t = if getTagsRight patchset == [info hp]- then PatchSet NilRL (Tagged hp Nothing ps :<: ts) :> NilRL- else case partitionRL ((`notElem` (t:ds)) . info) (hp:<:ps) of- (x:<:a) :> b ->- if getTagsRight (PatchSet (x:<:a) ts) == [t]- then PatchSet NilRL (Tagged x Nothing a :<: ts) :> b- else case splitOnTag t $ eatOne $ PatchSet (x:<:a) ts of- xx :> yy -> xx :> (b +<+ yy)- _ -> impossible- where ds = getdeps (hopefully hp)- eatOne :: PatchSet p C(start x) -> PatchSet p C(start x)- eatOne (PatchSet ps1 (Tagged x _ ps2 :<: ts')) = PatchSet (ps1+<+x:<:ps2) ts'- eatOne _ = bug "a stubborn case in splitOnTag (theoretically possible)"-splitOnTag t (PatchSet (p:<:ps) ts) = case splitOnTag t (PatchSet ps ts) of- ns :> x -> ns :> (p:<:x)-splitOnTag t0 (PatchSet NilRL (Tagged t _ ps :<: ts)) = splitOnTag t0 (PatchSet (t:<:ps) ts)-splitOnTag t0 (PatchSet NilRL NilRL) = bug $ "tag\n" ++- renderString (humanFriendly t0) ++- "\nis not in the patchset in splitOnTag."+-- |splitOnTag takes a tag's 'PatchInfo', and a 'PatchSet', and attempts to+-- find the tag in the PatchSet, returning a pair: the clean PatchSet "up to"+-- the tag, and a RL of patches after the tag; If the tag is not in the+-- PatchSet, we return Nothing.+splitOnTag :: (Patchy p, NameHack p) => PatchInfo -> PatchSet p wStart wX+ -> Maybe ((PatchSet p :> RL (PatchInfoAnd p)) wStart wX)+-- If the tag we are looking for is the first Tagged tag of the patchset, just+-- separate out the patchset's patches.+splitOnTag t (PatchSet ps ts@(Tagged hp _ _ :<: _)) | info hp == t =+ Just $ PatchSet NilRL ts :> ps+-- If the tag is the most recent patch in the set, we check if the patch is the+-- only non-depended-on patch in the set (i.e. it is a clean tag); creating a+-- new Tagged out of the patches and tag, and adding it to the patchset, if+-- this is the case. Otherwise, we try to make the tag clean.+splitOnTag t patchset@(PatchSet hps@(hp :<: ps) ts) | info hp == t =+ if getUncovered patchset == [t]+ then Just $ PatchSet NilRL (Tagged hp Nothing ps :<: ts) :> NilRL+ else case partitionRL ((`notElem` (t : ds)) . info) hps of+ -- Partition hps by those that are the tag and its explicit deps.+ tagAndDeps@(hp' :<: ds') :> nonDeps ->+ -- If @ds@ doesn't contain the tag of the first Tagged, that+ -- tag will also be returned by the call to getUncovered - so+ -- we need to unwrap the next Tagged in order to expose it to+ -- being partitioned out in the recursive call to splitOnTag.+ if getUncovered (PatchSet tagAndDeps ts) == [t]+ then let tagged = Tagged hp' Nothing ds' in+ return $ PatchSet NilRL (tagged :<: ts) :> nonDeps+ else do+ unfolded <- unwrapOneTagged $ PatchSet tagAndDeps ts+ xx :> yy <- splitOnTag t unfolded+ return $ xx :> (nonDeps +<+ yy)+ _ -> impossible+ where+ ds = getdeps (hopefully hp)+-- We drop the leading patch, to try and find a non-Tagged tag.+splitOnTag t (PatchSet (p :<: ps) ts) = do+ ns :> x <- splitOnTag t (PatchSet ps ts)+ return $ ns :> (p :<: x)+-- If there are no patches left, we "unfold" the next Tagged, and try again.+splitOnTag t0 patchset@(PatchSet NilRL (Tagged _ _ _s :<: _)) =+ unwrapOneTagged patchset >>= splitOnTag t0+-- If we've checked all the patches, but haven't found the tag, return Nothing.+splitOnTag _ (PatchSet NilRL NilRL) = Nothing --- | @getPatchesInTag t ps@ returns a 'SealedPatchSet' of all--- patches in @ps@ which are contained in @t@.-getPatchesInTag :: RepoPatch p => PatchInfo -> PatchSet p C(start x) -> SealedPatchSet p C(start)-getPatchesInTag t ns = case splitOnTag t ns of- ns' :> _ -> seal ns'+-- |'unwrapOneTagged' unfolds a single Tagged object in a PatchSet, adding the+-- tag and patches to the PatchSet's patch list.+unwrapOneTagged :: (Monad m) => PatchSet p wX wY -> m (PatchSet p wX wY)+unwrapOneTagged (PatchSet ps (Tagged t _ tps :<: ts)) =+ return $ PatchSet (ps +<+ t :<: tps) ts+unwrapOneTagged _ = fail "called unwrapOneTagged with no Tagged's in the set" --- | @getTagsRight ps@ returns the 'PatchInfo' for all the patches in+-- | @getUncovered ps@ returns the 'PatchInfo' for all the patches in -- @ps@ that are not depended on by anything else *through explicit -- dependencies*. Tags are a likely candidate, although we may also -- find some non-tag patches in this list.@@ -135,159 +207,178 @@ -- Keep in mind that in a typical repository with a lot of tags, only a small -- fraction of tags would be returned as they would be at least indirectly -- depended on by the topmost ones.-getTagsRight :: PatchSet p C(start x) -> [PatchInfo]-getTagsRight (PatchSet ps NilRL) = getTagsR (mapRL infoAndDeps ps)-getTagsRight (PatchSet ps (Tagged t _ _ :<: _)) = getTagsR (mapRL infoAndDeps (ps+<+t:<:NilRL))+getUncovered :: PatchSet p wStart wX -> [PatchInfo]+getUncovered patchset = case patchset of+ (PatchSet ps NilRL) -> findUncovered (mapRL infoAndExplicitDeps ps)+ (PatchSet ps (Tagged t _ _ :<: _)) ->+ findUncovered (mapRL infoAndExplicitDeps (ps +<+ t :<: NilRL))+ where+ findUncovered :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo]+ findUncovered [] = []+ findUncovered ((pi, Nothing) : rest) = pi : findUncovered rest+ findUncovered ((pi, Just deps) : rest) =+ pi : findUncovered (dropDepsIn deps rest) -getTagsR :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo]-getTagsR [] = []-getTagsR ((i0,Nothing):pps0) = i0 : getTagsR pps0-getTagsR ((i0,Just ds0):pps0) = i0 : getTagsR (drop_tags_r ds0 pps0)- where- -- example traversal given dependencies:- --- -- X1 -> X2- -- X1 -> X4- -- X2 -> X3- --- -- [X2,X4]: | o1 o2 X2 o3 o4 X3 o5 X5- -- o1 |o2 X2 o3 o4 X3 o5 X5- -- [X4,X3]: o1 o2 | o3 o4 X3 o5 X5- -- ...- -- [X4]: o1 o2 o3 o4 | o5 X5- -- ...- -- []: o1 o2 o3 o4 o5- drop_tags_r :: [PatchInfo]- -> [(PatchInfo, Maybe [PatchInfo])] -> [(PatchInfo, Maybe [PatchInfo])]- drop_tags_r [] pps = pps- drop_tags_r _ [] = []- drop_tags_r ds (hp:pps)- | fst hp `elem` ds = case snd hp of- Just ds' -> drop_tags_r (ds'++delete (fst hp) ds) pps- Nothing -> drop_tags_r (delete (fst hp) ds) pps- | otherwise = hp : drop_tags_r ds pps+ -- |dropDepsIn traverses the list of patches, dropping any patches that+ -- occur in the dependency list; when a patch is dropped, its dependencies+ -- are added to the dependency list used for later patches.+ dropDepsIn :: [PatchInfo] -> [(PatchInfo, Maybe [PatchInfo])]+ -> [(PatchInfo, Maybe [PatchInfo])]+ dropDepsIn [] pps = pps+ dropDepsIn _ [] = []+ dropDepsIn ds (hp : pps)+ | fst hp `elem` ds =+ let extraDeps = fromMaybe [] $ snd hp in+ dropDepsIn (extraDeps ++ delete (fst hp) ds) pps+ | otherwise = hp : dropDepsIn ds pps -infoAndDeps :: PatchInfoAnd p C(x y) -> (PatchInfo, Maybe [PatchInfo])-infoAndDeps p+ -- |infoAndExplicitDeps returns the patch info and (for tags only) the list+ -- of explicit dependencies of a patch.+ infoAndExplicitDeps :: PatchInfoAnd p wX wY+ -> (PatchInfo, Maybe [PatchInfo])+ infoAndExplicitDeps p | isTag (info p) = (info p, getdeps `fmap` hopefullyM p) | otherwise = (info p, Nothing) --- | @deepOptimizePatchset@ runs through all patches whether they are in the--- surface inventory or the deep one.-deepOptimizePatchset :: PatchSet p C(start x) -> PatchSet p C(start x)-deepOptimizePatchset ns = optimizePatchset (PatchSet (newset2RL ns) NilRL)---- | @optimizePatchset@ is similar to @slightlyOptimizePatchset@ in--- that it only works on the surface inventory (see below), but it--- works a bit harder and can optimize several tags.------ * surface inventory: the sequence of patches that corresponds--- to the @\_darcs/hashed\_inventory@ or @\_darcs/inventory@ files------ * deep inventory: the sequence of sequences of patches that--- corresponds to the @\_darcs/inventories@ directory-optimizePatchset :: PatchSet p C(start x) -> PatchSet p C(start x)-optimizePatchset (PatchSet NilRL ts) = PatchSet NilRL ts-optimizePatchset (PatchSet (p:<:ps) ts)- | isTag (info p) && getTagsRight (PatchSet (p:<:ps) ts) == [info p]- -- all subsequent patches depend on p- = case optimizePatchset (PatchSet ps ts) of- PatchSet ps' ts' -> PatchSet NilRL (Tagged p Nothing ps' :<: ts')- | otherwise = case optimizePatchset (PatchSet ps ts) of- PatchSet ps' ts' -> PatchSet (p:<:ps') ts'- -- | @slightlyOptimizePatchset@ only works on the surface inventory -- (see 'optimizePatchset') and only optimises at most one tag in -- there, going for the most recent tag which has no non-depended -- patch after it. Older tags won't be 'clean', which means the -- PatchSet will not be in 'unclean :< clean' state.-slightlyOptimizePatchset :: PatchSet p C(start x) -> PatchSet p C(start x)-slightlyOptimizePatchset (PatchSet ps0 ts0) = sops $ PatchSet (progressRL "Optimizing inventory" ps0) ts0- where sops :: PatchSet p C(start y) -> PatchSet p C(start y)- sops (PatchSet NilRL ts) = PatchSet NilRL ts- sops (PatchSet (hp:<:ps) ts)- | isTag (info hp) = if getTagsRight (PatchSet (hp:<:ps) ts) == [info hp]- then -- exactly one tag and it depends on everything not already archived- PatchSet NilRL (Tagged hp Nothing ps :<: ts)- else -- other tags or other top-level patches too (so move past hp)- case sops $ PatchSet (progressRL "Optimizing inventory" ps) ts of- PatchSet ps' ts' -> PatchSet (hp:<:ps') ts'- | otherwise = -- move past hp- case sops $ PatchSet ps ts of- PatchSet ps' ts' -> PatchSet (hp:<:ps') ts'+slightlyOptimizePatchset :: PatchSet p wStart wX -> PatchSet p wStart wX+slightlyOptimizePatchset (PatchSet ps0 ts0) =+ sops $ PatchSet (prog ps0) ts0+ where+ prog = progressRL "Optimizing inventory"+ sops :: PatchSet p wStart wY -> PatchSet p wStart wY+ sops patchset@(PatchSet NilRL _) = patchset+ sops patchset@(PatchSet (hp :<: ps) ts)+ | isTag (info hp) =+ if getUncovered patchset == [info hp]+ -- exactly one tag and it depends on everything not already+ -- archived+ then PatchSet NilRL (Tagged hp Nothing ps :<: ts)+ -- other tags or other top-level patches too (so move past hp)+ else let ps' = sops $ PatchSet (prog ps) ts in+ appendPSFL ps' (hp :>: NilFL)+ | otherwise = appendPSFL (sops $ PatchSet ps ts) (hp :>: NilFL) -commuteToEnd :: forall p C(start x y). RepoPatch p => RL (PatchInfoAnd p) C(x y)- -> PatchSet p C(start y) -> (PatchSet p :> RL (PatchInfoAnd p)) C(start x)+commuteToEnd :: forall p wStart wX wY+ . (Patchy p, NameHack p)+ => RL (PatchInfoAnd p) wX wY+ -> PatchSet p wStart wY+ -> (PatchSet p :> RL (PatchInfoAnd p)) wStart wX commuteToEnd NilRL (PatchSet ps ts) = PatchSet NilRL ts :> ps-commuteToEnd (p:<:ps) (PatchSet xs ts)- | info p `elem` mapRL info xs = case fastRemoveRL p xs of- Just xs' -> commuteToEnd ps (PatchSet xs' ts)- Nothing -> impossible -- "Nothing is impossible"+commuteToEnd (p :<: ps) (PatchSet xs ts) | info p `elem` mapRL info xs =+ case fastRemoveRL p xs of+ Just xs' -> commuteToEnd ps (PatchSet xs' ts)+ Nothing -> impossible -- "Nothing is impossible" commuteToEnd ps (PatchSet xs (Tagged t _ ys :<: ts)) =- commuteToEnd ps (PatchSet (xs+<+t:<:ys) ts)+ commuteToEnd ps (PatchSet (xs +<+ t :<: ys) ts) commuteToEnd _ _ = impossible -removeFromPatchSet :: RepoPatch p => FL (PatchInfoAnd p) C(x y)- -> PatchSet p C(start y) -> Maybe (PatchSet p C(start x))+removeFromPatchSet :: (Patchy p, NameHack p) => FL (PatchInfoAnd p) wX wY+ -> PatchSet p wStart wY -> Maybe (PatchSet p wStart wX) removeFromPatchSet bad0 = rfns (reverseFL bad0)- where rfns :: RepoPatch p => RL (PatchInfoAnd p) C(x y)- -> PatchSet p C(start y) -> Maybe (PatchSet p C(start x))- rfns bad (PatchSet ps ts)- | all (`elem` (mapRL info ps)) (mapRL info bad) =- do ps' <- removeSubsequenceRL bad ps- Just $ PatchSet ps' ts- rfns _ (PatchSet _ NilRL) = Nothing- rfns bad (PatchSet ps (Tagged t _ tps :<: ts)) =- rfns bad (PatchSet (ps+<+t:<:tps) ts)+ where+ rfns :: (Patchy p, NameHack p)+ => RL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY+ -> Maybe (PatchSet p wStart wX)+ rfns bad (PatchSet ps ts)+ | all (`elem` mapRL info ps) (mapRL info bad) = do+ ps' <- removeSubsequenceRL bad ps+ Just $ PatchSet ps' ts+ rfns _ (PatchSet _ NilRL) = Nothing+ rfns bad (PatchSet ps (Tagged t _ tps :<: ts)) =+ rfns bad (PatchSet (ps +<+ t :<: tps) ts) -findCommonWithThem :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y)- -> (PatchSet p :> FL (PatchInfoAnd p)) C(start x)-findCommonWithThem us them =- with_partial_intersection us them $- \common us' them' ->+findCommonAndUncommon :: forall p wStart wX wY . (Patchy p, NameHack p)+ => PatchSet p wStart wX -> PatchSet p wStart wY+ -> Fork (PatchSet p)+ (FL (PatchInfoAnd p))+ (FL (PatchInfoAnd p)) wStart wX wY+findCommonAndUncommon us them = case taggedIntersection us them of+ Fork common us' them' ->+ case partitionFL (infoIn them') $ reverseRL us' of+ _ :> bad@(_ :>: _) :> _ ->+ bug $ "Failed to commute common patches:\n"+ ++ renderString Encode+ (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad)+ (common2 :> NilFL :> only_ours) ->+ case partitionFL (infoIn us') $ reverseRL them' of+ _ :> bad@(_ :>: _) :> _ ->+ bug $ "Failed to commute common patches:\n"+ ++ renderString Encode (vcat $+ mapRL (showPatchInfoUI . info) $ reverseFL bad)+ _ :> NilFL :> only_theirs ->+ Fork (PatchSet (reverseFL common2) common)+ only_ours (unsafeCoercePStart only_theirs)+ where+ infoIn inWhat = (`elem` mapRL info inWhat) . info++findCommonWithThem :: (Patchy p, NameHack p)+ => PatchSet p wStart wX+ -> PatchSet p wStart wY+ -> (PatchSet p :> FL (PatchInfoAnd p)) wStart wX+findCommonWithThem us them = case taggedIntersection us them of+ Fork common us' them' -> case partitionFL ((`elem` mapRL info them') . info) $ reverseRL us' of- _ :> bad@(_:>:_) :> _ -> bug $ "Failed to commute common patches:\n" ++- (renderString $ vcat $ mapRL (humanFriendly . info) $ reverseFL bad)- common2 :> _nilfl :> only_ours -> PatchSet (reverseFL common2) common :> unsafeCoerceP only_ours+ _ :> bad@(_ :>: _) :> _ ->+ bug $ "Failed to commute common patches:\n"+ ++ renderString Encode+ (vcat $ mapRL (showPatchInfoUI . info) $ reverseFL bad)+ common2 :> _nilfl :> only_ours ->+ PatchSet (reverseFL common2) common :> unsafeCoerceP only_ours -findUncommon :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y)- -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(x y)+findUncommon :: (Patchy p, NameHack p)+ => PatchSet p wStart wX -> PatchSet p wStart wY+ -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wX wY findUncommon us them =- case findCommonWithThem us them of- _common :> us' -> case findCommonWithThem them us of- _ :> them' -> unsafeCoercePStart us' :\/: them'+ case findCommonWithThem us them of+ _common :> us' -> case findCommonWithThem them us of+ _ :> them' -> unsafeCoercePStart us' :\/: them' -countUsThem :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y) -> (Int, Int)+countUsThem :: (Patchy p, NameHack p)+ => PatchSet p wStart wX+ -> PatchSet p wStart wY+ -> (Int, Int) countUsThem us them =- with_partial_intersection us them $- \_ us' them' -> let uu = mapRL info us'- tt = mapRL info them'- in (length $ uu \\ tt, length $ tt \\ uu)+ case taggedIntersection us them of+ Fork _ us' them' -> let uu = mapRL info us'+ tt = mapRL info them' in+ (length $ uu \\ tt, length $ tt \\ uu) -mergeThem :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y)- -> Sealed (FL (PatchInfoAnd p) C(x))+mergeThem :: (Patchy p, Merge p, NameHack p)+ => PatchSet p wStart wX -> PatchSet p wStart wY+ -> Sealed (FL (PatchInfoAnd p) wX) mergeThem us them =- with_partial_intersection us them $- \_ us' them' -> merge2FL (reverseRL us') (reverseRL them')+ case taggedIntersection us them of+ Fork _ us' them' ->+ case merge2FL (reverseRL us') (reverseRL them') of+ them'' :/\: _ -> Sealed them'' -newsetIntersection :: RepoPatch p => [SealedPatchSet p C(start)] -> SealedPatchSet p C(start)+newsetIntersection :: (Patchy p, NameHack p)+ => [SealedPatchSet p wStart]+ -> SealedPatchSet p wStart newsetIntersection [] = seal $ PatchSet NilRL NilRL newsetIntersection [x] = x-newsetIntersection (Sealed y:ys) =+newsetIntersection (Sealed y : ys) = case newsetIntersection ys of- Sealed z -> with_partial_intersection y z $- \common a b ->- case mapRL info a `intersect` mapRL info b of- morecommon ->- case partitionRL (\e -> info e `notElem` morecommon) a of+ Sealed z -> case taggedIntersection y z of+ Fork common a b -> case mapRL info a `intersect` mapRL info b of+ morecommon ->+ case partitionRL (\e -> info e `notElem` morecommon) a of commonps :> _ -> seal $ PatchSet commonps common -newsetUnion :: RepoPatch p => [SealedPatchSet p C(start)] -> SealedPatchSet p C(start)+newsetUnion :: (Patchy p, Merge p, NameHack p)+ => [SealedPatchSet p wStart]+ -> SealedPatchSet p wStart newsetUnion [] = seal $ PatchSet NilRL NilRL newsetUnion [x] = x-newsetUnion (Sealed y@(PatchSet psy tsy):Sealed y2:ys) =+newsetUnion (Sealed y@(PatchSet psy tsy) : Sealed y2 : ys) = case mergeThem y y2 of- Sealed p2 -> newsetUnion $ seal (PatchSet (reverseFL p2+<+psy) tsy) : ys+ Sealed p2 ->+ newsetUnion $ seal (PatchSet (reverseFL p2 +<+ psy) tsy) : ys -- | Merge two FLs (say L and R), starting in a common context. The result is a -- FL starting in the original end context of L, going to a new context that is@@ -300,79 +391,87 @@ -- does -- (Question from Eric Kow: in what sense? Why not fix the mergeFL instance?) ----- * 'mergeFL' returns both paths of the merge diamond, but this version only--- returns one, so you'd better choose the order carefully, eg.--- (@merge2FL l r@)--- -- * The conventional order we use in this function is reversed from -- 'mergeFL' (so @mergeFL r l@ vs. @merge2FL l r@. This does not -- matter so much for the former since you get both paths. -- (Question from Eric Kow: should we flip merge2FL for more uniformity in -- the code?)-merge2FL :: RepoPatch p => FL (PatchInfoAnd p) C(x y)- -> FL (PatchInfoAnd p) C(x z)- -> Sealed (FL (PatchInfoAnd p) C(y))-merge2FL _ NilFL = seal NilFL-merge2FL NilFL ys = seal ys-merge2FL xs (y:>:ys) | Just xs' <- fastRemoveFL y xs = merge2FL xs' ys-merge2FL (x:>:xs) ys | Just ys' <- fastRemoveFL x ys = merge2FL xs ys'- | otherwise = case mergeFL (x :\/: ys) of- ys' :/\: _ -> merge2FL xs ys'--simpleTag :: PatchInfo -> PatchSet p C(start x) -> Maybe (PatchSet p C(start x))-simpleTag t0 (PatchSet ps (Tagged t h pst :<: ts))- | t0 == info t = Just $ PatchSet ps (Tagged t h pst :<: ts)- | otherwise = do PatchSet ps' ts' <- simpleTag t0 (PatchSet (t:<:pst) ts)- Just $ PatchSet (ps +<+ ps') ts'-simpleTag _ _ = Nothing+merge2FL :: (Patchy p, Merge p, NameHack p)+ => FL (PatchInfoAnd p) wX wY+ -> FL (PatchInfoAnd p) wX wZ+ -> (FL (PatchInfoAnd p) :/\: FL (PatchInfoAnd p)) wY wZ+merge2FL xs NilFL = NilFL :/\: xs+merge2FL NilFL ys = ys :/\: NilFL+merge2FL xs (y :>: ys) | Just xs' <- fastRemoveFL y xs = merge2FL xs' ys+merge2FL (x :>: xs) ys | Just ys' <- fastRemoveFL x ys = merge2FL xs ys'+ | otherwise = case mergeFL (x :\/: ys) of+ ys' :/\: x' ->+ case merge2FL xs ys' of+ ys'' :/\: xs' ->+ ys'' :/\: (x' :>: xs') -areUnrelatedRepos :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y) -> Bool+areUnrelatedRepos :: (Patchy p, NameHack p)+ => PatchSet p wStart wX+ -> PatchSet p wStart wY -> Bool areUnrelatedRepos us them =- with_partial_intersection us them checkit- where checkit (Tagged _ _ _ :<: _) _ _ = False- checkit _ u t | t `isShorterThanRL` 5 = False- | u `isShorterThanRL` 5 = False- | otherwise = null $ intersect (mapRL info u) (mapRL info t)+ case taggedIntersection us them of+ Fork c u t -> checkit c u t+ where+ checkit (Tagged{} :<: _) _ _ = False+ checkit _ u t | t `isShorterThanRL` 5 = False+ | u `isShorterThanRL` 5 = False+ | otherwise = null $ intersect (mapRL info u) (mapRL info t) -- | Remove a patch from FL, using PatchInfo equality. The result is Just -- whenever the patch has been found and removed. If the patch is not present -- in the sequence at all or any commutation fails, we get Nothing. First two -- cases are optimisations for the common cases where the head of the list is -- the patch to remove, or the patch is not there at all.-fastRemoveFL :: RepoPatch p => PatchInfoAnd p C(x y) -> FL (PatchInfoAnd p) C(x z)- -> Maybe (FL (PatchInfoAnd p) C(y z))+fastRemoveFL :: (Patchy p, NameHack p)+ => PatchInfoAnd p wX wY+ -> FL (PatchInfoAnd p) wX wZ -> Maybe (FL (PatchInfoAnd p) wY wZ) fastRemoveFL _ NilFL = Nothing-fastRemoveFL a (b:>:bs) | IsEq <- a =\/= b = Just bs- | info a `notElem` mapFL info bs = Nothing-fastRemoveFL a (b:>:bs) = do a' :> bs' <- pullout NilRL bs- a'' :> b' <- commute (b :> a')- IsEq <- return (a'' =\/= a)- Just (b':>:bs')- where i = info a- pullout :: RepoPatch p => RL (PatchInfoAnd p) C(a0 a)- -> FL (PatchInfoAnd p) C(a b)- -> Maybe ((PatchInfoAnd p :> FL (PatchInfoAnd p)) C(a0 b))- pullout _ NilFL = Nothing- pullout acc (x:>:xs) | info x == i = do x' :> acc' <- commuteRL (acc :> x)- Just (x' :> reverseRL acc' +>+ xs)- | otherwise = pullout (x:<:acc) xs+fastRemoveFL a (b :>: bs) | IsEq <- a =\/= b = Just bs+ | info a `notElem` mapFL info bs = Nothing+fastRemoveFL a (b :>: bs) = do+ a' :> bs' <- pullout NilRL bs+ a'' :> b' <- commute (b :> a')+ IsEq <- return (a'' =\/= a)+ Just (b' :>: bs')+ where+ i = info a+ pullout :: (Patchy p, NameHack p)+ => RL (PatchInfoAnd p) wA0 wA+ -> FL (PatchInfoAnd p) wA wB+ -> Maybe ((PatchInfoAnd p :> FL (PatchInfoAnd p)) wA0 wB)+ pullout _ NilFL = Nothing+ pullout acc (x :>: xs)+ | info x == i = do x' :> acc' <- commuteRL (acc :> x)+ Just (x' :> reverseRL acc' +>+ xs)+ | otherwise = pullout (x :<: acc) xs -fastRemoveRL :: RepoPatch p => PatchInfoAnd p C(y z) -> RL (PatchInfoAnd p) C(x z)- -> Maybe (RL (PatchInfoAnd p) C(x y))+fastRemoveRL :: (Patchy p, NameHack p)+ => PatchInfoAnd p wY wZ+ -> RL (PatchInfoAnd p) wX wZ -> Maybe (RL (PatchInfoAnd p) wX wY) fastRemoveRL _ NilRL = Nothing-fastRemoveRL a (b:<:bs) | IsEq <- a =/\= b = Just bs- | info a `notElem` mapRL info bs = Nothing-fastRemoveRL a (b:<:bs) = do bs' :> a' <- pullout NilFL bs- b' :> a'' <- commute (a' :> b)- IsEq <- return (a'' =/\= a)- Just (b':<:bs')- where i = info a- pullout :: RepoPatch p => FL (PatchInfoAnd p) C(b c)- -> RL (PatchInfoAnd p) C(a b)- -> Maybe ((RL (PatchInfoAnd p) :> PatchInfoAnd p) C(a c))- pullout _ NilRL = Nothing- pullout acc (x:<:xs) | info x == i = do acc' :> x' <-- either (const Nothing)- Just (commuteFLorComplain (x :> acc))- Just (reverseFL acc' +<+ xs :> x')- | otherwise = pullout (x:>:acc) xs+fastRemoveRL a (b :<: bs) | IsEq <- a =/\= b = Just bs+ | info a `notElem` mapRL info bs = Nothing+fastRemoveRL a (b :<: bs) = do+ bs' :> a' <- pullout NilFL bs+ b' :> a'' <- commute (a' :> b)+ IsEq <- return (a'' =/\= a)+ Just (b' :<: bs')+ where+ i = info a+ pullout :: (Patchy p, NameHack p)+ => FL (PatchInfoAnd p) wB wC+ -> RL (PatchInfoAnd p) wA wB+ -> Maybe ((RL (PatchInfoAnd p) :> PatchInfoAnd p) wA wC)+ pullout _ NilRL = Nothing+ pullout acc (x :<: xs)+ | info x == i = do+ acc' :> x' <- either (const Nothing)+ Just+ (commuteFLorComplain (x :> acc))+ Just (reverseFL acc' +<+ xs :> x')+ | otherwise = pullout (x :>: acc) xs
src/Darcs/Patch/Dummy.hs view
@@ -2,19 +2,57 @@ {-# LANGUAGE EmptyDataDecls #-} module Darcs.Patch.Dummy ( DummyPatch ) where +import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )+import Darcs.Patch.Debug ( PatchDebug(..) )+import Darcs.Patch.Effect ( Effect ) import Darcs.Patch.FileHunk ( IsHunk ) import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.Matchable ( Matchable )+import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Patch.Patchy ( Patchy, ShowPatch, Invert, Commute, Apply(..), PatchInspect , ReadPatch )+import Darcs.Patch.Prim ( FromPrim, PrimPatch, PrimPatchBase(..) )+import Darcs.Patch.Prim.Class+ ( PrimConstruct, PrimCanonize, PrimClassify+ , PrimDetails, PrimShow, PrimRead, PrimApply )+import Darcs.Patch.Merge ( Merge)+import Darcs.Patch.Rebase.NameHack ( NameHack )+import Darcs.Patch.Rebase.Recontext ( RecontextRebase )+import Darcs.Patch.Repair ( Check, RepairToFL )+import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.Show ( ShowPatchBasic )-import Darcs.Witnesses.Eq ( MyEq )+import Darcs.Patch.Witnesses.Eq ( MyEq ) import Storage.Hashed.Tree( Tree ) -#include "gadts.h" -data DummyPatch C(x y)+data DummyPrim wX wY+data DummyPatch wX wY +instance IsHunk DummyPrim+instance PatchListFormat DummyPrim+instance MyEq DummyPrim+instance Invert DummyPrim+instance PatchInspect DummyPrim+instance ReadPatch DummyPrim+instance ShowPatchBasic DummyPrim+instance ShowPatch DummyPrim+instance Commute DummyPrim+instance Apply DummyPrim+instance Patchy DummyPrim++instance RepairToFL DummyPrim+instance PrimConstruct DummyPrim+instance PrimCanonize DummyPrim+instance PrimClassify DummyPrim+instance PrimDetails DummyPrim+instance PrimShow DummyPrim+instance PrimRead DummyPrim+instance PrimApply DummyPrim+instance PrimPatch DummyPrim++instance PatchDebug DummyPrim+ instance IsHunk DummyPatch instance PatchListFormat DummyPatch instance MyEq DummyPatch@@ -26,4 +64,21 @@ instance Commute DummyPatch instance Apply DummyPatch where type ApplyState DummyPatch = Tree+instance Matchable DummyPatch instance Patchy DummyPatch++instance Effect DummyPatch+instance Merge DummyPatch+instance Conflict DummyPatch+instance FromPrim DummyPatch+instance CommuteNoConflicts DummyPatch+instance Check DummyPatch+instance RepairToFL DummyPatch+instance PrimPatchBase DummyPatch where+ type PrimOf DummyPatch = DummyPrim+instance MaybeInternal DummyPatch+instance NameHack DummyPatch+instance RecontextRebase DummyPatch+instance RepoPatch DummyPatch++instance PatchDebug DummyPatch
src/Darcs/Patch/Effect.hs view
@@ -2,21 +2,20 @@ import Darcs.Patch.Prim.Class ( PrimOf ) -import Darcs.Witnesses.Ordered+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), reverseFL, reverseRL , concatFL, concatRL, mapFL_FL, mapRL_RL ) -#include "gadts.h" -- | Patches whose concrete effect which can be expressed as a list of -- primitive patches. -- -- A minimal definition would be either of @effect@ or @effectRL@. class Effect p where- effect :: p C(x y) -> FL (PrimOf p) C(x y)+ effect :: p wX wY -> FL (PrimOf p) wX wY effect = reverseRL . effectRL- effectRL :: p C(x y) -> RL (PrimOf p) C(x y)+ effectRL :: p wX wY -> RL (PrimOf p) wX wY effectRL = reverseFL . effect instance Effect p => Effect (FL p) where
src/Darcs/Patch/FileHunk.hs view
@@ -3,24 +3,23 @@ ) where -import Darcs.Patch.FileName ( FileName )+import Darcs.Util.Path ( FileName ) import Darcs.Patch.Format ( FileNameFormat ) import Darcs.Patch.Show ( formatFileName ) -import Printer+import Darcs.Util.Printer ( Doc, blueText, text, lineColor, vcat, userchunkPS , prefix, ($$), (<+>), Color(Cyan, Magenta) ) import qualified Data.ByteString as B ( ByteString ) -#include "gadts.h" -data FileHunk C(x y) = FileHunk !FileName !Int [B.ByteString] [B.ByteString]+data FileHunk wX wY = FileHunk !FileName !Int [B.ByteString] [B.ByteString] class IsHunk p where- isHunk :: p C(x y) -> Maybe (FileHunk C(x y))+ isHunk :: p wX wY -> Maybe (FileHunk wX wY) -showFileHunk :: FileNameFormat -> FileHunk C(x y) -> Doc+showFileHunk :: FileNameFormat -> FileHunk wX wY -> Doc showFileHunk x (FileHunk f line old new) = blueText "hunk" <+> formatFileName x f <+> text (show line) $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS old))
− src/Darcs/Patch/FileName.hs
@@ -1,161 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- | FileName is an abstract type intended to facilitate the input and output of--- unicode filenames.-module Darcs.Patch.FileName ( FileName( ),- fp2fn, fn2fp,- fn2ps, ps2fn,- niceps2fn, fn2niceps,- breakOnDir, normPath, ownName, superName,- movedirfilename,- encodeWhite, decodeWhite,- (///),- breakup, isParentOrEqOf- ) where--import Data.Char ( isSpace, chr, ord )-import Data.List ( stripPrefix )-import ByteStringUtils ( packStringToUTF8, unpackPSFromUTF8 )-import qualified Data.ByteString.Char8 as BC (unpack, pack)-import qualified Data.ByteString as B (ByteString)--newtype FileName = FN FilePath deriving ( Eq, Ord )--instance Show FileName where- showsPrec d (FN fp) = showParen (d > appPrec) $ showString "fp2fn " . showsPrec (appPrec + 1) fp- where appPrec = 10--{-# INLINE fp2fn #-}-fp2fn :: FilePath -> FileName-fp2fn fp = FN fp--{-# INLINE fn2fp #-}-fn2fp :: FileName -> FilePath-fn2fp (FN fp) = fp--{-# INLINE niceps2fn #-}-niceps2fn :: B.ByteString -> FileName-niceps2fn = FN . decodeWhite . BC.unpack--{-# INLINE fn2niceps #-}-fn2niceps :: FileName -> B.ByteString-fn2niceps (FN fp) = BC.pack $ encodeWhite fp--{-# INLINE fn2ps #-}-fn2ps :: FileName -> B.ByteString-fn2ps (FN fp) = packStringToUTF8 $ encodeWhite fp--{-# INLINE ps2fn #-}-ps2fn :: B.ByteString -> FileName-ps2fn ps = FN $ decodeWhite $ unpackPSFromUTF8 ps---- | 'encodeWhite' translates whitespace in filenames to a darcs-specific--- format (numerical representation according to 'ord' surrounded by--- backslashes). Note that backslashes are also escaped since they are used--- in the encoding.------ > encodeWhite "hello there" == "hello\32\there"--- > encodeWhite "hello\there" == "hello\92\there"-encodeWhite :: FilePath -> String-encodeWhite (c:cs) | isSpace c || c == '\\' =- '\\' : (show $ ord c) ++ "\\" ++ encodeWhite cs-encodeWhite (c:cs) = c : encodeWhite cs-encodeWhite [] = []---- | 'decodeWhite' interprets the Darcs-specific \"encoded\" filenames--- produced by 'encodeWhite'------ > decodeWhite "hello\32\there" == "hello there"--- > decodeWhite "hello\92\there" == "hello\there"--- > decodeWhite "hello\there" == error "malformed filename"-decodeWhite :: String -> FilePath-decodeWhite ('\\':cs) =- case break (=='\\') cs of- (theord, '\\':rest) ->- chr (read theord) : decodeWhite rest- _ -> error "malformed filename"-decodeWhite (c:cs) = c: decodeWhite cs-decodeWhite "" = ""--ownName :: FileName -> FileName-ownName (FN f) = case breakLast '/' f of Nothing -> FN f- Just (_,f') -> FN f'-superName :: FileName -> FileName-superName fn = case normPath fn of- FN f -> case breakLast '/' f of- Nothing -> FN "."- Just (d,_) -> FN d-breakOnDir :: FileName -> Maybe (FileName,FileName)-breakOnDir (FN p) = case breakFirst '/' p of- Nothing -> Nothing- Just (d,f) | d == "." -> breakOnDir $ FN f- | otherwise -> Just (FN d, FN f)-normPath :: FileName -> FileName -- remove "./"-normPath (FN p) = FN $ repath $ dropDotdot $ breakup p--repath :: [String] -> String-repath [] = ""-repath [f] = f-repath (d:p) = d ++ "/" ++ repath p--dropDotdot :: [String] -> [String]-dropDotdot ("":p) = dropDotdot p-dropDotdot (".":p) = dropDotdot p-dropDotdot ("..":p) = ".." : (dropDotdot p)-dropDotdot (_:"..":p) = dropDotdot p-dropDotdot (d:p) = case dropDotdot p of- ("..":p') -> p'- p' -> d : p'-dropDotdot [] = []---- | Split a file path at the slashes-breakup :: String -> [String]-breakup p = case break (=='/') p of- (d,"") -> [d]- (d,p') -> d : breakup (tail p')--breakFirst :: Char -> String -> Maybe (String,String)-breakFirst c l = bf [] l- where bf a (r:rs) | r == c = Just (reverse a,rs)- | otherwise = bf (r:a) rs- bf _ [] = Nothing-breakLast :: Char -> String -> Maybe (String,String)-breakLast c l = case breakFirst c (reverse l) of- Nothing -> Nothing- Just (a,b) -> Just (reverse b, reverse a)--(///) :: FileName -> FileName -> FileName-(FN "")///b = normPath b-a///b = normPath $ fp2fn $ fn2fp a ++ "/" ++ fn2fp b--isParentOrEqOf :: FileName -> FileName -> Bool-isParentOrEqOf fn1 fn2 = case stripPrefix (fn2fp fn1) (fn2fp fn2) of- Just ('/' : _) -> True- Just [] -> True- _ -> False--movedirfilename :: FileName -> FileName -> FileName -> FileName-movedirfilename old new name =- if name' == old'- then new- else case stripPrefix old' name' of- Just rest@('/':_) -> fp2fn $ "./" ++ new' ++ rest- _ -> name- where old' = fn2fp $ normPath old- new' = fn2fp $ normPath new- name' = fn2fp $ normPath name
src/Darcs/Patch/Format.hs view
@@ -1,32 +1,38 @@ module Darcs.Patch.Format- ( PatchListFormat(..), ListFormat(..)- , FileNameFormat(..) )- where--#include "gadts.h"+ ( PatchListFormat(..)+ , ListFormat(..)+ , copyListFormat+ , FileNameFormat(..)+ ) where --- | Showing and reading lists of patches This class allows us to control how+-- | Showing and reading lists of patches. This class allows us to control how -- lists of patches are formatted on disk. For legacy reasons V1 patches have -- their own special treatment (see 'ListFormat'). Other patch types use the -- default format which just puts them in a sequence without separators or any -- prelude/epilogue. ----- This means that 'FL (FL p)' etc would be ambiguous, so there are no instances--- for 'FL p' or other list types.+-- This means that 'FL (FL p)' etc would be ambiguous, so there are no+-- instances for 'FL p' or other list types. class PatchListFormat p where- patchListFormat :: ListFormat p- patchListFormat = ListFormatDefault+ patchListFormat :: ListFormat p+ patchListFormat = ListFormatDefault -- | This type is used to tweak the way that lists of 'p' are shown for a given--- 'Patch' type 'p'. It is needed to maintain backwards compatibility for V1 and--- V2 patches.-data ListFormat (p :: PATCHKIND)- = ListFormatDefault -- ^ Show and read lists without braces.- | ListFormatV1 -- ^ Show lists with a single layer of braces around the outside,- -- except for singletons which have no braces.- -- Read with arbitrary nested braces and parens and flatten them out.- | ListFormatV2 -- ^ Show lists without braces- -- Read with arbitrary nested parens and flatten them out.+-- 'Patch' type 'p'. It is needed to maintain backwards compatibility for V1+-- and V2 patches.+data ListFormat (p :: (* -> * -> *))+ = ListFormatDefault -- ^ Show and read lists without braces.+ | ListFormatV1 -- ^ Show lists with a single layer of braces around+ -- the outside, except for singletons which have no+ -- braces. Read with arbitrary nested braces and parens+ -- and flatten them out.+ | ListFormatV2 -- ^ Show lists without braces. Read with arbitrary+ -- nested parens and flatten them out.++copyListFormat :: ListFormat p -> ListFormat q+copyListFormat ListFormatDefault = ListFormatDefault+copyListFormat ListFormatV1 = ListFormatV1+copyListFormat ListFormatV2 = ListFormatV2 data FileNameFormat = OldFormat | NewFormat
+ src/Darcs/Patch/Index/Monad.hs view
@@ -0,0 +1,117 @@+-- Copyright (C) 2009 Benedikt Schmidt+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,++-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.+++{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Darcs.Patch.Index.Monad ( FileModMonad, withPatchMods ) where++import Darcs.Patch.Index.Types ( PatchMod(..) )+import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )+import Control.Applicative ( Applicative )+import Control.Monad.State+import Control.Arrow+import Darcs.Util.Path ( FileName, fn2fp, movedirfilename )+import qualified Data.Set as S+import Data.Set ( Set )+import Data.List ( isPrefixOf )+import Storage.Hashed.Tree (Tree)+#include "impossible.h"++newtype FileModMonad a = FMM (State (Set FileName, [PatchMod FileName]) a)+ deriving (Functor, Applicative, Monad, MonadState (Set FileName, [PatchMod FileName]))++withPatchMods :: FileModMonad a -> Set FileName -> (Set FileName, [PatchMod FileName])+withPatchMods (FMM m) fps = second reverse $ execState m (fps,[])++-- These instances are defined to be used only with+-- apply.+instance ApplyMonad FileModMonad Tree where+ type ApplyMonadBase FileModMonad = FileModMonad+ mDoesDirectoryExist d = do+ fps <- gets fst+ return $ S.member d fps+ mDoesFileExist f = do+ fps <- gets fst+ return $ S.member f fps+ mReadFilePS _ = bug "mReadFilePS FileModMonad"+ nestedApply _ _ = bug "nestedApply FileModMonad"+ liftApply _ _ = bug "liftApply FileModMonad"+ getApplyState = bug "getApplyState FileModMonad"+ putApplyState _ = bug "putApplyState FileModMonad"+ mCreateFile = createFile+ mCreateDirectory = createDir+ mRemoveFile = remove+ mRemoveDirectory = remove+ mRename a b = do+ fns <- gets fst+ if S.notMember a fns then+ addMod (PInvalid a) -- works around some old repo inconsistencies+ else+ do -- we have to account for directory moves+ addMod (PRename a b)+ modifyFps (S.delete a)+ addFile b+ forM_ (S.toList fns) $ \fn ->+ when (fn2fp a `isPrefixOf` fn2fp fn) $ do+ modifyFps (S.delete fn)+ let newfn = movedirfilename a b fn+ addFile newfn+ addMod (PRename fn newfn)++ mModifyFilePS f _ = addMod (PTouch f)+ mModifyFilePSs f _ = addMod (PTouch f)++-- ---------------------------------------------------------------------+-- State Handling Functions++addMod :: PatchMod FileName -> FileModMonad ()+addMod pm = modify $ second (pm :)++addFile :: FileName -> FileModMonad ()+addFile f = modifyFps (S.insert f)++createFile :: FileName -> FileModMonad ()+createFile fn = do+ errorIfPresent fn True+ addMod (PCreateFile fn)+ addFile fn++createDir :: FileName -> FileModMonad ()+createDir fn = do+ errorIfPresent fn False+ addMod (PCreateDir fn)+ addFile fn++errorIfPresent :: FileName -> Bool -> FileModMonad ()+errorIfPresent fn isFile = do+ fs <- gets fst+ when (S.member fn fs) $+ error $ unwords [ "error: patch index entry for"+ , if isFile then "file" else "directory"+ , fn2fp fn+ , "created >1 times"+ ]++remove :: FileName -> FileModMonad ()+remove f = addMod (PRemove f) >> modifyFps (S.delete f)++modifyFps :: (Set FileName -> Set FileName) -> FileModMonad ()+modifyFps f = modify $ first f
+ src/Darcs/Patch/Index/Types.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveFunctor #-}+-- Copyright (C) 2009-2010 Benedikt Schmidt+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Patch.Index.Types where++import Darcs.Util.Crypt.SHA1( SHA1(..) )+import Darcs.Util.Path ( fp2fn, fn2fp, FileName )+import Darcs.Patch.Info ( makePatchname, PatchInfo )+import Data.Binary ( Binary(..) )+import Data.Word ( Word32 )++-- | The FileId for a file consists of the FilePath (creation name)+-- and an index. The index denotes how many files+-- with the same name have been added before (and subsequently+-- deleted or moved)+data FileId = FileId {cname::FileName,count::Int}+ deriving (Eq,Show,Ord)++instance Binary FileId where+ put (FileId rfp i) = put (rfp,i)+ get = do+ (rfp,cnt) <- get+ return $ FileId rfp cnt++-- | Parse FileId from a string+parseFileId :: String -> FileId+parseFileId s = let (f,'.':i) = break (=='.') s in FileId (fp2fn f) (read i)++-- | Convert FileId to string+showFileId :: FileId -> String+showFileId (FileId fn i) = show i++"#"++fn2fp fn++-- | The PatchId identifies a patch and can be created from a PatchInfo with makePatchname+newtype PatchId = PID {patchId :: SHA1}+ deriving (Show,Ord,Eq)++instance Binary PatchId where+ put (PID p) = put p+ get = PID `fmap` get++pid2string :: PatchId -> String+pid2string = show . patchId++-- | describes a filepath that is interpreted relative to a certain+-- point in the history of the repository. The point is given by+-- Just pid which denotes the history up to (including) pid or+-- Nothing which denotes the history including the last patch+data DatedFilePath = DatedFilePath FilePath (Maybe PatchId)++-- | This is used to track changes to files+data PatchMod a = PTouch a+ | PCreateFile a+ | PCreateDir a+ | PRename a a+ | PRemove a+ | PInvalid a -- ^ This is an invalid patch+ -- e.g. there is a patch 'Move Autoconf.lhs Autoconf.lhs.in'+ -- where there is no Autoconf.lhs in the darcs repo+ | PDuplicateTouch a -- ^ this is used for duplicate patches that don't+ -- have any effect, but we still want to keep+ -- track of them+ deriving (Show, Eq, Functor)++makePatchID :: PatchInfo -> PatchId+makePatchID = PID . makePatchname++short :: PatchId -> Word32+short (PID (SHA1 a _ _ _ _)) = a+
src/Darcs/Patch/Info.hs view
@@ -16,20 +16,20 @@ -- Boston, MA 02110-1301, USA. module Darcs.Patch.Info ( PatchInfo(..), patchinfo, invertName,- idpatchinfo, addJunk, makePatchname,- makeFilename, makeAltFilename, readPatchInfo,- justName, justAuthor, justLog, repopatchinfo,- RepoPatchInfo, humanFriendly, toXml, piDate,+ rawPatchInfo,+ addJunk, makePatchname,+ makeFilename, readPatchInfo,+ justName, justAuthor, justLog,+ showPatchInfoUI, toXml, piDate, setPiDate, piDateString, piDateBytestring, piName, piRename, piAuthor, piTag, piLog, showPatchInfo, isTag, readPatchInfos, escapeXML ) where-import Text.Html hiding (name, text, option) import System.Random ( randomRIO ) import Numeric ( showHex )-import Control.Monad ( when, unless )+import Control.Monad ( when, unless, void ) -import ByteStringUtils ( unlinesPS, packStringToUTF8, unpackPSFromUTF8, decodeLocale)+import Darcs.Util.ByteString ( unlinesPS, packStringToUTF8, unpackPSFromUTF8, decodeLocale) import qualified Darcs.Patch.ReadMonads as RM ( take ) import Darcs.Patch.ReadMonads as RM ( skipSpace, char, takeTill, anyChar, ParserM,@@ -43,21 +43,17 @@ import qualified Data.ByteString.Char8 as BC (index, head, unpack, pack) import Data.List( isPrefixOf ) -import Printer ( renderString, Doc, packedString,- empty, ($$), (<>), (<+>), vcat, text, blueText, prefix )+import Darcs.Util.Printer ( Doc, packedString,+ empty, ($$), (<>), (<+>), vcat, text, cyanText, blueText, prefix ) import Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) import System.Time ( CalendarTime(ctTZ), calendarTimeToString, toClockTime, toCalendarTime ) import System.IO.Unsafe ( unsafePerformIO )-import SHA1 ( sha1PS )-import Darcs.Utils ( promptYorn )+import Darcs.Util.Crypt.SHA1 ( sha1PS, SHA1 )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.Show ( appPrec ) import Prelude hiding (pi, log) -data RepoPatchInfo = RPI String PatchInfo--repopatchinfo :: String -> PatchInfo -> RepoPatchInfo-repopatchinfo r pi = RPI r pi- -- | A PatchInfo value contains the metadata of a patch. The date, name, author -- and log fields are UTF-8 encoded text in darcs 2.4 and later, and just -- sequences of bytes (decoded with whatever is the locale when displayed) in@@ -73,17 +69,30 @@ } deriving (Eq,Ord) -idpatchinfo :: PatchInfo-idpatchinfo = PatchInfo myid myid myid [] False- where myid = BC.pack "identity"+instance Show PatchInfo where+ showsPrec d (PatchInfo date name author log inverted) =+ showParen (d > appPrec) $+ showString "rawPatchInfo " . showsPrec (appPrec + 1) date .+ showString " " . showsPrec (appPrec + 1) name .+ showString " " . showsPrec (appPrec + 1) author .+ showString " " . showsPrec (appPrec + 1) log .+ showString " " . showsPrec (appPrec + 1) inverted +rawPatchInfo :: String -> String -> String -> [String] -> Bool -> PatchInfo+rawPatchInfo date name author log inverted =+ PatchInfo { _piDate = BC.pack date+ , _piName = packStringToUTF8 name+ , _piAuthor = packStringToUTF8 author+ , _piLog = map packStringToUTF8 log+ , isInverted = inverted }++-- | @patchinfo date name author log@ constructs a new 'PatchInfo' value+-- with the given details, automatically assigning an Ignore-this header+-- to guarantee the patch is unique. The function does not verify+-- the date string's sanity. patchinfo :: String -> String -> String -> [String] -> IO PatchInfo patchinfo date name author log =- addJunk $ PatchInfo { _piDate = BC.pack date- , _piName = packStringToUTF8 name- , _piAuthor = packStringToUTF8 author- , _piLog = map packStringToUTF8 log- , isInverted = False }+ addJunk $ rawPatchInfo date name author log False -- | addJunk adds a line that contains a random number to make the patch -- unique.@@ -123,9 +132,11 @@ justLog :: PatchInfo -> String justLog = unlines . map BC.unpack . _piLog -humanFriendly :: PatchInfo -> Doc-humanFriendly pi =- text (friendlyD $ _piDate pi) <> text " " <> text (piAuthor pi)+showPatchInfoUI :: PatchInfo -> Doc+showPatchInfoUI pi =+ cyanText "patch " <> cyanText (show $ makePatchname pi)+ $$ text "Author: " <> text (piAuthor pi)+ $$ text "Date: " <> text (friendlyD $ _piDate pi) $$ hfn (piName pi) $$ vcat (map ((text " " <>) . text) (piLog pi)) where hfn x = case piTag pi of@@ -189,8 +200,8 @@ -- We try UTF-8 first because UTF-8 is clearly recognizable, widely used, -- and people may have UTF-8 patches even when UTF-8 is not their locale. metadataToString :: B.ByteString -> String-metadataToString bs | not ('\xfffd' `elem` bsUtf8) = bsUtf8- | otherwise = decodeLocale bs+metadataToString bs | '\xfffd' `notElem` bsUtf8 = bsUtf8+ | otherwise = decodeLocale bs where bsUtf8 = unpackPSFromUTF8 bs friendlyD :: B.ByteString -> String@@ -206,7 +217,7 @@ <+> text "date='" <> escapeXMLByteString (_piDate pi) <> text "'" <+> text "local_date='" <> escapeXML (friendlyD $ _piDate pi) <> text "'" <+> text "inverted='" <> text (show $ isInverted pi) <> text "'"- <+> text "hash='" <> text (makePatchname pi) <> text "'>"+ <+> text "hash='" <> text (show $ makePatchname pi) <> text "'>" $$ prefix "\t" ( text "<name>" <> escapeXMLByteString (_piName pi) <> text "</name>" $$ commentsAsXml (_piLog pi))@@ -238,8 +249,8 @@ strReplace :: Char -> String -> String -> String strReplace _ _ [] = [] strReplace x y (z:zs)- | x == z = y ++ (strReplace x y zs)- | otherwise = z : (strReplace x y zs)+ | x == z = y ++ strReplace x y zs+ | otherwise = z : strReplace x y zs bstrReplace :: Char -> String -> B.ByteString -> B.ByteString bstrReplace c s bs | B.null bs = B.empty@@ -249,12 +260,6 @@ else B.cons (B.head bs) (bstrReplace c s (B.tail bs)) -makeAltFilename :: PatchInfo -> String-makeAltFilename pi@(PatchInfo { isInverted = False }) =- fixUpFname (midtrunc (piName pi)++"-"++justAuthor pi++"-"++BC.unpack (_piDate pi))-makeAltFilename pi@(PatchInfo { isInverted = True}) =- makeAltFilename (pi { isInverted = False }) ++ "-inverted"- -- | This makes darcs-1 (non-hashed repos) filenames, and is also generally -- used in both in hashed and non-hashed repo code for making patch "hashes". --@@ -267,11 +272,15 @@ -- * SHA1 hash of the patch name, author, date, log, and \"inverted\" -- flag. makeFilename :: PatchInfo -> String-makeFilename pi = makePatchname pi ++ ".gz"+makeFilename pi = showIsoDateTime d++"-"++sha1_a++"-"++ (show $ makePatchname pi) ++ ".gz"+ where d = readPatchDate $ _piDate pi+ sha1_a = take 5 $ show $ sha1PS $ _piAuthor pi -makePatchname :: PatchInfo -> String-makePatchname pi =- showIsoDateTime d++"-"++sha1_a++"-"++sha1PS sha1_me+-- | Hash on patch metadata (patch name, author, date, log, and \"inverted\"+-- flag. Robust against context changes but does not garantee patch contents.+-- Usually used as matcher or patch identifier (see Darcs.Patch.Match).+makePatchname :: PatchInfo -> SHA1+makePatchname pi = sha1PS sha1_me where b2ps True = BC.pack "t" b2ps False = BC.pack "f" sha1_me = B.concat [_piName pi,@@ -279,49 +288,8 @@ _piDate pi, B.concat $ _piLog pi, b2ps $ isInverted pi]- d = readPatchDate $ _piDate pi- sha1_a = take 5 $ sha1PS $ _piAuthor pi -midtrunc :: String -> String-midtrunc s- | length s < 73 = s- | otherwise = (take 40 s)++"..."++(reverse $ take 30 $ reverse s)-fixUpFname :: String -> String-fixUpFname = map mungeChar -mungeChar :: Char -> Char-mungeChar '*' = '+'-mungeChar '?' = '2'-mungeChar '>' = '7'-mungeChar '<' = '2'-mungeChar ' ' = '_'-mungeChar '"' = '~'-mungeChar '`' = '.'-mungeChar '\'' = '.'-mungeChar '/' = '1'-mungeChar '\\' = '1'-mungeChar '!' = '1'-mungeChar ':' = '.'-mungeChar ';' = ','-mungeChar '{' = '~'-mungeChar '}' = '~'-mungeChar '(' = '~'-mungeChar ')' = '~'-mungeChar '[' = '~'-mungeChar ']' = '~'-mungeChar '=' = '+'-mungeChar '#' = '+'-mungeChar '%' = '8'-mungeChar '&' = '6'-mungeChar '@' = '9'-mungeChar '|' = '1'-mungeChar c = c--instance HTML RepoPatchInfo where- toHtml = htmlPatchInfo-instance Show PatchInfo where- show pi = renderString (showPatchInfo pi)- -- |Patch is stored between square brackets. -- -- > [ <patch name>@@ -341,9 +309,8 @@ <> myunlines (_piLog pi) <> blueText "] " where inverted = if isInverted pi then "*-" else "**" myunlines [] = empty- myunlines xs = mul xs- where mul [] = text "\n"- mul (s:ss) = text "\n " <> packedString s <> mul ss+ myunlines xs =+ foldr (\s -> ((text "\n " <> packedString s) <>)) (text "\n") xs -- |Parser for 'PatchInfo' as stored in patch bundles and inventory files, -- for example:@@ -355,7 +322,7 @@ -- > ] -- -- See 'showPatchInfo' for the inverse operation.-readPatchInfo :: ParserM m => m (PatchInfo)+readPatchInfo :: ParserM m => m PatchInfo readPatchInfo = do skipSpace char '['@@ -364,14 +331,14 @@ author <- takeTillChar '*' s2 <- RM.take 2 ct <- takeTill (\c->c==']'||c=='\n')- option () (char '\n' >> return ()) -- consume newline char, if present+ option () (void (char '\n')) -- consume newline char, if present log <- linesStartingWithEndingWith ' ' ']'- return $ PatchInfo { _piDate = ct- , _piName = name- , _piAuthor = author- , _piLog = log- , isInverted = BC.index s2 1 /= '*'- }+ return PatchInfo { _piDate = ct+ , _piName = name+ , _piAuthor = author+ , _piLog = log+ , isInverted = BC.index s2 1 /= '*'+ } readPatchInfos :: B.ByteString -> [PatchInfo] readPatchInfos inv | B.null inv = []@@ -379,16 +346,3 @@ Just (pinfo,r) -> pinfo : readPatchInfos r _ -> [] -htmlPatchInfo :: RepoPatchInfo -> Html-htmlPatchInfo (RPI r pi) =- toHtml $ (td << patchLink r pi) `above`- ((td ! [align "right"] << mailLink (justAuthor pi)) `beside`- (td << (friendlyD $ _piDate pi)))--patchLink :: String -> PatchInfo -> Html-patchLink r pi =- toHtml $ hotlink- ("darcs?"++r++"**"++makeFilename pi)- [toHtml $ piName pi]-mailLink :: String -> Html-mailLink email = toHtml $ hotlink ("mailto:"++email) [toHtml email]
src/Darcs/Patch/Inspect.hs view
@@ -3,16 +3,15 @@ ) where -import Darcs.Witnesses.Ordered ( FL, RL, reverseRL, mapFL )+import Darcs.Patch.Witnesses.Ordered ( FL, RL, reverseRL, mapFL ) import qualified Data.ByteString.Char8 as BC import Data.List ( nub ) -#include "gadts.h" class PatchInspect p where- listTouchedFiles :: p C(x y) -> [FilePath]- hunkMatches :: (BC.ByteString -> Bool) -> p C(x y) -> Bool+ listTouchedFiles :: p wX wY -> [FilePath]+ hunkMatches :: (BC.ByteString -> Bool) -> p wX wY -> Bool instance PatchInspect p => PatchInspect (FL p) where listTouchedFiles xs = nub $ concat $ mapFL listTouchedFiles xs
src/Darcs/Patch/Invert.hs view
@@ -3,17 +3,22 @@ ) where -import Darcs.Witnesses.Ordered ( FL(..), RL(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), reverseFL, reverseRL ) -#include "gadts.h" class Invert p where- invert :: p C(x y) -> p C(y x)+ invert :: p wX wY -> p wY wX -invertFL :: Invert p => FL p C(x y) -> RL p C(y x)+invertFL :: Invert p => FL p wX wY -> RL p wY wX invertFL NilFL = NilRL invertFL (x:>:xs) = invert x :<: invertFL xs -invertRL :: Invert p => RL p C(x y) -> FL p C(y x)+invertRL :: Invert p => RL p wX wY -> FL p wY wX invertRL NilRL = NilFL invertRL (x:<:xs) = invert x :>: invertRL xs++instance Invert p => Invert (FL p) where+ invert = reverseRL . invertFL++instance Invert p => Invert (RL p) where+ invert = reverseFL . invertRL
src/Darcs/Patch/Match.hs view
@@ -1,4 +1,4 @@--- Copyright (C) 2004 David Roundy+-- Copyright (C) 2004-2005 David Roundy -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by@@ -15,34 +15,131 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -#include "gadts.h"+{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, Rank2Types #-} -module Darcs.Patch.Match ( PatchMatch, Matcher, MatchFun,- patchMatch, matchPattern,- applyMatcher, makeMatcher,- parseMatch,- matchParser, helpOnMatchers,- ) where+-- | /First matcher, Second matcher and Nonrange matcher/+--+-- When we match for patches, we have a PatchSet, of which we want a+-- subset. This subset is formed by the patches in a given interval+-- which match a given criterion. If we represent time going left to+-- right, then we have (up to) three 'Matcher's:+--+-- * the 'firstMatcher' is the left bound of the interval,+--+-- * the 'secondMatcher' is the right bound, and+--+-- * the 'nonrangeMatcher' is the criterion we use to select among+-- patches in the interval.+---+-- Each of these matchers can be present or not according to the+-- options. The patches we want would then be the ones that all+-- present matchers have in common.+--+-- (Implementation note: keep in mind that the PatchSet is written+-- backwards with respect to the timeline, ie., from right to left)+module Darcs.Patch.Match+ (+ matchParser+ , helpOnMatchers+ , addInternalMatcher+ , matchFirstPatchset+ , matchSecondPatchset+ , splitSecondFL+ , matchPatch+ , matchAPatch+ , matchAPatchread+ , getNonrangeMatchS+ , firstMatch+ , secondMatch+ , haveNonrangeMatch+ , havePatchsetMatch+ , checkMatchSyntax+ , applyInvToMatcher+ , nonrangeMatcher+ , InclusiveOrExclusive(..)+ , matchExists+ , applyNInv+ , hasIndexRange+ , getMatchingTag+ , matchAPatchset+ , getFirstMatchS+ , nonrangeMatcherIsTag+ , MatchFlag(..)+ ) where import Text.ParserCombinators.Parsec+ ( parse+ , CharParser+ , (<?>)+ , (<|>)+ , noneOf+ , option+ , eof+ , many+ , try+ , between+ , spaces+ , char+ , oneOf+ , string+ , choice+ ) import Text.ParserCombinators.Parsec.Expr+ ( OperatorTable+ , Assoc( AssocLeft )+ , Operator ( Infix, Prefix )+ , buildExpressionParser+ ) import Text.Regex ( mkRegex, matchRegex ) import Data.Maybe ( isJust )-import Data.List ( isPrefixOf ) import System.IO.Unsafe ( unsafePerformIO )+import Control.Monad ( when )+import Data.List ( isPrefixOf, intercalate )+import Data.Char ( toLower ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )-import Darcs.Patch ( Patchy, hunkMatches, listTouchedFiles, patchcontents )-import Darcs.Patch.Info ( justName, justAuthor, justLog, makeFilename,+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Patch+ ( Patchy+ , hunkMatches+ , listTouchedFiles+ , patchcontents+ , Named+ , invert+ , invertRL+ , patch2patchinfo+ , apply+ )+import Darcs.Patch.Info ( justName, justAuthor, justLog, makePatchname, piDate )-import Darcs.Witnesses.Sealed ( Sealed2(..), seal2 )-import DateMatcher ( parseDateMatcher ) -import Darcs.Patch.MatchData ( PatchMatch(..), patchMatch ) import qualified Data.ByteString.Char8 as BC import Darcs.Patch.Dummy ( DummyPatch ) +import Darcs.Patch.Matchable ( Matchable )+import Darcs.Patch.MaybeInternal ( MaybeInternal, patchInternalChecker, isInternal, flIsInternal )+import Darcs.Patch.MonadProgress ( MonadProgress )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, piap,+ conscientiously, hopefully, n2pia )+import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL, Origin )+import Darcs.Patch.Type ( PatchType(..) )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.ApplyPatches( applyPatches )+import Darcs.Patch.Depends ( getPatchesBeyondTag, splitOnTag )++import Darcs.Patch.Witnesses.Eq ( isIsEq )+import Darcs.Patch.Witnesses.Ordered ( RL(..), consRLSealed, FL(..), (:>)(..) )+import Darcs.Patch.Witnesses.Sealed+ ( FlippedSeal(..), Sealed2(..),+ seal, flipSeal, seal2, unsealFlipped, unseal2, unseal )+import Darcs.Util.Printer ( text, ($$) )+import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )++import Darcs.Util.DateMatcher ( parseDateMatcher )++import Storage.Hashed.Tree ( Tree )+#include "impossible.h"+ -- | A type for predicates over patches which do not care about -- contexts type MatchFun p = Sealed2 (PatchInfoAnd p) -> Bool@@ -54,37 +151,84 @@ instance Show (Matcher p) where show (MATCH s _) = '"':s ++ "\"" ++data MatchFlag =+ OnePattern String+ | SeveralPattern String+ | AfterPattern String+ | UpToPattern String+ | OnePatch String+ | OneHash String+ | AfterHash String+ | UpToHash String+ | SeveralPatch String+ | AfterPatch String+ | UpToPatch String+ | OneTag String+ | AfterTag String+ | UpToTag String+ | LastN Int+ | PatchIndexRange Int Int+ | Context AbsolutePath+ deriving ( Show )++ makeMatcher :: String -> (Sealed2 (PatchInfoAnd p) -> Bool) -> Matcher p-makeMatcher s m = MATCH s m+makeMatcher = MATCH -- | @applyMatcher@ applies a matcher to a patch.-applyMatcher :: Matcher p -> PatchInfoAnd p C(x y) -> Bool+applyMatcher :: Matcher p -> PatchInfoAnd p wX wY -> Bool applyMatcher (MATCH _ m) = m . seal2 -parseMatch :: Patchy p => PatchMatch -> Either String (MatchFun p)-parseMatch (PatternMatch s) =- case parse matchParser "match" s of- Left err -> Left $ "Invalid -"++"-match pattern '"++s+++parseMatch :: Matchable p => String -> Either String (MatchFun p)+parseMatch pattern =+ case parse matchParser "match" pattern of+ Left err -> Left $ "Invalid --match pattern '"++ pattern ++ "'.\n"++ unlines (map (" "++) $ lines $ show err) -- indent Right m -> Right m -matchPattern :: Patchy p => PatchMatch -> Matcher p-matchPattern p@(PatternMatch s) =- case parseMatch p of+matchPattern :: Matchable p => String -> Matcher p+matchPattern pattern =+ case parseMatch pattern of Left err -> error err- Right m -> makeMatcher s m+ Right m -> makeMatcher pattern m -trivial :: Patchy p => MatchFun p-trivial = const True+addInternalMatcher :: Matchable p => Maybe (Matcher p) -> Maybe (Matcher p)+addInternalMatcher om =+ case patchInternalChecker of+ Nothing -> om+ Just f ->+ let matchFun = unseal2 (not . isIsEq . isInternal f . patchcontents . hopefully)+ in case om of+ Nothing -> Just (MATCH "internal patch" matchFun)+ Just (MATCH s oldFun) -> Just (MATCH s (\p -> matchFun p && oldFun p)) -matchParser :: Patchy p => CharParser st (MatchFun p)-matchParser = do m <- option trivial submatch- eof- return m+matchParser :: Matchable p => CharParser st (MatchFun p)+matchParser = submatcher <?> helpfulErrorMsg+ where+ submatcher = do+ m <- option matchAnyPatch submatch+ eof+ return m -submatch :: Patchy p => CharParser st (MatchFun p)-submatch = buildExpressionParser table match <?> "match rule"+ -- When using <?>, Parsec prepends "expecting " to the given error message,+ -- so the phrasing below makes sense.+ helpfulErrorMsg = "valid expressions over: "+ ++ intercalate ", " (map (\(name, _, _, _) -> name) ps)+ ++ "\nfor more help, see `darcs help patterns`." + -- This type signature is just to bind an ambiguous type var.+ ps :: [(String, String, [String], String -> MatchFun DummyPatch)]+ ps = primitiveMatchers++ -- matchAnyPatch is returned if submatch fails without consuming any+ -- input, i.e. if we pass --match '', we want to match anything.+ matchAnyPatch :: Matchable p => MatchFun p+ matchAnyPatch = const True++submatch :: Matchable p => CharParser st (MatchFun p)+submatch = buildExpressionParser table match+ table :: OperatorTable Char st (MatchFun p) table = [ [prefix "not" negate_match, prefix "!" negate_match ]@@ -93,27 +237,22 @@ binary "&&" and_match, binary "and" and_match ] ]- where binary name fun =- Infix (do _ <- trystring name- spaces- return fun) AssocLeft- prefix name fun = Prefix $ do _ <- trystring name+ where binary name fun = Infix (tryNameAndUseFun name fun) AssocLeft+ prefix name fun = Prefix $ tryNameAndUseFun name fun+ tryNameAndUseFun name fun = do _ <- trystring name spaces return fun negate_match a p = not (a p)- or_match m1 m2 p = (m1 p) || (m2 p)- and_match m1 m2 p = (m1 p) && (m2 p)+ or_match m1 m2 p = m1 p || m2 p+ and_match m1 m2 p = m1 p && m2 p trystring :: String -> CharParser st String trystring s = try $ string s -match :: Patchy p => CharParser st (MatchFun p)-match = between spaces spaces- (parens submatch- <|> choice matchers_- <?> "simple match")- where matchers_ = map createMatchHelper primitiveMatchers-+match :: Matchable p => CharParser st (MatchFun p)+match = between spaces spaces (parens submatch <|> choice matchers_)+ where+ matchers_ = map createMatchHelper primitiveMatchers createMatchHelper :: (String, String, [String], String -> MatchFun p) -> CharParser st (MatchFun p)@@ -125,25 +264,27 @@ -- FIXME: would this be better defined in Darcs.Commands.Help? -- | The string that is emitted when the user runs @darcs help --match@.-helpOnMatchers :: String-helpOnMatchers = unlines $+helpOnMatchers :: [String]+helpOnMatchers = ["Selecting Patches:", "",- "The --patches option yields patches with names matching an `extended'",+ "The --patches option yields patches with names matching an *extended*", "regular expression. See regex(7) for details. The --matches option", "yields patches that match a logical (Boolean) expression: one or more", "primitive expressions combined by grouping (parentheses) and the", "complement (not), conjunction (and) and disjunction (or) operators.", "The C notation for logic operators (!, && and ||) can also be used.", "",- " --patches=regex is a synonym for --matches='name regex'",- " --from-patch and --to-patch are synonyms for --from-match='name... and --to-match='name...",- " --from-patch and --to-match can be unproblematically combined:",- " darcs changes --from-patch='html.*documentation' --to-match='date 20040212'",+ "- --patches=regex is a synonym for --matches='name regex'",+ "- --hash=HASH is a synonym for --matches='hash HASH'",+ "- --from-patch and --to-patch are synonyms for --from-match='name... and --to-match='name...",+ "- --from-patch and --to-match can be unproblematically combined:",+ " `darcs changes --from-patch='html.*documentation' --to-match='date 20040212'`", "",- "The following primitive Boolean expressions are supported:"]+ "The following primitive Boolean expressions are supported:"+ ,""] ++ keywords- ++ ["", "Here are some examples:"]+ ++ ["", "Here are some examples:", ""] ++ examples where -- This type signature exists to appease GHC. ps :: [(String, String, [String], String -> MatchFun DummyPatch)]@@ -154,15 +295,15 @@ -- FIXME: it would be nice to have a variable name here: -- "author REGEX - match against author (email address)" -- or "exact STRING - match against exact patch name".- " " ++ keyword ++ " - " ++ description ++ "."+ "- " ++ keyword ++ " - " ++ description ++ "." showExample keyword example = -- FIXME: this string is long, and its not a use case I've -- ever seen in practice. Can we use something else, -- like "darcs changes --matches"? --twb, 2008-12-28- " darcs annotate --summary --match "+ " darcs annotate --summary --match " ++ "'" ++ keyword ++ " " ++ example ++ "'" -primitiveMatchers :: Patchy p => [(String, String, [String], String -> MatchFun p)]+primitiveMatchers :: Matchable p => [(String, String, [String], String -> MatchFun p)] -- ^ keyword (operator), help description, list -- of examples, matcher function primitiveMatchers =@@ -171,7 +312,7 @@ , exactmatch ) , ("name", "check a regular expression against the patch name" , ["issue17", "\"^[Rr]esolve issue17\\>\""]- , mymatch )+ , namematch ) , ("author", "check a regular expression against the author name" , ["\"David Roundy\"", "droundy", "droundy@darcs.net"] , authormatch )@@ -181,10 +322,8 @@ , ("comment", "check a regular expression against the log message" , ["\"prevent deadlocks\""] , logmatch )- , ("hash", "match the darcs hash for a patch"- , ["20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef"- ,"c719567e92c3b0ab9eddd5290b705712b8b918ef"- ,"c719567e"]+ , ("hash", "match a full hash or a prefix for a patch"+ , ["c719567e92c3b0ab9eddd5290b705712b8b918ef","c7195"] , hashmatch ) , ("date", "match the patch date" , ["\"2006-04-02 22:41\"", "\"tea time yesterday\""]@@ -195,39 +334,405 @@ parens :: CharParser st (MatchFun p) -> CharParser st (MatchFun p)-parens p = between (string "(") (string ")") p+parens = between (string "(") (string ")") quoted :: CharParser st String quoted = between (char '"') (char '"') (many $ do { _ <- char '\\' -- allow escapes- ; try (oneOf ['\\', '"']) <|> return '\\'+ ; try (oneOf "\\\"") <|> return '\\' }- <|> noneOf ['"'])+ <|> noneOf "\"") <|> between spaces spaces (many $ noneOf " ()") <?> "string" -mymatch, exactmatch, authormatch, hunkmatch, hashmatch, datematch, touchmatch :: Patchy p => String -> MatchFun p+namematch, exactmatch, authormatch, hunkmatch, hashmatch, datematch, touchmatch+ :: Matchable p => String -> MatchFun p -mymatch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ justName (info hp)+namematch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ justName (info hp) -exactmatch r (Sealed2 hp) = r == (justName (info hp))+exactmatch r (Sealed2 hp) = r == justName (info hp) authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ justAuthor (info hp) -logmatch :: Patchy p => String -> MatchFun p+logmatch :: Matchable p => String -> MatchFun p logmatch l (Sealed2 hp) = isJust $ matchRegex (mkRegex l) $ justLog (info hp) hunkmatch r (Sealed2 hp) = let patch = patchcontents $ hopefully hp- regexMatcher = isJust . (matchRegex (mkRegex r) . BC.unpack)+ regexMatcher = isJust . matchRegex (mkRegex r) . BC.unpack in hunkMatches regexMatcher patch -hashmatch h (Sealed2 hp) = let rh = makeFilename (info hp) in- (rh == h) || (rh == h++".gz")- || (h `isPrefixOf` drop 21 rh)- -- enable matching on (prefix of) third part, like in darcs 2.10+hashmatch h (Sealed2 hp) = let rh = show $ makePatchname (info hp)+ lh = map toLower h+ in (lh `isPrefixOf` rh) || (lh == rh ++ ".gz") datematch d (Sealed2 hp) = let dm = unsafePerformIO $ parseDateMatcher d in dm $ piDate (info hp) touchmatch r (Sealed2 hp) = let files = listTouchedFiles $ patchcontents $ hopefully hp- in or $ map (isJust . matchRegex (mkRegex r)) files+ in any (isJust . matchRegex (mkRegex r)) files++data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq++-- | @haveNonrangeMatch flags@ tells whether there is a flag in+-- @flags@ which corresponds to a match that is "non-range". Thus,+-- @--match@, @--patch@, @--hash@ and @--index@ make @haveNonrangeMatch@+-- true, but not @--from-patch@ or @--to-patch@.+haveNonrangeMatch :: forall p . Matchable p => PatchType p -> [MatchFlag] -> Bool+haveNonrangeMatch _ fs =+ isJust (hasIndexRange fs)+ || isJust (nonrangeMatcher fs::Maybe (Matcher p))++-- | @havePatchsetMatch flags@ tells whether there is a "patchset+-- match" in the flag list. A patchset match is @--match@ or+-- @--patch@, or @--context@, but not @--from-patch@ nor (!)+-- @--index@.+-- Question: Is it supposed not to be a subset of @haveNonrangeMatch@?+havePatchsetMatch :: [MatchFlag] -> Bool+havePatchsetMatch fs = isJust (nonrangeMatcher fs::Maybe (Matcher DummyPatch)) || hasC fs+ where hasC [] = False+ hasC (Context _:_) = True+ hasC (_:xs) = hasC xs++getNonrangeMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, Matchable p, ApplyState p ~ Tree)+ => [MatchFlag]+ -> PatchSet p Origin wX+ -> m ()+getNonrangeMatchS fs repo =+ case nonrangeMatcher fs of+ Just m -> if nonrangeMatcherIsTag fs+ then getTagS m repo+ else getMatcherS Exclusive m repo+ Nothing -> fail "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+-- than against all patches since the creation of the repository.+firstMatch :: [MatchFlag] -> Bool+firstMatch fs = isJust (hasLastn fs)+ || isJust (firstMatcher fs::Maybe (Matcher DummyPatch))+ || isJust (hasIndexRange fs)++getFirstMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, Matchable p)+ => [MatchFlag] -> PatchSet p Origin wX -> m ()+getFirstMatchS fs repo =+ case hasLastn fs of+ Just n -> unpullLastN repo n+ Nothing ->+ case hasIndexRange fs of+ Just (_,b) -> unpullLastN repo b -- b is chronologically earlier than a+ Nothing ->+ case firstMatcher fs of+ Nothing -> fail "Pattern not specified in getFirstMatchS."+ Just m -> if firstMatcherIsTag fs+ then getTagS m repo+ else getMatcherS Inclusive m repo++-- | @secondMatch fs@ tells whether @fs@ implies a "second match", that+-- is if we match against patches up to a point in the past on, rather+-- than against all patches until now.+secondMatch :: [MatchFlag] -> Bool+secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher DummyPatch)) || isJust (hasIndexRange fs)++unpullLastN :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p, MaybeInternal p)+ => PatchSet p wX wY+ -> Int+ -> m ()+unpullLastN repo n = applyInvRL `unsealFlipped` safetake n (newset2RL repo)++checkMatchSyntax :: [MatchFlag] -> IO ()+checkMatchSyntax opts =+ case getMatchPattern opts of+ Nothing -> return ()+ Just p -> either fail (const $ return ()) (parseMatch p::Either String (MatchFun DummyPatch))++getMatchPattern :: [MatchFlag] -> Maybe String+getMatchPattern [] = Nothing+getMatchPattern (OnePattern m:_) = Just m+getMatchPattern (SeveralPattern m:_) = Just m+getMatchPattern (_:fs) = getMatchPattern fs++tagmatch :: Matchable p => String -> Matcher p+tagmatch r = makeMatcher ("tag-name "++r) tm+ where tm (Sealed2 p) =+ let n = justName (info p) in+ "TAG " `isPrefixOf` n && isJust (matchRegex (mkRegex r) $ drop 4 n)++patchmatch :: Matchable p => String -> Matcher p+patchmatch r = makeMatcher ("patch-name "++r) (namematch r)++hashmatch' :: Matchable p => String -> Matcher p+hashmatch' r = makeMatcher ("hash "++r) (hashmatch r)+++-- | strictJust is a strict version of the Just constructor, used to ensure+-- that if we claim we've got a pattern match, that the pattern will+-- actually match (rathern than fail to compile properly).+strictJust :: a -> Maybe a+strictJust x = Just $! x++-- | @nonrangeMatcher@ is the criterion that is used to match against+-- patches in the interval. It is 'Just m' when the @--patch@, @--match@,+-- @--tag@ options are passed (or their plural variants).+nonrangeMatcher, nonrangeMatcherArgs :: Matchable p => [MatchFlag] -> Maybe (Matcher p)++nonrangeMatcher fs = addInternalMatcher $ nonrangeMatcherArgs fs++nonrangeMatcherArgs [] = Nothing+nonrangeMatcherArgs (OnePattern m:_) = strictJust $ matchPattern m+nonrangeMatcherArgs (OneTag t:_) = strictJust $ tagmatch t+nonrangeMatcherArgs (OnePatch p:_) = strictJust $ patchmatch p+nonrangeMatcherArgs (OneHash h:_) = strictJust $ hashmatch' h+nonrangeMatcherArgs (SeveralPattern m:_) = strictJust $ matchPattern m+nonrangeMatcherArgs (SeveralPatch p:_) = strictJust $ patchmatch p+nonrangeMatcherArgs (_:fs) = nonrangeMatcherArgs fs++-- | @nonrangeMatcherIsTag@ returns true if the matching option was+-- '--tag'+nonrangeMatcherIsTag :: [MatchFlag] -> Bool+nonrangeMatcherIsTag [] = False+nonrangeMatcherIsTag (OneTag _:_) = True+nonrangeMatcherIsTag (_:fs) = nonrangeMatcherIsTag fs++-- | @firstMatcher@ returns the left bound of the matched interval.+-- This left bound is also specified when we use the singular versions+-- of @--patch@, @--match@ and @--tag@. Otherwise, @firstMatcher@+-- returns @Nothing@.+firstMatcher :: Matchable p => [MatchFlag] -> Maybe (Matcher p)+firstMatcher [] = Nothing+firstMatcher (OnePattern m:_) = strictJust $ matchPattern m+firstMatcher (AfterPattern m:_) = strictJust $ matchPattern m+firstMatcher (AfterTag t:_) = strictJust $ tagmatch t+firstMatcher (OnePatch p:_) = strictJust $ patchmatch p+firstMatcher (AfterPatch p:_) = strictJust $ patchmatch p+firstMatcher (OneHash h:_) = strictJust $ hashmatch' h+firstMatcher (AfterHash h:_) = strictJust $ hashmatch' h+firstMatcher (_:fs) = firstMatcher fs++firstMatcherIsTag :: [MatchFlag] -> Bool+firstMatcherIsTag [] = False+firstMatcherIsTag (AfterTag _:_) = True+firstMatcherIsTag (_:fs) = firstMatcherIsTag fs++secondMatcher :: Matchable p => [MatchFlag] -> Maybe (Matcher p)+secondMatcher [] = Nothing+secondMatcher (OnePattern m:_) = strictJust $ matchPattern m+secondMatcher (UpToPattern m:_) = strictJust $ matchPattern m+secondMatcher (OnePatch p:_) = strictJust $ patchmatch p+secondMatcher (UpToPatch p:_) = strictJust $ patchmatch p+secondMatcher (OneHash h:_) = strictJust $ hashmatch' h+secondMatcher (UpToHash h:_) = strictJust $ hashmatch' h+secondMatcher (UpToTag t:_) = strictJust $ tagmatch t+secondMatcher (_:fs) = secondMatcher fs++secondMatcherIsTag :: [MatchFlag] -> Bool+secondMatcherIsTag [] = False+secondMatcherIsTag (UpToTag _:_) = True+secondMatcherIsTag (_:fs) = secondMatcherIsTag fs++-- | @matchAPatchread fs p@ tells whether @p@ matches the matchers in+-- the flags listed in @fs@.+matchAPatchread :: Matchable p => [MatchFlag] -> PatchInfoAnd p wX wY -> Bool+matchAPatchread fs = case nonrangeMatcher fs of+ Nothing -> const True+ Just m -> applyMatcher m++-- | @matchAPatch fs p@ tells whether @p@ matches the matchers in+-- the flags @fs@+matchAPatch :: Matchable p => [MatchFlag] -> Named p wX wY -> Bool+matchAPatch fs p =+ case nonrangeMatcher fs of+ Nothing -> True+ Just m -> applyMatcher m (patch2patchinfo p `piap` p)++matchPatch :: Matchable p => [MatchFlag] -> PatchSet p wStart wX -> Sealed2 (Named p)+matchPatch fs ps =+ case hasIndexRange fs of+ Just (a,a') | a == a' -> case unseal myhead $ dropn (a-1) ps of+ Just (Sealed2 p) -> seal2 $ hopefully p+ Nothing -> error "Patch out of range!"+ | otherwise -> bug ("Invalid index range match given to matchPatch: "+++ show (PatchIndexRange a a'))+ where myhead :: PatchSet p wStart wX -> Maybe (Sealed2 (PatchInfoAnd p))+ myhead (PatchSet NilRL (Tagged t _ _ :<: _)) = Just $ seal2 t+ myhead (PatchSet (x:<:_) _) = Just $ seal2 x+ myhead _ = Nothing+ Nothing -> case nonrangeMatcher fs of+ Nothing -> bug "Couldn't matchPatch"+ Just m -> findAPatch m ps++-- | @hasLastn fs@ return the @--last@ argument in @fs@, if any.+hasLastn :: [MatchFlag] -> Maybe Int+hasLastn [] = Nothing+hasLastn (LastN (-1):_) = error "--last requires a positive integer argument."+hasLastn (LastN n:_) = Just n+hasLastn (_:fs) = hasLastn fs++hasIndexRange :: [MatchFlag] -> Maybe (Int,Int)+hasIndexRange [] = Nothing+hasIndexRange (PatchIndexRange x y:_) = Just (x,y)+hasIndexRange (_:fs) = hasIndexRange fs++-- | @matchFirstPatchset fs ps@ returns the part of @ps@ before its+-- first matcher, ie the one that comes first dependencywise. Hence,+-- patches in @matchFirstPatchset fs ps@ are the context for the ones+-- we don't want.+matchFirstPatchset :: Matchable p => [MatchFlag] -> PatchSet p wStart wX+ -> SealedPatchSet p wStart+matchFirstPatchset fs patchset =+ case hasLastn fs of+ Just n -> dropn n patchset+ Nothing ->+ case hasIndexRange fs of+ Just (_,b) -> dropn b patchset+ Nothing ->+ case firstMatcher fs of+ Nothing -> bug "Couldn't matchFirstPatchset"+ Just m -> unseal (dropn 1) $ if firstMatcherIsTag fs+ then getMatchingTag m patchset+ else matchAPatchset m patchset++-- | @dropn n ps@ drops the @n@ last patches from @ps@.+dropn :: MaybeInternal p => Int -> PatchSet p wStart wX -> SealedPatchSet p wStart+dropn n ps | n <= 0 = seal ps+dropn n (PatchSet NilRL (Tagged t _ ps :<: ts)) = dropn n $ PatchSet (t:<:ps) ts+dropn _ (PatchSet NilRL NilRL) = seal $ PatchSet NilRL NilRL+dropn n (PatchSet (p:<:ps) ts)+ | isIsEq (flIsInternal (patchcontents (hopefully p)))+ = dropn n $ PatchSet ps ts+dropn n (PatchSet (_:<:ps) ts) = dropn (n-1) $ PatchSet ps ts++-- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its+-- second matcher, ie the one that comes last dependencywise.+matchSecondPatchset :: Matchable p => [MatchFlag] -> PatchSet p wStart wX+ -> SealedPatchSet p wStart+matchSecondPatchset fs ps =+ case hasIndexRange fs of+ Just (a,_) -> dropn (a-1) ps+ Nothing ->+ case secondMatcher fs of+ Nothing -> bug "Couldn't matchSecondPatchset"+ Just m -> if secondMatcherIsTag fs+ then getMatchingTag m ps+ else matchAPatchset m ps++-- | Split on the second matcher. Note that this picks up the first match starting from+-- the earliest patch in a sequence, as opposed to 'matchSecondPatchset' which picks up the+-- first match starting from the latest patch+splitSecondFL :: Matchable p+ => (forall wA wB . q wA wB -> Sealed2 (Named p))+ -> [MatchFlag]+ -> FL q wX wY+ -> (FL q :> FL q) wX wY -- ^The first element is the patches before and including the first patch matching the second matcher,+ -- the second element is the patches after it+splitSecondFL extract fs ps =+ case hasIndexRange fs of+ Just _ -> -- selecting the last n doesn't really make sense if we're starting from the earliest patches+ bug "index matches not supported by splitSecondPatchesFL"+ Nothing ->+ case secondMatcher fs of+ Nothing -> bug "Couldn't splitSecondPatches"+ Just m -> splitMatchFL extract m ps++-- | @findAPatch m ps@ returns the last patch in @ps@ matching @m@, and+-- calls 'error' if there is none.+findAPatch :: Matchable p => Matcher p -> PatchSet p wStart wX -> Sealed2 (Named p)+findAPatch m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m+findAPatch m (PatchSet NilRL (Tagged t _ ps :<: ts)) = findAPatch m (PatchSet (t:<:ps) ts)+findAPatch m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal2 $ hopefully p+ | otherwise = findAPatch m (PatchSet ps ts)++-- | @matchAPatchset m ps@ returns a (the largest?) subset of @ps@+-- ending in patch which matches @m@. Calls 'error' if there is none.+matchAPatchset :: Matchable p => Matcher p -> PatchSet p wStart wX+ -> SealedPatchSet p wStart+matchAPatchset m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m+matchAPatchset m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchAPatchset m (PatchSet (t:<:ps) ts)+matchAPatchset m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal (PatchSet (p:<:ps) ts)+ | otherwise = matchAPatchset m (PatchSet ps ts)++-- | @getMatchingTag m ps@, where @m@ is a 'Matcher' which matches tags+-- returns a 'SealedPatchSet' containing all patches in the last tag which+-- matches @m@. Last tag means the most recent tag in repository order,+-- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls+-- 'error' if there is no matching tag.+getMatchingTag :: Matchable p => Matcher p -> PatchSet p wStart wX -> SealedPatchSet p wStart+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 =+ -- 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+ Nothing -> bug "splitOnTag couldn't find tag we explicitly provided!"+ Just (patchSet :> _) -> seal patchSet+ | otherwise = getMatchingTag m (PatchSet ps ts)++splitMatchFL :: Matchable p => (forall wA wB . q wA wB -> Sealed2 (Named p)) -> Matcher p -> FL q wX wY -> (FL q :> FL q) wX wY+splitMatchFL _extract m NilFL = error $ "Couldn't find patch matching " ++ show m+splitMatchFL extract m (p :>: ps)+ | unseal2 (applyMatcher m . n2pia) . extract $ p = (p :>: NilFL) :> ps+ | otherwise = case splitMatchFL extract m ps of+ before :> after -> (p :>: before) :> after++-- | @matchExists m ps@ tells whether there is a patch matching+-- @m@ in @ps@+matchExists :: Matcher p -> PatchSet p wStart wX -> Bool+matchExists _ (PatchSet NilRL NilRL) = False+matchExists m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchExists m (PatchSet (t:<:ps) ts)+matchExists m (PatchSet (p:<:ps) ts) | applyMatcher m p = True+ | otherwise = matchExists m (PatchSet ps ts)++applyInvToMatcher :: (Matchable p, ApplyMonad m (ApplyState p))+ => InclusiveOrExclusive -> Matcher p -> PatchSet p Origin wX -> m ()+applyInvToMatcher _ _ (PatchSet NilRL NilRL) = impossible+applyInvToMatcher ioe m (PatchSet NilRL (Tagged t _ ps :<: ts)) = applyInvToMatcher ioe m+ (PatchSet (t:<:ps) ts)+applyInvToMatcher ioe m (PatchSet (p:<:ps) xs)+ | applyMatcher m p = when (ioe == Inclusive) (applyInvp p)+ | otherwise = applyInvp p >> applyInvToMatcher ioe m (PatchSet ps xs)++-- | @applyNInv@ n ps applies the inverse of the last @n@ patches of @ps@.+applyNInv :: (Matchable p, ApplyMonad m (ApplyState p)) => Int -> PatchSet p Origin wX -> m ()+applyNInv n _ | n <= 0 = return ()+applyNInv _ (PatchSet NilRL NilRL) = error "Index out of range."+applyNInv n (PatchSet NilRL (Tagged t _ ps :<: ts)) =+ applyNInv n (PatchSet (t :<: ps) ts)+applyNInv n (PatchSet (p :<: ps) xs) =+ applyInvp p >> applyNInv (n - 1) (PatchSet ps xs)+++getMatcherS :: (ApplyMonad m (ApplyState p), Matchable p) =>+ InclusiveOrExclusive -> Matcher p -> PatchSet p Origin wX -> m ()+getMatcherS ioe m repo =+ if matchExists m repo+ then applyInvToMatcher ioe m repo+ else fail $ "Couldn't match pattern "++ show m++getTagS :: (ApplyMonad m (ApplyState p), MonadProgress m, Matchable p) =>+ Matcher p -> PatchSet p Origin wX -> m ()+getTagS matcher repo = do+ let pinfo = patch2patchinfo `unseal2` findAPatch matcher repo+ case getPatchesBeyondTag pinfo repo of+ FlippedSeal extras -> applyInvRL extras++-- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd+-- patch', and to apply its inverse. If we fail to fetch the patch+-- (presumably in a partial repositiory), then we share our sorrow+-- with the user.+applyInvp :: (Patchy p, ApplyMonad m (ApplyState p)) => PatchInfoAnd p wX wY -> m ()+applyInvp hp = apply (invert $ fromHopefully hp)+ where fromHopefully = conscientiously $ \e ->+ text "Sorry, partial repository problem. Patch not available:"+ $$ e+ $$ text ""+ $$ text "If you think what you're trying to do is ok then"+ $$ text "report this as a bug on the darcs-user list."++-- | a version of 'take' for 'RL' lists that cater for contexts.+safetake :: MaybeInternal p => Int -> RL (PatchInfoAnd p) wX wY -> FlippedSeal (RL (PatchInfoAnd p)) wY+safetake 0 _ = flipSeal NilRL+safetake _ NilRL = error "There aren't that many patches..."+safetake i (a:<:as) | isIsEq (flIsInternal (patchcontents (hopefully a))) = a `consRLSealed` safetake i as+safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as++applyInvRL :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p) => RL (PatchInfoAnd p) wX wR -> m ()+applyInvRL = applyPatches . invertRL -- this gives nicer feedback
− src/Darcs/Patch/MatchData.hs
@@ -1,28 +0,0 @@--- Copyright (C) 2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Patch.MatchData ( PatchMatch(..), patchMatch,- ) where--data PatchMatch = PatternMatch String- deriving ( Eq )--instance Show PatchMatch where- show (PatternMatch m) = "pattern " ++ show m--patchMatch :: String -> PatchMatch-patchMatch s = PatternMatch s
+ src/Darcs/Patch/Matchable.hs view
@@ -0,0 +1,13 @@+-- Copyright (C) 2013 Ganesh Sittampalam+--+-- BSD3++module Darcs.Patch.Matchable ( Matchable ) where++import Darcs.Patch.MaybeInternal ( MaybeInternal )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Patchy ( Patchy )+import Darcs.Patch.Rebase.NameHack ( NameHack )++class (Patchy p, PatchInspect p, MaybeInternal p, NameHack p)+ => Matchable p
+ src/Darcs/Patch/MaybeInternal.hs view
@@ -0,0 +1,33 @@+-- Copyright (C) 2009-2012 Ganesh Sittampalam+--+-- BSD3+module Darcs.Patch.MaybeInternal+ (+ InternalChecker(..)+ , MaybeInternal(..)+ , flIsInternal+ ) where++import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered ( FL )++-- Note: the EqCheck result could be replaced by a Bool if clients were changed to commute the patch+-- out if necessary.+newtype InternalChecker p = InternalChecker { isInternal :: forall wX wY . p wX wY -> EqCheck wX wY }++-- |Provides a hook for flagging whether a patch is "internal" to the repo+-- and therefore shouldn't be referred to externally, e.g. by inclusion in tags.+-- Note that despite the name, every patch type has to implement it, but for+-- normal (non-internal) types the default implementation is fine.+-- Currently only used for rebase internal patches.+class MaybeInternal p where+ -- | @maybe (const NotEq) (fmap isInternal patchInternalChecker) p@+ -- returns 'IsEq' if @p@ is internal, and 'NotEq' otherwise.+ -- The two-level structure is purely for efficiency: 'Nothing' and 'Just (InternalChecker (const NotEq))' are+ -- semantically identical, but 'Nothing' allows clients to avoid traversing an entire list.+ -- The patch type is passed as an 'FL' because that's how the internals of named patches are stored.+ patchInternalChecker :: Maybe (InternalChecker (FL p))+ patchInternalChecker = Nothing++flIsInternal :: MaybeInternal p => FL p wX wY -> EqCheck wX wY+flIsInternal = maybe (const NotEq) isInternal patchInternalChecker
src/Darcs/Patch/Merge.hs view
@@ -1,4 +1,3 @@-#include "gadts.h" -- | -- Module : Darcs.Patch.Merge@@ -9,6 +8,7 @@ module Darcs.Patch.Merge ( Merge(..)+ , selfMerger , mergeFL ) where @@ -16,18 +16,26 @@ import Data.Maybe ( fromJust ) import Darcs.Patch.Commute ( Commute )-import Darcs.Witnesses.Ordered ( (:\/:)(..), (:/\:)(..),- FL(..), RL,- reverseFL, reverseRL- )-+import Darcs.Patch.CommuteFn ( MergeFn )+import Darcs.Patch.Witnesses.Ordered+ ( (:\/:)(..)+ , (:/\:)(..)+ , FL(..)+ , RL+ , reverseFL+ , reverseRL+ ) -- | Things that can always be merged class Commute p => Merge p where- merge :: (p :\/: p) C(x y)- -> (p :/\: p) C(x y)+ merge :: (p :\/: p) wX wY+ -> (p :/\: p) wX wY +selfMerger :: Merge p => MergeFn p p+selfMerger = merge++ instance Merge p => Merge (FL p) where merge (NilFL :\/: x) = x :/\: NilFL merge (x :\/: NilFL) = NilFL :/\: x@@ -43,8 +51,8 @@ mergeFL :: Merge p- => (p :\/: FL p) C(x y)- -> (FL p :/\: p) C(x y)+ => (p :\/: FL p) wX wY+ -> (FL p :/\: p) wX wY mergeFL (p :\/: NilFL) = NilFL :/\: p mergeFL (p :\/: (x :>: xs)) = fromJust $ do x' :/\: p' <- return $ merge (p :\/: x)
+ src/Darcs/Patch/MonadProgress.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TypeSynonymInstances #-}+-- Copyright (C) 2011 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.++module Darcs.Patch.MonadProgress+ ( MonadProgress(..)+ , ProgressAction(..)+ , silentlyRunProgressActions+ ) where++import Prelude hiding ( catch )+import Darcs.Util.Printer ( Doc )+import Darcs.Util.Printer.Color () -- for instance Show Doc+import qualified Storage.Hashed.Monad as HSM++-- |a monadic action, annotated with a progress message that could be printed out+-- while running the action, and a message that could be printed out on error.+-- Actually printing out these messages is optional to allow non-IO monads to+-- just run the action.+data ProgressAction m a =+ ProgressAction+ {paAction :: m a+ ,paMessage :: Doc+ ,paOnError :: Doc+ }++class Monad m => MonadProgress m where+ -- |run a list of 'ProgressAction's. In some monads (typically IO-based ones),+ -- the progress and error messages will be used. In others they will be+ -- ignored and just the actions will be run.+ runProgressActions :: String -> [ProgressAction m ()] -> m ()++-- |run a list of 'ProgressAction's without any feedback messages+silentlyRunProgressActions :: Monad m => String -> [ProgressAction m ()] -> m ()+silentlyRunProgressActions _ = mapM_ paAction++instance (Functor m, Monad m) => MonadProgress (HSM.TreeMonad m) where+ runProgressActions = silentlyRunProgressActions
src/Darcs/Patch/Named.hs view
@@ -17,7 +17,6 @@ {-# LANGUAGE CPP #-} -#include "gadts.h" module Darcs.Patch.Named ( Named(..),@@ -25,41 +24,52 @@ adddeps, namepatch, anonymous, getdeps, patch2patchinfo, patchname, patchcontents,- fmapNamed, fmapFL_Named+ fmapNamed, fmapFL_Named,+ commuterIdNamed, commuterNamedId,+ mergerIdNamed ) where import Prelude hiding ( pi )+import Darcs.Patch.CommuteFn ( CommuteFn, commuterIdFL, commuterFLId+ , MergeFn, mergerIdFL ) import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts )+import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect(effect, effectRL) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, patchinfo,- humanFriendly, makePatchname, invertName )+ showPatchInfoUI, makePatchname, invertName ) import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Patchy ( Patchy, Commute(..), Invert(..), Apply(..),+import Darcs.Patch.Patchy ( Commute(..), Invert(..), Apply(..), PatchInspect(..), ReadPatch(..) ) import Darcs.Patch.Prim ( PrimOf, PrimPatchBase ) import Darcs.Patch.ReadMonads ( ParserM, option, lexChar, choice, skipWhile, anyChar )+import Darcs.Patch.Rebase.NameHack ( NameHack(..) ) import Darcs.Patch.Repair ( mapMaybeSnd, Repair(..), RepairToFL, Check(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), showNamedPrefix ) import Darcs.Patch.Summary ( plainSummary ) import Darcs.Patch.Viewing () -- for ShowPatch FL instances -import Darcs.Witnesses.Eq ( MyEq(..) )-import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL, mapFL_FL )-import Darcs.Witnesses.Sealed ( Sealed, mapSeal )-import Darcs.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..) )+import Darcs.Patch.Witnesses.Eq ( MyEq(..) )+import Darcs.Patch.Witnesses.Ordered+ ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL, mapFL_FL )+import Darcs.Patch.Witnesses.Sealed ( Sealed, mapSeal )+import Darcs.Patch.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..) ) -import Printer ( renderString, ($$), (<+>), (<>), prefix, text, vcat )+import Darcs.Util.Diff ( DiffAlgorithm(MyersDiff) )+import Darcs.Util.Printer ( ($$), (<+>), (<>), prefix, text, vcat ) +import Data.Maybe ( fromMaybe )+ -- | The @Named@ type adds a patch info about a patch, that is a name.-data Named p C(x y) where+data Named p wX wY where NamedP :: !PatchInfo -> ![PatchInfo]- -> !(FL p C(x y))- -> Named p C(x y)+ -> !(FL p wX wY)+ -> Named p wX wY+ deriving Show -- ^ @NamedP info deps p@ represents patch @p@ with name -- @info@. @deps@ is a list of dependencies added at the named patch -- level, compared with the unnamed level (ie, dependencies added with@@ -80,7 +90,7 @@ instance (ReadPatch p, PatchListFormat p) => ReadPatch (Named p) where readPatch' = readNamed -readNamed :: (ReadPatch p, PatchListFormat p, ParserM m) => m (Sealed (Named p C(x )))+readNamed :: (ReadPatch p, PatchListFormat p, ParserM m) => m (Sealed (Named p wX)) readNamed = do n <- readPatchInfo d <- readDepends@@ -107,59 +117,75 @@ instance RepairToFL p => Repair (Named p) where applyAndTryToFix (NamedP n d p) = mapMaybeSnd (NamedP n d) `fmap` applyAndTryToFix p -namepatch :: Patchy p => String -> String -> String -> [String] -> FL p C(x y) -> IO (Named p C(x y))+namepatch :: String -> String -> String -> [String] -> FL p wX wY -> IO (Named p wX wY) namepatch date name author desc p | '\n' `elem` name = error "Patch names cannot contain newlines." | otherwise = do pinf <- patchinfo date name author desc return $ NamedP pinf [] p -anonymous :: Patchy p => FL p C(x y) -> IO (Named p C(x y))+anonymous :: FL p wX wY -> IO (Named p wX wY) anonymous p = namepatch "today" "anonymous" "unknown" ["anonymous"] p -infopatch :: Patchy p => PatchInfo -> FL p C(x y) -> Named p C(x y)+infopatch :: PatchInfo -> FL p wX wY -> Named p wX wY infopatch pi p = NamedP pi [] p -adddeps :: Named p C(x y) -> [PatchInfo] -> Named p C(x y)+adddeps :: Named p wX wY -> [PatchInfo] -> Named p wX wY adddeps (NamedP pi _ p) ds = NamedP pi ds p -getdeps :: Named p C(x y) -> [PatchInfo]+getdeps :: Named p wX wY -> [PatchInfo] getdeps (NamedP _ ds _) = ds -patch2patchinfo :: Named p C(x y) -> PatchInfo+patch2patchinfo :: Named p wX wY -> PatchInfo patch2patchinfo (NamedP i _ _) = i -patchname :: Named p C(x y) -> String-patchname (NamedP i _ _) = makePatchname i+patchname :: Named p wX wY -> String+patchname (NamedP i _ _) = show $ makePatchname i -patchcontents :: Named p C(x y) -> FL p C(x y)+patchcontents :: Named p wX wY -> FL p wX wY patchcontents (NamedP _ _ p) = p -fmapNamed :: (FORALL(a b) p C(a b) -> q C(a b)) -> Named p C(x y) -> Named q C(x y)+fmapNamed :: (forall wA wB . p wA wB -> q wA wB) -> Named p wX wY -> Named q wX wY fmapNamed f (NamedP i deps p) = NamedP i deps (mapFL_FL f p) -fmapFL_Named :: (FL p C(x y) -> FL q C(x y)) -> Named p C(x y) -> Named q C(x y)+fmapFL_Named :: (FL p wA wB -> FL q wC wD) -> Named p wA wB -> Named q wC wD fmapFL_Named f (NamedP i deps p) = NamedP i deps (f p) instance (Commute p, MyEq p) => MyEq (Named p) where unsafeCompare (NamedP n1 d1 p1) (NamedP n2 d2 p2) = n1 == n2 && d1 == d2 && unsafeCompare p1 p2 -instance (Commute p, Invert p) => Invert (Named p) where+instance Invert p => Invert (Named p) where invert (NamedP n d p) = NamedP (invertName n) (map invertName d) (invert p) -instance Commute p => Commute (Named p) where+instance (Commute p, NameHack p) => Commute (Named p) where commute (NamedP n1 d1 p1 :> NamedP n2 d2 p2) = if n2 `elem` d1 || n1 `elem` d2 then Nothing else do (p2' :> p1') <- commute (p1 :> p2)- return (NamedP n2 d2 p2' :> NamedP n1 d1 p1')+ let (informAdd, informDel) = fromMaybe (const id, const id) (nameHack MyersDiff)+ return (NamedP n2 d2 (informAdd n1 p2') :> NamedP n1 d1 (informDel n2 p1')) -instance Merge p => Merge (Named p) where+commuterIdNamed :: CommuteFn p1 p2 -> CommuteFn p1 (Named p2)+commuterIdNamed commuter (p1 :> NamedP n2 d2 p2) =+ do p2' :> p1' <- commuterIdFL commuter (p1 :> p2)+ return (NamedP n2 d2 p2' :> p1')++commuterNamedId :: CommuteFn p1 p2 -> CommuteFn (Named p1) p2+commuterNamedId commuter (NamedP n1 d1 p1 :> p2) =+ do p2' :> p1' <- commuterFLId commuter (p1 :> p2)+ return (p2' :> NamedP n1 d1 p1')++instance (Merge p, NameHack p) => Merge (Named p) where merge (NamedP n1 d1 p1 :\/: NamedP n2 d2 p2) = case merge (p1 :\/: p2) of (p2' :/\: p1') -> NamedP n2 d2 p2' :/\: NamedP n1 d1 p1' +mergerIdNamed :: MergeFn p1 p2 -> MergeFn p1 (Named p2)+mergerIdNamed merger (p1 :\/: NamedP n2 d2 p2) =+ case mergerIdFL merger (p1 :\/: p2) of+ p2' :/\: p1' -> NamedP n2 d2 p2' :/\: p1'+ instance PatchInspect p => PatchInspect (Named p) where listTouchedFiles (NamedP _ _ p) = listTouchedFiles p hunkMatches f (NamedP _ _ p) = hunkMatches f p@@ -179,7 +205,7 @@ PrimPatchBase p, ShowPatch p) => ShowPatch (Named p) where showContextPatch (NamedP n [] p) = showContextPatch p >>= return . (showPatchInfo n <>) showContextPatch (NamedP n d p) = showContextPatch p >>= return . (showNamedPrefix n d <+>)- description (NamedP n _ _) = humanFriendly n+ description (NamedP n _ _) = showPatchInfoUI n summary p = description p $$ text "" $$ prefix " " (plainSummary p) -- this isn't summary because summary does the -- wrong thing with (Named (FL p)) so that it can@@ -189,11 +215,11 @@ showNicely p@(NamedP _ _ pt) = description p $$ prefix " " (showNicely pt) -instance (PatchListFormat p, ShowPatch p) => Show (Named p C(x y)) where- show = renderString . showPatch--instance (PatchListFormat p, ShowPatch p) => Show1 (Named p C(x)) where+instance Show2 p => Show1 (Named p wX) where showDict1 = ShowDictClass -instance (PatchListFormat p, ShowPatch p) => Show2 (Named p) where+instance Show2 p => Show2 (Named p) where showDict2 = ShowDictClass++instance PatchDebug p => PatchDebug (Named p)+
src/Darcs/Patch/OldDate.hs view
@@ -98,7 +98,7 @@ | n < 0 = return [] | n > m = return [] | n == m = count n p- | n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))+ | n == 0 = foldr ((<|>) . (\x -> try $ count x p)) (return []) $ reverse [1..m] | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p) @@ -110,19 +110,23 @@ try $ iso8601DateTime tz, oldDateTime] +dayAndHMSTime :: CharParser a (Int, Int, Int, Int)+dayAndHMSTime = do d <- day+ _ <- mySpaces+ h <- hour+ _ <- char ':'+ m <- minute+ _ <- char ':'+ s <- second+ return (d, h, m, s)+ cvsDateTime :: Int -> CharParser a CalendarTime cvsDateTime tz = do y <- year _ <- char '/' mon <- monthNum _ <- char '/'- d <- day- _ <- mySpaces- h <- hour- _ <- char ':'- m <- minute- _ <- char ':'- s <- second+ (d, h, m, s) <- dayAndHMSTime z <- option tz $ mySpaces >> zone return (CalendarTime y mon d h m s 0 Monday 0 "" z False) @@ -131,13 +135,7 @@ _ <- mySpaces mon <- monthName _ <- mySpaces- d <- day- _ <- mySpaces- h <- hour- _ <- char ':'- m <- minute- _ <- char ':'- s <- second+ (d, h, m, s) <- dayAndHMSTime _ <- mySpaces z <- zone _ <- mySpaces@@ -194,8 +192,8 @@ -- will have already passed before the first week let afterThursday = firstDay == Sunday || firstDay > Thursday w = if afterThursday then w'+1 else w'- diff c = c { ctDay = (7 * w) + wd - (fromEnum firstDay) }- return [(toUTCTime.toClockTime.diff.yfn)]+ diff c = c { ctDay = (7 * w) + wd - fromEnum firstDay }+ return [toUTCTime.toClockTime.diff.yfn] ordinal_date = -- yyyy-ddd try $ optchain year_ [ (dash, yearDay_) ] --@@ -231,11 +229,11 @@ digsExp = length digs let frac | null digs = 0 | digsExp > picoExp = read $ take picoExp digs- | otherwise = 10 ^ (picoExp - digsExp) * (read digs)+ | otherwise = 10 ^ (picoExp - digsExp) * read digs return $ \c -> c { ctPicosec = frac } zulu = do { _ <- char 'Z'; return (\c -> c { ctTZ = 0 }) }- offset = do sign <- choice [ do { char '+' >> return 1 }- , do { char '-' >> return (-1) } ]+ offset = do sign <- choice [ char '+' >> return 1+ , char '-' >> return (-1) ] h <- twoDigits m <- option 0 $ do { optional colon; twoDigits } return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) }@@ -275,7 +273,7 @@ monthNum :: CharParser a Month monthNum = do mn <- manyNtoM 1 2 digit- return $ intToMonth $ (read mn :: Int)+ return $ intToMonth (read mn :: Int) intToMonth :: Int -> Month intToMonth 1 = January@@ -339,7 +337,7 @@ , mkZone "CEST" 2 , mkZone "EEST" 3 -- if we don't understand it, just give a GMT answer...- , do { _ <- manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])+ , do { _ <- manyTill (oneOf $ ['a'..'z']++['A'..'Z']++" ") (lookAhead space_digit); return 0 } ]
src/Darcs/Patch/PatchInfoAnd.hs view
@@ -15,25 +15,27 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, UndecidableInstances #-} -- XXX Undecidable only in GHC < 7+{-# LANGUAGE CPP #-} -#include "gadts.h" -module Darcs.Patch.PatchInfoAnd ( Hopefully, PatchInfoAnd,+module Darcs.Patch.PatchInfoAnd ( Hopefully(..), SimpleHopefully(..), PatchInfoAnd(..), WPatchInfo, unWPatchInfo, compareWPatchInfo, piap, n2pia, patchInfoAndPatch,- fmapPIAP, fmapFL_PIAP,+ fmapPIAP, fmapFLPIAP, conscientiously, hopefully, info, winfo, hopefullyM, createHashed, extractHash, actually, unavailable, patchDesc ) where import System.IO.Unsafe ( unsafeInterleaveIO ) -import Darcs.SignalHandler ( catchNonSignal )-import Printer ( Doc, renderString, errorDoc, text, ($$), vcat )-import Darcs.Patch.Info ( PatchInfo, humanFriendly, justName )-import Darcs.Patch ( RepoPatch, Named, patch2patchinfo )+import Darcs.Util.SignalHandler ( catchNonSignal )+import Darcs.Util.Printer+ ( Doc, renderString, errorDoc, text, ($$), vcat+ , RenderMode(..) )+import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI, justName )+import Darcs.Patch ( Named, patch2patchinfo ) import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )+import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat )@@ -42,13 +44,15 @@ import Darcs.Patch.Prim ( PrimPatchBase(..) ) import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..), ShowPatch(..), Commute(..), PatchInspect(..) )+import Darcs.Patch.Rebase.NameHack ( NameHack ) import Darcs.Patch.Repair ( Repair(..), RepairToFL ) import Darcs.Patch.Show ( ShowPatchBasic(..) )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal )-import Darcs.Utils ( prettyException )+import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal )+import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) )+import Darcs.Util.Exception ( prettyException ) import Storage.Hashed.Tree( Tree ) import Control.Applicative ( (<$>) )@@ -60,35 +64,44 @@ -- 'SimpleHopefully' does the real work of emulating -- 'Either'. @Hopefully sh@ represents an expected unhashed patch, and -- @Hashed hash sh@ represents an expected hashed patch with its hash.-data Hopefully a C(x y) = Hopefully (SimpleHopefully a C(x y)) | Hashed String (SimpleHopefully a C(x y))+data Hopefully a wX wY = Hopefully (SimpleHopefully a wX wY) | Hashed String (SimpleHopefully a wX wY)+ deriving Show -- | @SimpleHopefully@ is a variant of @Either String@ adapted for -- type witnesses. @Actually@ is the equivalent of @Right@, while -- @Unavailable@ is @Left@.-data SimpleHopefully a C(x y) = Actually (a C(x y)) | Unavailable String+data SimpleHopefully a wX wY = Actually (a wX wY) | Unavailable String+ deriving Show --- | @'PatchInfoAnd' p C(a b)@ represents a hope we have to get a+-- | @'PatchInfoAnd' p wA wB@ represents a hope we have to get a -- patch through its info. We're not sure we have the patch, but we -- know its info.-data PatchInfoAnd p C(a b) = PIAP !PatchInfo (Hopefully (Named p) C(a b))+data PatchInfoAnd p wA wB = PIAP !PatchInfo (Hopefully (Named p) wA wB)+ deriving Show +instance Show2 p => Show1 (PatchInfoAnd p wX) where+ showDict1 = ShowDictClass++instance Show2 p => Show2 (PatchInfoAnd p) where+ showDict2 = ShowDictClass+ instance PrimPatchBase p => PrimPatchBase (PatchInfoAnd p) where type PrimOf (PatchInfoAnd p) = PrimOf p --- | @'WPatchInfo' C(a b)@ represents the info of a patch, marked with+-- | @'WPatchInfo' wA wB@ represents the info of a patch, marked with -- the patch's witnesses.-newtype WPatchInfo C(a b) = WPatchInfo { unWPatchInfo :: PatchInfo }+newtype WPatchInfo wA wB = WPatchInfo { unWPatchInfo :: PatchInfo } -- This is actually unsafe if we ever commute patches and then compare them -- using this function. TODO: consider adding an extra existential to WPatchInfo -- (as with TaggedPatch in Darcs.Patch.Choices)-compareWPatchInfo :: WPatchInfo C(a b) -> WPatchInfo C(c d) -> EqCheck C((a, b) (c, d))+compareWPatchInfo :: WPatchInfo wA wB -> WPatchInfo wC wD -> EqCheck (wA, wB) (wC, wD) compareWPatchInfo (WPatchInfo x) (WPatchInfo y) = if x == y then unsafeCoerceP IsEq else NotEq instance MyEq WPatchInfo where WPatchInfo x `unsafeCompare` WPatchInfo y = x == y -fmapH :: (a C(x y) -> b C(w z)) -> Hopefully a C(x y) -> Hopefully b C(w z)+fmapH :: (a wX wY -> b wW wZ) -> Hopefully a wX wY -> Hopefully b wW wZ fmapH f (Hopefully sh) = Hopefully (ff sh) where ff (Actually a) = Actually (f a) ff (Unavailable e) = Unavailable e@@ -96,85 +109,88 @@ where ff (Actually a) = Actually (f a) ff (Unavailable e) = Unavailable e -info :: PatchInfoAnd p C(a b) -> PatchInfo+info :: PatchInfoAnd p wA wB -> PatchInfo info (PIAP i _) = i -patchDesc :: forall p C(x y) . PatchInfoAnd p C(x y) -> String+patchDesc :: forall p wX wY . PatchInfoAnd p wX wY -> String patchDesc p = justName $ info p -winfo :: PatchInfoAnd p C(a b) -> WPatchInfo C(a b)+winfo :: PatchInfoAnd p wA wB -> WPatchInfo wA wB winfo (PIAP i _) = WPatchInfo i -- | @'piap' i p@ creates a PatchInfoAnd containing p with info i.-piap :: PatchInfo -> Named p C(a b) -> PatchInfoAnd p C(a b)+piap :: PatchInfo -> Named p wA wB -> PatchInfoAnd p wA wB piap i p = PIAP i (Hopefully $ Actually p) -- | @n2pia@ creates a PatchInfoAnd representing a @Named@ patch.-n2pia :: Named p C(x y) -> PatchInfoAnd p C(x y)+n2pia :: Named p wX wY -> PatchInfoAnd p wX wY n2pia x = patch2patchinfo x `piap` x -patchInfoAndPatch :: PatchInfo -> Hopefully (Named p) C(a b) -> PatchInfoAnd p C(a b)+patchInfoAndPatch :: PatchInfo -> Hopefully (Named p) wA wB -> PatchInfoAnd p wA wB patchInfoAndPatch = PIAP -fmapPIAP :: (FORALL(a b) p C(a b) -> q C(a b)) -> PatchInfoAnd p C(x y) -> PatchInfoAnd q C(x y)+fmapPIAP :: (forall wA wB . p wA wB -> q wA wB) -> PatchInfoAnd p wX wY -> PatchInfoAnd q wX wY fmapPIAP f (PIAP i hp) = PIAP i (fmapH (fmapNamed f) hp) -fmapFL_PIAP :: (FL p C(x y) -> FL q C(x y)) -> PatchInfoAnd p C(x y) -> PatchInfoAnd q C(x y)-fmapFL_PIAP f (PIAP i hp) = PIAP i (fmapH (fmapFL_Named f) hp)+fmapFLPIAP :: (FL p wX wY -> FL q wX wY) -> PatchInfoAnd p wX wY -> PatchInfoAnd q wX wY+fmapFLPIAP f (PIAP i hp) = PIAP i (fmapH (fmapFL_Named f) hp) -- | @'hopefully' hp@ tries to get a patch from a 'PatchInfoAnd' -- value. If it fails, it outputs an error \"failed to read patch: -- \<description of the patch>\". We get the description of the patch -- from the info part of 'hp'-hopefully :: PatchInfoAnd p C(a b) -> Named p C(a b)+hopefully :: PatchInfoAnd p wA wB -> Named p wA wB hopefully = conscientiously $ \e -> text "failed to read patch:" $$ e -- | @'conscientiously' er hp@ tries to extract a patch from a 'PatchInfoAnd'. -- If it fails, it applies the error handling function @er@ to a description -- of the patch info component of @hp@. conscientiously :: (Doc -> Doc)- -> PatchInfoAnd p C(a b) -> Named p C(a b)+ -> PatchInfoAnd p wA wB -> Named p wA wB conscientiously er (PIAP pinf hp) = case hopefully2either hp of Right p -> p- Left e -> errorDoc $ er (humanFriendly pinf $$ text e)+ Left e -> errorDoc $ er (showPatchInfoUI pinf $$ text e) -- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a -- monad instead of erroring.-hopefullyM :: Monad m => PatchInfoAnd p C(a b) -> m (Named p C(a b))+hopefullyM :: Monad m => PatchInfoAnd p wA wB -> m (Named p wA wB) hopefullyM (PIAP pinf hp) = case hopefully2either hp of Right p -> return p- Left e -> fail $ renderString (humanFriendly pinf $$ text e)+ Left e -> fail $ renderString Encode+ (showPatchInfoUI pinf $$ text e) -- Any recommendations for a nice adverb to name the below?-hopefully2either :: Hopefully a C(x y) -> Either String (a C(x y))+hopefully2either :: Hopefully a wX wY -> Either String (a wX wY) hopefully2either (Hopefully (Actually p)) = Right p hopefully2either (Hashed _ (Actually p)) = Right p hopefully2either (Hopefully (Unavailable e)) = Left e hopefully2either (Hashed _ (Unavailable e)) = Left e -actually :: a C(x y) -> Hopefully a C(x y)+actually :: a wX wY -> Hopefully a wX wY actually = Hopefully . Actually -createHashed :: String -> (String -> IO (Sealed (a C(x)))) -> IO (Sealed (Hopefully a C(x)))-createHashed h f = do mapSeal (Hashed h) `fmap` unsafeInterleaveIO (f' `catchNonSignal` handler)+createHashed :: String -> (String -> IO (Sealed (a wX))) -> IO (Sealed (Hopefully a wX))+createHashed h f = mapSeal (Hashed h) `fmap` unsafeInterleaveIO (f' `catchNonSignal` handler) where f' = do Sealed x <- f h return (Sealed (Actually x)) handler e = return $ seal $ Unavailable $ prettyException e -extractHash :: PatchInfoAnd p C(a b) -> Either (Named p C(a b)) String+extractHash :: PatchInfoAnd p wA wB -> Either (Named p wA wB) String extractHash (PIAP _ (Hashed s _)) = Right s extractHash hp = Left $ conscientiously (\e -> text "unable to read patch:" $$ e) hp -unavailable :: String -> Hopefully a C(x y)+unavailable :: String -> Hopefully a wX wY unavailable = Hopefully . Unavailable -instance (Commute p, MyEq p) => MyEq (PatchInfoAnd p) where+-- Equality on PatchInfoAnd is solely determined by the PatchInfo+-- It is a global invariant of darcs that once a patch is recorded,+-- it should always have the same representation in the same context.+instance MyEq (PatchInfoAnd p) where unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2 ---instance Invert (p C(x y)) => Invert (PatchInfoAnd (p C(x y))) where-instance (Commute p, Invert p) => Invert (PatchInfoAnd p) where+instance Invert p => Invert (PatchInfoAnd p) where invert (PIAP i p) = PIAP i (invert `fmapH` p) instance PatchListFormat (PatchInfoAnd p)@@ -182,27 +198,27 @@ instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (PatchInfoAnd p) where showPatch (PIAP n p) = case hopefully2either p of Right x -> showPatch x- Left _ -> humanFriendly n+ Left _ -> showPatchInfoUI n instance (Apply p, Conflict p, CommuteNoConflicts p, IsHunk p, PatchListFormat p, PrimPatchBase p, ShowPatch p, ApplyState p ~ Tree) => ShowPatch (PatchInfoAnd p) where showContextPatch (PIAP n p) = case hopefully2either p of Right x -> showContextPatch x- Left _ -> return $ humanFriendly n- description (PIAP n _) = humanFriendly n+ Left _ -> return $ showPatchInfoUI n+ description (PIAP n _) = showPatchInfoUI n summary (PIAP n p) = case hopefully2either p of Right x -> summary x- Left _ -> humanFriendly n+ Left _ -> showPatchInfoUI n summaryFL = vcat . mapFL summary showNicely (PIAP n p) = case hopefully2either p of Right x -> showNicely x- Left _ -> humanFriendly n+ Left _ -> showPatchInfoUI n -instance Commute p => Commute (PatchInfoAnd p) where+instance (Commute p, NameHack p) => Commute (PatchInfoAnd p) where commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y) return $ (info y `piap` y') :> (info x `piap` x') -instance Merge p => Merge (PatchInfoAnd p) where+instance (Merge p, NameHack p) => Merge (PatchInfoAnd p) where merge (x :\/: y) = case merge (hopefully x :\/: hopefully y) of y' :/\: x' -> (info y `piap` y') :/\: (info x `piap` x') @@ -230,4 +246,7 @@ instance IsHunk (PatchInfoAnd p) where isHunk _ = Nothing -instance (RepoPatch p, ApplyState p ~ Tree) => Patchy (PatchInfoAnd p)+instance PatchDebug p => PatchDebug (PatchInfoAnd p)++instance (Patchy p, NameHack p, ApplyState p ~ Tree) => Patchy (PatchInfoAnd p)+
src/Darcs/Patch/Patchy.hs view
@@ -17,7 +17,6 @@ {-# LANGUAGE CPP #-} -#include "gadts.h" module Darcs.Patch.Patchy ( Patchy,@@ -31,8 +30,7 @@ import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.Show ( showPatch, ShowPatch(..), ShowPatchBasic )-import Darcs.Witnesses.Eq ( MyEq )+import Darcs.Patch.Show ( showPatch, ShowPatch(..) ) -class (MyEq p, Apply p, Commute p, PatchInspect p, ShowPatch p, ReadPatch p, Invert p) => Patchy p+class (Apply p, Commute p, Invert p) => Patchy p
src/Darcs/Patch/Patchy/Instances.hs view
@@ -7,7 +7,7 @@ import Darcs.Patch.Permutations () import Darcs.Patch.FileHunk ( IsHunk ) import Darcs.Patch.Viewing ()-import Darcs.Witnesses.Ordered ( FL, RL )+import Darcs.Patch.Witnesses.Ordered ( FL, RL ) instance (IsHunk p, PatchListFormat p, Patchy p) => Patchy (FL p) instance (IsHunk p, PatchListFormat p, Patchy p) => Patchy (RL p)
src/Darcs/Patch/Permutations.hs view
@@ -19,55 +19,55 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} -#include "gadts.h" module Darcs.Patch.Permutations ( removeFL, removeRL, removeCommon, commuteWhatWeCanFL, commuteWhatWeCanRL,- genCommuteWhatWeCanRL,+ genCommuteWhatWeCanRL, genCommuteWhatWeCanFL, partitionFL, partitionRL, simpleHeadPermutationsFL, headPermutationsRL, headPermutationsFL, removeSubsequenceFL, removeSubsequenceRL, partitionConflictingFL,- CommuteFn, selfCommuter,- commuterIdFL, commuterFLId,- commuterIdRL+ inverseCommuter ) where import Data.Maybe ( mapMaybe ) import Darcs.Patch.Commute ( Commute, commute, commuteFLorComplain, commuteRL )-import Darcs.Patch.Invert ( Invert(..), invertFL, invertRL )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+<+)- , reverseFL, (+>+), (:\/:)(..), lengthFL- , lengthRL, reverseRL )+import Darcs.Patch.CommuteFn ( CommuteFn )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), RL(..), (:>)(..), (+<+)+ , reverseFL, (+>+), (:\/:)(..), lengthFL+ , lengthRL, reverseRL ) #include "impossible.h" -- |split an 'FL' into "left" and "right" lists according to a predicate @p@, using commutation as necessary. -- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy -- the predicate, it goes in the "middle" list; to sum up, we have: @all p left@ and @all (not.p) right@, while -- midddle is mixed.+-- Note that @p@ should be invariant under commutation (i.e. if 'x1' can commute to 'x2' then 'p x1 <=> p x2'). partitionFL :: Commute p- => (FORALL(u v) p C(u v) -> Bool) -- ^predicate; if true we would like the patch in the "left" list- -> FL p C(x y) -- ^input 'FL'- -> ((FL p :> FL p :> FL p) C(x y)) -- ^"left", "middle" and "right"+ => (forall wU wV . p wU wV -> Bool) -- ^predicate; if true we would like the patch in the "left" list+ -> FL p wX wY -- ^input 'FL'+ -> (FL p :> FL p :> FL p) wX wY -- ^"left", "middle" and "right" -- optimise by using an accumulating parameter to track all the "right" patches that we've found so far partitionFL' :: Commute p- => (FORALL(u v) p C(u v) -> Bool)- -> RL p C(a b) -- the "middle" patches found so far- -> RL p C(b c) -- the "right" patches found so far- -> FL p C(c d)- -> ((FL p :> FL p :> FL p) C(a d))+ => (forall wU wV . p wU wV -> Bool)+ -> RL p wA wB -- the "middle" patches found so far+ -> RL p wB wC -- the "right" patches found so far+ -> FL p wC wD+ -> (FL p :> FL p :> FL p) wA wD -partitionFL keepleft ps = partitionFL' keepleft NilRL NilRL ps+partitionFL keepleft = partitionFL' keepleft NilRL NilRL -partitionFL' _ middle right NilFL = (NilFL :> reverseRL middle :> reverseRL right)+partitionFL' _ middle right NilFL = NilFL :> reverseRL middle :> reverseRL right partitionFL' keepleft middle right (p :>: ps) | keepleft p = case commuteRL (right :> p) of Just (p' :> right') -> case commuteRL (middle :> p') of Just (p'' :> middle') -> case partitionFL' keepleft middle' right' ps of- (a :> b :> c) -> (p'' :>: a :> b :> c)+ (a :> b :> c) -> p'' :>: a :> b :> c Nothing -> partitionFL' keepleft (p' :<: middle) right' ps Nothing -> case commuteWhatWeCanRL (right :> p) of (tomiddle :> p' :> right') -> partitionFL' keepleft (p' :<: tomiddle +<+ middle) right' ps@@ -78,16 +78,16 @@ -- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy -- the predicate, it goes in the "left" list. partitionRL :: Commute p- => (FORALL(u v) p C(u v) -> Bool) -- ^predicate; if true we would like the patch in the "right" list- -> RL p C(x y) -- ^input 'RL'- -> (RL p :> RL p) C(x y) -- ^"left" and "right" results+ => (forall wU wV . p wU wV -> Bool) -- ^predicate; if true we would like the patch in the "right" list+ -> RL p wX wY -- ^input 'RL'+ -> (RL p :> RL p) wX wY -- ^"left" and "right" results -- optimise by using an accumulating parameter to track all the "left" patches that we've found so far partitionRL' :: Commute p- => (FORALL(u v) p C(u v) -> Bool)- -> RL p C(x z)- -> FL p C(z y) -- the "left" patches found so far- -> (RL p :> RL p) C(x y)+ => (forall wU wV . p wU wV -> Bool)+ -> RL p wX wZ+ -> FL p wZ wY -- the "left" patches found so far+ -> (RL p :> RL p) wX wY partitionRL keepright ps = partitionRL' keepright ps NilFL @@ -100,24 +100,30 @@ a :> b -> a :> p' :<: b | otherwise = partitionRL' keepright ps (p :>: qs) -commuteWhatWeCanFL :: Commute p => (p :> FL p) C(x y) -> (FL p :> p :> FL p) C(x y)-commuteWhatWeCanFL (p :> x :>: xs) =- case commute (p :> x) of+commuteWhatWeCanFL :: Commute p => (p :> FL p) wX wY -> (FL p :> p :> FL p) wX wY+commuteWhatWeCanFL = genCommuteWhatWeCanFL commute++genCommuteWhatWeCanFL :: Commute q =>+ (forall wA wB . ((p:>q) wA wB -> Maybe ((q:>p)wA wB)))+ -> (p :> FL q) wX wY -> (FL q :> p :> FL q) wX wY+genCommuteWhatWeCanFL com (p :> x :>: xs) =+ case com (p :> x) of Nothing -> case commuteWhatWeCanFL (x :> xs) of- xs1 :> x' :> xs2 -> case commuteWhatWeCanFL (p :> xs1) of+ xs1 :> x' :> xs2 -> case genCommuteWhatWeCanFL com (p :> xs1) of xs1' :> p' :> xs2' -> xs1' :> p' :> xs2' +>+ x' :>: xs2- Just (x' :> p') -> case commuteWhatWeCanFL (p' :> xs) of+ Just (x' :> p') -> case genCommuteWhatWeCanFL com (p' :> xs) of a :> p'' :> c -> x' :>: a :> p'' :> c-commuteWhatWeCanFL (y :> NilFL) = NilFL :> y :> NilFL+genCommuteWhatWeCanFL _ (y :> NilFL) = NilFL :> y :> NilFL -commuteWhatWeCanRL :: Commute p => (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y)+commuteWhatWeCanRL :: Commute p => (RL p :> p) wX wY -> (RL p :> p :> RL p) wX wY commuteWhatWeCanRL = genCommuteWhatWeCanRL commute -genCommuteWhatWeCanRL :: (FORALL(a b) ((p :> p) C(a b) -> Maybe ((p :> p) C(a b))))- -> (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y)+genCommuteWhatWeCanRL :: Commute p =>+ (forall wA wB . ((p :> q) wA wB -> Maybe ((q :> p) wA wB)))+ -> (RL p :> q) wX wY -> (RL p :> q :> RL p) wX wY genCommuteWhatWeCanRL com (x :<: xs :> p) = case com (x :> p) of- Nothing -> case genCommuteWhatWeCanRL com (xs :> x) of+ Nothing -> case commuteWhatWeCanRL (xs :> x) of xs1 :> x' :> xs2 -> case genCommuteWhatWeCanRL com (xs2 :> p) of xs1' :> p' :> xs2' -> xs1' +<+ x' :<: xs1 :> p' :> xs2' Just (p' :> x') -> case genCommuteWhatWeCanRL com (xs :> p') of@@ -125,11 +131,11 @@ genCommuteWhatWeCanRL _ (NilRL :> y) = NilRL :> y :> NilRL -removeCommon :: (MyEq p, Commute p) => (FL p :\/: FL p) C(x y) -> (FL p :\/: FL p) C(x y)+removeCommon :: (MyEq p, Commute p) => (FL p :\/: FL p) wX wY -> (FL p :\/: FL p) wX wY removeCommon (xs :\/: NilFL) = xs :\/: NilFL removeCommon (NilFL :\/: xs) = NilFL :\/: xs removeCommon (xs :\/: ys) = rc xs (headPermutationsFL ys)- where rc :: (MyEq p, Commute p) => FL p C(x y) -> [(p:>FL p) C(x z)] -> (FL p :\/: FL p) C(y z)+ where rc :: (MyEq p, Commute p) => FL p wX wY -> [(p:>FL p) wX wZ] -> (FL p :\/: FL p) wY wZ rc nms ((n:>ns):_) | Just ms <- removeFL n nms = removeCommon (ms :\/: ns) rc ms [n:>ns] = ms :\/: n:>:ns rc ms (_:nss) = rc ms nss@@ -137,17 +143,17 @@ -- | 'removeFL' @x xs@ removes @x@ from @xs@ if @x@ can be commuted to its head. -- Otherwise it returns 'Nothing'-removeFL :: (MyEq p, Commute p) => p C(x y) -> FL p C(x z) -> Maybe (FL p C(y z))+removeFL :: (MyEq p, Commute p) => p wX wY -> FL p wX wZ -> Maybe (FL p wY wZ) removeFL x xs = r x $ headPermutationsFL xs- where r :: (MyEq p, Commute p) => p C(x y) -> [(p:>FL p) C(x z)] -> Maybe (FL p C(y z))+ where r :: (MyEq p, Commute p) => p wX wY -> [(p:>FL p) wX wZ] -> Maybe (FL p wY wZ) r _ [] = Nothing r z ((z':>zs):zss) | IsEq <- z =\/= z' = Just zs | otherwise = r z zss -- | 'removeRL' is like 'removeFL' except with 'RL'-removeRL :: (MyEq p, Commute p) => p C(y z) -> RL p C(x z) -> Maybe (RL p C(x y))+removeRL :: (MyEq p, Commute p) => p wY wZ -> RL p wX wZ -> Maybe (RL p wX wY) removeRL x xs = r x $ headPermutationsRL xs- where r :: (MyEq p, Commute p) => p C(y z) -> [RL p C(x z)] -> Maybe (RL p C(x y))+ where r :: (MyEq p, Commute p) => p wY wZ -> [RL p wX wZ] -> Maybe (RL p wX wY) r z ((z':<:zs):zss) | IsEq <- z =/\= z' = Just zs | otherwise = r z zss r _ _ = Nothing@@ -156,27 +162,27 @@ -- @ab@ have been commuted out of it, if possible. If this is not possible -- for any reason (the set of patches @ab@ is not actually a subset of @abc@, -- or they can't be commuted out) we return 'Nothing'.-removeSubsequenceFL :: (MyEq p, Commute p) => FL p C(a b)- -> FL p C(a c) -> Maybe (FL p C(b c))+removeSubsequenceFL :: (MyEq p, Commute p) => FL p wA wB+ -> FL p wA wC -> Maybe (FL p wB wC) removeSubsequenceFL a b | lengthFL a > lengthFL b = Nothing | otherwise = rsFL a b- where rsFL :: (MyEq p, Commute p) => FL p C(a b) -> FL p C(a c) -> Maybe (FL p C(b c))+ where rsFL :: (MyEq p, Commute p) => FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC) rsFL NilFL ys = Just ys rsFL (x:>:xs) yys = removeFL x yys >>= removeSubsequenceFL xs -- | 'removeSubsequenceRL' is like @removeSubsequenceFL@ except that it works -- on 'RL'-removeSubsequenceRL :: (MyEq p, Commute p) => RL p C(ab abc)- -> RL p C(a abc) -> Maybe (RL p C(a ab))+removeSubsequenceRL :: (MyEq p, Commute p) => RL p wAb wAbc+ -> RL p wA wAbc -> Maybe (RL p wA wAb) removeSubsequenceRL a b | lengthRL a > lengthRL b = Nothing | otherwise = rsRL a b- where rsRL :: (MyEq p, Commute p) => RL p C(ab abc) -> RL p C(a abc) -> Maybe (RL p C(a ab))+ where rsRL :: (MyEq p, Commute p) => RL p wAb wAbc -> RL p wA wAbc -> Maybe (RL p wA wAb) rsRL NilRL ys = Just ys rsRL (x:<:xs) yys = removeRL x yys >>= removeSubsequenceRL xs -- | This is a minor variant of 'headPermutationsFL' with each permutation -- is simply returned as a 'FL'-simpleHeadPermutationsFL :: Commute p => FL p C(x y) -> [FL p C(x y)]+simpleHeadPermutationsFL :: Commute p => FL p wX wY -> [FL p wX wY] simpleHeadPermutationsFL ps = map (\ (x:>xs) -> x:>:xs) $ headPermutationsFL ps -- | 'headPermutationsFL' @p:>:ps@ returns all the permutations of the list@@ -195,7 +201,7 @@ -- > y :> X h a s t c k -- > s :> X h a y t c k -- > k :> X h a y s t c-headPermutationsFL :: Commute p => FL p C(x y) -> [(p :> FL p) C(x y)]+headPermutationsFL :: Commute p => FL p wX wY -> [(p :> FL p) wX wY] headPermutationsFL NilFL = [] headPermutationsFL (p:>:ps) = (p:>ps) : mapMaybe (swapfirstFL.(p:>)) (headPermutationsFL ps)@@ -205,7 +211,7 @@ -- | 'headPermutationsRL' is like 'headPermutationsFL', except that we -- operate on an 'RL' (in other words, we are pushing things to the end of a -- patch sequence instead of to the beginning).-headPermutationsRL :: Commute p => RL p C(x y) -> [RL p C(x y)]+headPermutationsRL :: Commute p => RL p wX wY -> [RL p wX wY] headPermutationsRL NilRL = [] headPermutationsRL (p:<:ps) = (p:<:ps) : mapMaybe (swapfirstRL.(p:<:)) (headPermutationsRL ps)@@ -216,66 +222,25 @@ instance (MyEq p, Commute p) => MyEq (FL p) where a =\/= b | lengthFL a /= lengthFL b = NotEq | otherwise = cmpSameLength a b- where cmpSameLength :: FL p C(x y) -> FL p C(x z) -> EqCheck C(y z)+ where cmpSameLength :: FL p wX wY -> FL p wX wZ -> EqCheck wY wZ cmpSameLength (x:>:xs) xys | Just ys <- removeFL x xys = cmpSameLength xs ys cmpSameLength NilFL NilFL = IsEq cmpSameLength _ _ = NotEq xs =/\= ys = reverseFL xs =/\= reverseFL ys -instance (Invert p, Commute p) => Invert (FL p) where- invert = reverseRL . invertFL- instance (MyEq p, Commute p) => MyEq (RL p) where unsafeCompare = bug "Buggy use of unsafeCompare on RL" a =/\= b | lengthRL a /= lengthRL b = NotEq | otherwise = cmpSameLength a b- where cmpSameLength :: RL p C(x y) -> RL p C(w y) -> EqCheck C(x w)+ where cmpSameLength :: RL p wX wY -> RL p wW wY -> EqCheck wX wW cmpSameLength (x:<:xs) xys | Just ys <- removeRL x xys = cmpSameLength xs ys cmpSameLength NilRL NilRL = IsEq cmpSameLength _ _ = NotEq xs =\/= ys = reverseRL xs =\/= reverseRL ys -instance (Commute p, Invert p) => Invert (RL p) where- invert = reverseFL . invertRL---- |CommuteFn is the basis of a general framework for building up commutation--- operations between different patch types in a generic manner. Unfortunately--- type classes are not well suited to the problem because of the multiple possible--- routes by which the commuter for (FL p1, FL p2) can be built out of the--- commuter for (p1, p2) - and more complicated problems when we start building--- multiple constructors on top of each other. The type class resolution machinery--- really can't cope with selecting some route, because it doesn't know that all--- possible routes should be equivalent.-type CommuteFn p1 p2 = FORALL(x y) (p1 :> p2) C(x y) -> Maybe ((p2 :> p1) C(x y))---- |Build a commuter between a patch and itself using the operation from the type class.-selfCommuter :: Commute p => CommuteFn p p-selfCommuter = commute--commuterIdRL :: CommuteFn p1 p2 -> CommuteFn p1 (RL p2)-commuterIdRL _ (x :> NilRL) = return (NilRL :> x)-commuterIdRL commuter (x :> (y :<: ys))- = do ys' :> x' <- commuterIdRL commuter (x :> ys)- y' :> x'' <- commuter (x' :> y)- return ((y' :<: ys') :> x'')--commuterIdFL :: CommuteFn p1 p2 -> CommuteFn p1 (FL p2)-commuterIdFL _ (x :> NilFL) = return (NilFL :> x)-commuterIdFL commuter (x :> (y :>: ys))- = do y' :> x' <- commuter (x :> y)- ys' :> x'' <- commuterIdFL commuter (x' :> ys)- return ((y' :>: ys') :> x'')--commuterFLId :: CommuteFn p1 p2 -> CommuteFn (FL p1) p2-commuterFLId _ (NilFL :> y) = return (y :> NilFL)-commuterFLId commuter ((x :>: xs) :> y)- = do y' :> xs' <- commuterFLId commuter (xs :> y)- y'' :> x' <- commuter (x :> y')- return (y'' :> (x' :>: xs'))---- |Partition a list into the patches that commute with the given patch and those that don't (including dependencies)-partitionConflictingFL :: (Commute p1, Invert p1) => CommuteFn p1 p2 -> FL p1 C(x y) -> p2 C(x z) -> (FL p1 :> FL p1) C(x y)-partitionConflictingFL _ NilFL _ = (NilFL :> NilFL)+-- |Partition a list into the patches that merge with the given patch and those that don't (including dependencies)+partitionConflictingFL :: (Commute p1, Invert p1) => CommuteFn p1 p2 -> FL p1 wX wY -> p2 wX wZ -> (FL p1 :> FL p1) wX wY+partitionConflictingFL _ NilFL _ = NilFL :> NilFL partitionConflictingFL commuter (x :>: xs) y = case commuter (invert x :> y) of Nothing -> case commuteWhatWeCanFL (x :> xs) of@@ -285,3 +250,9 @@ Just (y' :> _) -> case partitionConflictingFL commuter xs y' of xs_clean :> xs_conflicts -> (x :>: xs_clean) :> xs_conflicts++inverseCommuter :: (Invert p, Invert q) => CommuteFn p q -> CommuteFn q p+inverseCommuter commuter (p :> q) =+ do invp' :> invq' <- commuter (invert q :> invert p)+ return (invert invq' :> invert invp')+
src/Darcs/Patch/Prim.hs view
@@ -4,7 +4,7 @@ primIsAddfile, primIsHunk, primIsBinary, primIsSetpref, primIsAdddir, is_filepatch, canonize, tryToShrink,- sortCoalesceFL, join, canonizeFL,+ sortCoalesceFL, coalesce, canonizeFL, tryShrinkingInverse, summarizePrim, applyPrimFL,
src/Darcs/Patch/Prim/Class.hs view
@@ -11,23 +11,29 @@ import Darcs.Patch.ApplyMonad ( ApplyMonad ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.FileHunk ( FileHunk, IsHunk )-import Darcs.Patch.FileName ( FileName )+import Darcs.Util.Path ( FileName ) import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) )+import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Patchy ( Patchy )+import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.ReadMonads ( ParserM ) import Darcs.Patch.Repair ( RepairToFL )+import Darcs.Patch.Show ( ShowPatch ) import Darcs.Patch.SummaryData ( SummDetail )-import Darcs.Witnesses.Ordered- ( FL(..), RL, (:>), mapFL, mapFL_FL, concatFL, reverseFL, concatRL )-import Darcs.Witnesses.Sealed ( Sealed )+import Darcs.Patch.Witnesses.Eq ( MyEq(..) )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), RL, (:>), mapFL, mapFL_FL, reverseFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed ) -import Printer ( Doc, vcat )+import Darcs.Util.Printer ( Doc, vcat )+import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) import qualified Data.ByteString as B ( ByteString ) -#include "gadts.h" -class (Patchy prim, PatchListFormat prim, IsHunk prim, RepairToFL prim+class (Patchy prim, MyEq prim+ ,PatchListFormat prim, IsHunk prim, RepairToFL prim+ ,PatchInspect prim, ReadPatch prim, ShowPatch prim ,PrimConstruct prim, PrimCanonize prim ,PrimClassify prim, PrimDetails prim ,PrimShow prim, PrimRead prim, PrimApply prim@@ -35,7 +41,7 @@ => PrimPatch prim class PrimPatch (PrimOf p) => PrimPatchBase p where- type PrimOf (p :: PATCHKIND) :: PATCHKIND+ type PrimOf (p :: (* -> * -> *)) :: (* -> * -> *) instance PrimPatchBase p => PrimPatchBase (FL p) where type PrimOf (FL p) = PrimOf p@@ -44,58 +50,65 @@ type PrimOf (RL p) = PrimOf p class FromPrim p where- fromPrim :: PrimOf p C(x y) -> p C(x y)+ fromPrim :: PrimOf p wX wY -> p wX wY class FromPrim p => ToFromPrim p where- toPrim :: p C(x y) -> Maybe (PrimOf p C(x y))+ toPrim :: p wX wY -> Maybe (PrimOf p wX wY) class FromPrims p where- fromPrims :: FL (PrimOf p) C(x y) -> p C(x y)- joinPatches :: FL p C(x y) -> p C(x y)+ fromPrims :: FL (PrimOf p) wX wY -> p wX wY instance FromPrim p => FromPrim (FL p) where fromPrim p = fromPrim p :>: NilFL instance FromPrim p => FromPrims (FL p) where fromPrims = mapFL_FL fromPrim- joinPatches = concatFL instance FromPrim p => FromPrims (RL p) where fromPrims = reverseFL . mapFL_FL fromPrim- joinPatches = concatRL . reverseFL class PrimClassify prim where- primIsAddfile :: prim C(x y) -> Bool- primIsRmfile :: prim C(x y) -> Bool- primIsAdddir :: prim C(x y) -> Bool- primIsRmdir :: prim C(x y) -> Bool- primIsMove :: prim C(x y) -> Bool- primIsHunk :: prim C(x y) -> Bool- primIsTokReplace :: prim C(x y) -> Bool- primIsBinary :: prim C(x y) -> Bool- primIsSetpref :: prim C(x y) -> Bool- is_filepatch :: prim C(x y) -> Maybe FileName+ primIsAddfile :: prim wX wY -> Bool+ primIsRmfile :: prim wX wY -> Bool+ primIsAdddir :: prim wX wY -> Bool+ primIsRmdir :: prim wX wY -> Bool+ primIsMove :: prim wX wY -> Bool+ primIsHunk :: prim wX wY -> Bool+ primIsTokReplace :: prim wX wY -> Bool+ primIsBinary :: prim wX wY -> Bool+ primIsSetpref :: prim wX wY -> Bool+ is_filepatch :: prim wX wY -> Maybe FileName class PrimConstruct prim where- addfile :: FilePath -> prim C(x y)- rmfile :: FilePath -> prim C(x y)- adddir :: FilePath -> prim C(x y)- rmdir :: FilePath -> prim C(x y)- move :: FilePath -> FilePath -> prim C(x y)- changepref :: String -> String -> String -> prim C(x y)- hunk :: FilePath -> Int -> [B.ByteString] -> [B.ByteString] -> prim C(x y)- tokreplace :: FilePath -> String -> String -> String -> prim C(x y)- binary :: FilePath -> B.ByteString -> B.ByteString -> prim C(x y)- primFromHunk :: FileHunk C(x y) -> prim C(x y)- anIdentity :: prim C(x x)+ addfile :: FilePath -> prim wX wY+ rmfile :: FilePath -> prim wX wY+ adddir :: FilePath -> prim wX wY+ rmdir :: FilePath -> prim wX wY+ move :: FilePath -> FilePath -> prim wX wY+ changepref :: String -> String -> String -> prim wX wY+ hunk :: FilePath -> Int -> [B.ByteString] -> [B.ByteString] -> prim wX wY+ tokreplace :: FilePath -> String -> String -> String -> prim wX wY+ binary :: FilePath -> B.ByteString -> B.ByteString -> prim wX wY+ primFromHunk :: FileHunk wX wY -> prim wX wY+ anIdentity :: prim wX wX class PrimCanonize prim where- tryToShrink :: FL prim C(x y) -> FL prim C(x y)- tryShrinkingInverse :: FL prim C(x y) -> Maybe (FL prim C(x y))+ -- | @tryToShrink ps@ simplifies @ps@ by getting rid of self-cancellations+ -- or coalescing patches+ --+ -- Question (Eric Kow): what properties should this have? For example,+ -- the prim1 implementation only gets rid of the first self-cancellation+ -- it finds (as far as I can tell). Is that OK? Can we try harder?+ tryToShrink :: FL prim wX wY -> FL prim wX wY + -- | @tryShrinkingInverse ps@ deletes the first subsequence of+ -- primitive patches that is followed by the inverse subsequence,+ -- if one exists. If not, it returns @Nothing@+ tryShrinkingInverse :: FL prim wX wY -> Maybe (FL prim wX wY)+ -- | 'sortCoalesceFL' @ps@ coalesces as many patches in @ps@ as -- possible, sorting the results in some standard order.- sortCoalesceFL :: FL prim C(x y) -> FL prim C(x y)+ sortCoalesceFL :: FL prim wX wY -> FL prim wX wY -- | It can sometimes be handy to have a canonical representation of a given -- patch. We achieve this by defining a canonical form for each patch type,@@ -103,7 +116,7 @@ -- canonical form. This routine is used by the diff function to create an -- optimal patch (based on an LCS algorithm) from a simple hunk describing the -- old and new version of a file.- canonize :: prim C(x y) -> FL prim C(x y)+ canonize :: D.DiffAlgorithm -> prim wX wY -> FL prim wX wY -- | 'canonizeFL' @ps@ puts a sequence of primitive patches into -- canonical form. Even if the patches are just hunk patches,@@ -115,22 +128,22 @@ -- of the patches and is therefore not appropriate for use when -- working with already recorded patches (unless doing amend-record -- or the like).- canonizeFL :: FL prim C(x y) -> FL prim C(x y)+ canonizeFL :: D.DiffAlgorithm -> FL prim wX wY -> FL prim wX wY - join :: (prim :> prim) C(x y) -> Maybe (FL prim C(x y))+ coalesce :: (prim :> prim) wX wY -> Maybe (FL prim wX wY) class PrimDetails prim where- summarizePrim :: prim C(x y) -> [SummDetail]+ summarizePrim :: prim wX wY -> [SummDetail] class PrimShow prim where- showPrim :: FileNameFormat -> prim C(a b) -> Doc+ showPrim :: FileNameFormat -> prim wA wB -> Doc -showPrimFL :: PrimShow prim => FileNameFormat -> FL prim C(a b) -> Doc+showPrimFL :: PrimShow prim => FileNameFormat -> FL prim wA wB -> Doc showPrimFL f xs = vcat (mapFL (showPrim f) xs) class PrimRead prim where- readPrim :: ParserM m => FileNameFormat -> m (Sealed (prim C(x )))+ readPrim :: ParserM m => FileNameFormat -> m (Sealed (prim wX)) class PrimApply prim where- applyPrimFL :: ApplyMonad m (ApplyState prim) => FL prim C(x y) -> m ()+ applyPrimFL :: ApplyMonad m (ApplyState prim) => FL prim wX wY -> m ()
src/Darcs/Patch/Prim/V1/Apply.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-}+{-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V1.Apply () where import Darcs.Patch.Apply ( Apply(..) )@@ -10,24 +11,23 @@ DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.Prim.V1.Show ( showHunk ) -import Darcs.Patch.FileName ( fn2fp )+import Darcs.Util.Path ( fn2fp ) import Darcs.Patch.Format ( FileNameFormat(..) ) import Darcs.Patch.TokenReplace ( tryTokInternal ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) import Storage.Hashed.Tree( Tree ) -import Darcs.Witnesses.Ordered ( FL(..), mapFL_FL, spanFL, (:>)(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoercePStart )+import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, spanFL, (:>)(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart ) -import ByteStringUtils ( unlinesPS, breakAfterNthNewline, breakBeforeNthNewline, )-import Printer( renderString )+import Darcs.Util.ByteString ( unlinesPS, breakAfterNthNewline, breakBeforeNthNewline, )+import Darcs.Util.Printer( renderString, RenderMode(..) ) import qualified Data.ByteString as B ( ByteString, empty, null, concat ) import qualified Data.ByteString.Char8 as BC (pack, singleton, unpack) import Data.List ( intersperse ) -#include "gadts.h" #include "impossible.h" type FileContents = B.ByteString@@ -36,7 +36,7 @@ type ApplyState Prim = Tree apply (FP f RmFile) = mRemoveFile f apply (FP f AddFile) = mCreateFile f- apply p@(FP _ (Hunk _ _ _)) = applyPrimFL (p :>: NilFL)+ apply p@(FP _ (Hunk{})) = applyPrimFL (p :>: NilFL) apply (FP f (TokReplace t o n)) = mModifyFilePSs f doreplace where doreplace ls = case mapM (tryTokInternal t (BC.pack o) (BC.pack n)) ls of@@ -57,12 +57,12 @@ applyAndTryToFixFL (FP f RmFile) = do x <- mReadFilePS f mRemoveFile f- return $ case B.null x of- True -> Nothing- False -> Just ("WARNING: Fixing removal of non-empty file "++fn2fp f,- -- No need to coerce because the content- -- removal patch has freely decided contexts- FP f (Binary x B.empty) :>: FP f RmFile :>: NilFL )+ return $ if B.null x+ then Nothing+ else Just ("WARNING: Fixing removal of non-empty file "++fn2fp f,+ -- No need to coerce because the content+ -- removal patch has freely decided contexts+ FP f (Binary x B.empty) :>: FP f RmFile :>: NilFL ) applyAndTryToFixFL (FP f AddFile) = do exists <- mDoesFileExist f if exists@@ -87,22 +87,23 @@ instance PrimApply Prim where applyPrimFL NilFL = return ()- applyPrimFL ((FP f h@(Hunk _ _ _)):>:the_ps)+ applyPrimFL (FP f h@(Hunk{}):>:the_ps) = case spanFL f_hunk the_ps of (xs :> ps') -> do let foo = h :>: mapFL_FL (\(FP _ h') -> h') xs mModifyFilePS f $ hunkmod foo applyPrimFL ps'- where f_hunk (FP f' (Hunk _ _ _)) | f == f' = True+ where f_hunk (FP f' (Hunk{})) | f == f' = True f_hunk _ = False- hunkmod :: ApplyMonad m Tree => FL FilePatchType C(x y)+ hunkmod :: ApplyMonad m Tree => FL FilePatchType wX wY -> B.ByteString -> m B.ByteString hunkmod NilFL ps = return ps hunkmod (Hunk line old new:>:hs) ps = case applyHunkLines [(line,old,new)] ps of Just ps' -> hunkmod hs ps' Nothing -> fail $ "### Error applying:\n" ++- (renderString $ showHunk NewFormat f line old new) +++ renderString Encode+ (showHunk NewFormat f line old new) ++ "\n### to file " ++ fn2fp f ++ ":\n" ++ BC.unpack ps hunkmod _ _ = impossible applyPrimFL (p:>:ps) = do apply p@@ -138,7 +139,7 @@ else fail "applyHunkLines: Unexpected hunks" Just (shouldbeo, suffix) | shouldbeo /= unlinesPS (o++[B.empty]) ->- fail $ "applyHunkLines: Bad patch!"+ fail "applyHunkLines: Bad patch!" | null n -> do x <- applyHunkLines hs' suffix return [x]
src/Darcs/Patch/Prim/V1/Coalesce.hs view
@@ -1,14 +1,18 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V1.Coalesce () where import Prelude hiding ( pi )+import Control.Arrow ( second )+import Data.Maybe ( fromMaybe ) import Data.Map ( elems, fromListWith, mapWithKey ) -import qualified Data.ByteString as B (ByteString)+import qualified Data.ByteString as B (ByteString, empty) -import Darcs.Patch.FileName ( FileName, fp2fn )+import System.FilePath ( (</>) )+ import Darcs.Patch.Prim.Class ( PrimCanonize(..) ) import Darcs.Patch.Prim.V1.Commute () import Darcs.Patch.Prim.V1.Core@@ -16,42 +20,47 @@ , comparePrim, isIdentity ) import Darcs.Patch.Prim.V1.Show ()-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:<)(..)- , reverseRL, mapFL, mapFL_FL- , concatFL, lengthFL, (+>+) )-import Darcs.Witnesses.Sealed ( unseal, Sealed2(..), unsafeUnseal2- , Gap(..), unFreeLeft- )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )+import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), RL(..), (:>)(..), (:<)(..)+ , reverseRL, mapFL, mapFL_FL+ , concatFL, lengthFL, (+>+) )+import Darcs.Patch.Witnesses.Sealed+ ( unseal, Sealed2(..), unsafeUnseal2+ , Gap(..), unFreeLeft+ )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Commute ( Commute(..) ) -- import Darcs.Patch.Permutations () -- for Invert instance of FL-import Lcs ( getChanges ) -#include "gadts.h"+import Darcs.Util.Diff ( getChanges )+import qualified Darcs.Util.Diff as D ( DiffAlgorithm )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Path ( FileName, fp2fn )+ #include "impossible.h" --- | 'coalesce' @p2 :< p1@ tries to combine @p1@ and @p2@ into a single+-- | 'coalesceRev' @p2 :< p1@ tries to combine @p1@ and @p2@ into a single -- patch without intermediary changes. For example, two hunk patches -- modifying adjacent lines can be coalesced into a bigger hunk patch. -- Or a patch which moves file A to file B can be coalesced with a -- patch that moves file B into file C, yielding a patch that moves -- file A to file C.-coalesce :: (Prim :< Prim) C(x y) -> Maybe (FL Prim C(x y))-coalesce (FP f1 _ :< FP f2 _) | f1 /= f2 = Nothing-coalesce (p2 :< p1) | IsEq <- p2 =\/= invert p1 = Just NilFL-coalesce (FP f1 p1 :< FP _ p2) = fmap (:>: NilFL) $ coalesceFilePrim f1 (p1 :< p2) -- f1 = f2-coalesce (Move a b :< Move b' a') | a == a' = Just $ Move b' b :>: NilFL-coalesce (Move a b :< FP f AddFile) | f == a = Just $ FP b AddFile :>: NilFL-coalesce (Move a b :< DP f AddDir) | f == a = Just $ DP b AddDir :>: NilFL-coalesce (FP f RmFile :< Move a b) | b == f = Just $ FP a RmFile :>: NilFL-coalesce (DP f RmDir :< Move a b) | b == f = Just $ DP a RmDir :>: NilFL-coalesce (ChangePref p f1 t1 :< ChangePref p2 f2 t2) | p == p2 && t2 == f1 = Just $ ChangePref p f2 t1 :>: NilFL-coalesce _ = Nothing+coalesceRev :: (Prim :< Prim) wX wY -> Maybe (FL Prim wX wY)+coalesceRev (FP f1 _ :< FP f2 _) | f1 /= f2 = Nothing+coalesceRev (p2 :< p1) | IsEq <- p2 =\/= invert p1 = Just NilFL+coalesceRev (FP f1 p1 :< FP _ p2) = fmap (:>: NilFL) $ coalesceFilePrim f1 (p1 :< p2) -- f1 = f2+coalesceRev (Move a b :< Move b' a') | a == a' = Just $ Move b' b :>: NilFL+coalesceRev (Move a b :< FP f AddFile) | f == a = Just $ FP b AddFile :>: NilFL+coalesceRev (Move a b :< DP f AddDir) | f == a = Just $ DP b AddDir :>: NilFL+coalesceRev (FP f RmFile :< Move a b) | b == f = Just $ FP a RmFile :>: NilFL+coalesceRev (DP f RmDir :< Move a b) | b == f = Just $ DP a RmDir :>: NilFL+coalesceRev (ChangePref p f1 t1 :< ChangePref p2 f2 t2) | p == p2 && t2 == f1 = Just $ ChangePref p f2 t1 :>: NilFL+coalesceRev _ = Nothing -mapPrimFL :: (FORALL(x y) FL Prim C(x y) -> FL Prim C(x y))- -> FL Prim C(w z) -> FL Prim C(w z)+mapPrimFL :: (forall wX wY . FL Prim wX wY -> FL Prim wX wY)+ -> FL Prim wW wZ -> FL Prim wW wZ mapPrimFL f x = -- an optimisation; break the list up into independent sublists -- and apply f to each of them@@ -62,38 +71,37 @@ map (\ (a,b) -> (a,(b:))) sx Nothing -> f x where- unsealList :: [Sealed2 p] -> FL p C(a b)- unsealList [] = unsafeCoerceP NilFL- unsealList (y:ys) = unsafeUnseal2 y :>: unsealList ys+ unsealList :: [Sealed2 p] -> FL p wA wB+ unsealList = foldr ((:>:) . unsafeUnseal2) (unsafeCoerceP NilFL) toSimpleSealed :: Sealed2 Prim -> Maybe (FileName, Sealed2 Simple)- toSimpleSealed (Sealed2 p) = fmap (\(fn, s) -> (fn, Sealed2 s)) (toSimple p)+ toSimpleSealed (Sealed2 p) = fmap (second Sealed2) (toSimple p) -data Simple C(x y) = SFP !(FilePatchType C(x y)) | SDP !(DirPatchType C(x y))+data Simple wX wY = SFP !(FilePatchType wX wY) | SDP !(DirPatchType wX wY) | SCP String String String deriving ( Show ) -toSimple :: Prim C(x y) -> Maybe (FileName, Simple C(x y))+toSimple :: Prim wX wY -> Maybe (FileName, Simple wX wY) toSimple (FP a b) = Just (a, SFP b) toSimple (DP a AddDir) = Just (a, SDP AddDir) toSimple (DP _ RmDir) = Nothing -- ordering is trickier with rmdir present toSimple (Move _ _) = Nothing-toSimple (ChangePref a b c) = Just (fp2fn "_darcs/prefs/prefs", SCP a b c)+toSimple (ChangePref a b c) = Just (fp2fn $ darcsdir </> "prefs" </> "prefs", SCP a b c) -fromSimple :: FileName -> Simple C(x y) -> Prim C(x y)+fromSimple :: FileName -> Simple wX wY -> Prim wX wY fromSimple a (SFP b) = FP a b fromSimple a (SDP b) = DP a b fromSimple _ (SCP a b c) = ChangePref a b c -fromSimples :: FileName -> FL Simple C(x y) -> FL Prim C(x y)-fromSimples a bs = mapFL_FL (fromSimple a) bs+fromSimples :: FileName -> FL Simple wX wY -> FL Prim wX wY+fromSimples a = mapFL_FL (fromSimple a) -tryHarderToShrink :: FL Prim C(x y) -> FL Prim C(x y)-tryHarderToShrink x = tryToShrink2 $ maybe x id (tryShrinkingInverse x)+tryHarderToShrink :: FL Prim wX wY -> FL Prim wX wY+tryHarderToShrink x = tryToShrink2 $ fromMaybe x (tryShrinkingInverse x) -tryToShrink2 :: FL Prim C(x y) -> FL Prim C(x y)+tryToShrink2 :: FL Prim wX wY -> FL Prim wX wY tryToShrink2 psold = let ps = sortCoalesceFL psold ps_shrunk = shrinkABit ps@@ -102,25 +110,28 @@ then tryToShrink2 ps_shrunk else ps_shrunk -shrinkABit :: FL Prim C(x y) -> FL Prim C(x y)+-- | @shrinkABit ps@ tries to simplify @ps@ by one patch,+-- the first one we find that coalesces with its neighbour+shrinkABit :: FL Prim wX wY -> FL Prim wX wY shrinkABit NilFL = NilFL-shrinkABit (p:>:ps) =- case tryOne NilRL p ps of- Nothing -> p :>: shrinkABit ps- Just ps' -> ps'+shrinkABit (p:>:ps) = fromMaybe (p :>: shrinkABit ps) $ tryOne NilRL p ps -tryOne :: RL Prim C(w x) -> Prim C(x y) -> FL Prim C(y z)- -> Maybe (FL Prim C(w z))+-- | @tryOne acc p ps@ pushes @p@ as far down @ps@ as we can go+-- until we can either coalesce it with something or it can't+-- go any further. Returns @Just@ if we manage to get any+-- coalescing out of this+tryOne :: RL Prim wW wX -> Prim wX wY -> FL Prim wY wZ+ -> Maybe (FL Prim wW wZ) tryOne _ _ NilFL = Nothing tryOne sofar p (p1:>:ps) =- case coalesce (p1 :< p) of+ case coalesceRev (p1 :< p) of Just p' -> Just (reverseRL sofar +>+ p' +>+ ps) Nothing -> case commute (p :> p1) of Nothing -> Nothing Just (p1' :> p') -> tryOne (p1':<:sofar) p' ps -- | The heart of "sortCoalesceFL"-sortCoalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y)+sortCoalesceFL2 :: FL Prim wX wY -> FL Prim wX wY sortCoalesceFL2 NilFL = NilFL sortCoalesceFL2 (x:>:xs) | IsEq <- isIdentity x = sortCoalesceFL2 xs sortCoalesceFL2 (x:>:xs) = either id id $ pushCoalescePatch x $ sortCoalesceFL2 xs@@ -143,11 +154,11 @@ -- Also note that pushCoalescePatch is only ever used (and should -- only ever be used) as an internal function in in -- sortCoalesceFL2.-pushCoalescePatch :: Prim C(x y) -> FL Prim C(y z)- -> Either (FL Prim C(x z)) (FL Prim C(x z))+pushCoalescePatch :: Prim wX wY -> FL Prim wY wZ+ -> Either (FL Prim wX wZ) (FL Prim wX wZ) pushCoalescePatch new NilFL = Left (new:>:NilFL) pushCoalescePatch new ps@(p:>:ps')- = case coalesce (p :< new) of+ = case coalesceRev (p :< new) of Just (new' :>: NilFL) -> Right $ either id id $ pushCoalescePatch new' ps' Just NilFL -> Right ps' Just _ -> impossible -- coalesce either returns a singleton or empty@@ -160,14 +171,14 @@ Left r -> Left (p' :>: r) Nothing -> Left (new:>:ps) -coalesceFilePrim :: FileName -> (FilePatchType :< FilePatchType) C(x y)- -> Maybe (Prim C(x y))+coalesceFilePrim :: FileName -> (FilePatchType :< FilePatchType) wX wY+ -> Maybe (Prim wX wY) coalesceFilePrim f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) = coalesceHunk f line1 old1 new1 line2 old2 new2 -- Token replace patches operating right after (or before) AddFile (RmFile) -- is an identity patch, as far as coalescing is concerned.-coalesceFilePrim f (TokReplace _ _ _ :< AddFile) = Just $ FP f AddFile-coalesceFilePrim f (RmFile :< TokReplace _ _ _) = Just $ FP f RmFile+coalesceFilePrim f (TokReplace{} :< AddFile) = Just $ FP f AddFile+coalesceFilePrim f (RmFile :< TokReplace{}) = Just $ FP f RmFile coalesceFilePrim f (TokReplace t1 o1 n1 :< TokReplace t2 o2 n2) | t1 == t2 && n2 == o1 = Just $ FP f $ TokReplace t1 o2 n1 coalesceFilePrim f (Binary m n :< Binary o m')@@ -177,7 +188,7 @@ coalesceHunk :: FileName -> Int -> [B.ByteString] -> [B.ByteString] -> Int -> [B.ByteString] -> [B.ByteString]- -> Maybe (Prim C(x y))+ -> Maybe (Prim wX wY) coalesceHunk f line1 old1 new1 line2 old2 new2 | line1 == line2 && lengthold1 < lengthnew2 = if take lengthold1 new2 /= old1@@ -202,19 +213,18 @@ lengthnew2 = length new2 canonizeHunk :: Gap w- => FileName -> Int -> [B.ByteString] -> [B.ByteString]+ => D.DiffAlgorithm -> FileName -> Int -> [B.ByteString] -> [B.ByteString] -> w (FL Prim)-canonizeHunk f line old new- | null old || null new+canonizeHunk _ f line old new+ | null old || null new || old == [B.empty] || new == [B.empty] = freeGap (FP f (Hunk line old new) :>: NilFL)-canonizeHunk f line old new = makeHoley f line $ getChanges old new+canonizeHunk da f line old new = makeHoley f line $ getChanges da old new makeHoley :: Gap w => FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])] -> w (FL Prim)-makeHoley f line changes =- foldr (joinGap (:>:)) (emptyGap NilFL) $- map (\ (l,o,n) -> freeGap (FP f (Hunk (l+line) o n))) changes+makeHoley f line =+ foldr (joinGap (:>:) . (\(l,o,n) -> freeGap (FP f (Hunk (l+line) o n)))) (emptyGap NilFL) instance PrimCanonize Prim where tryToShrink = mapPrimFL tryHarderToShrink@@ -223,17 +233,15 @@ | IsEq <- invert x =\/= y = Just z | otherwise = case tryShrinkingInverse (y:>:z) of Nothing -> Nothing- Just yz' -> Just $ case tryShrinkingInverse (x:>:yz') of- Nothing -> x:>:yz'- Just xyz' -> xyz'+ Just yz' -> Just $ fromMaybe (x :>: yz') $ tryShrinkingInverse (x:>:yz') tryShrinkingInverse _ = Nothing sortCoalesceFL = mapPrimFL sortCoalesceFL2- canonize p | IsEq <- isIdentity p = NilFL- canonize (FP f (Hunk line old new)) = unseal unsafeCoercePEnd $ unFreeLeft $ canonizeHunk f line old new- canonize p = p :>: NilFL+ canonize _ p | IsEq <- isIdentity p = NilFL+ canonize da (FP f (Hunk line old new)) = unseal unsafeCoercePEnd $ unFreeLeft $ canonizeHunk da f line old new+ canonize _ p = p :>: NilFL -- Running canonize twice is apparently necessary to fix issue525; -- would be nice to understand why.- canonizeFL = concatFL . mapFL_FL canonize . sortCoalesceFL .- concatFL . mapFL_FL canonize- join (x :> y) = coalesce (y :< x)+ canonizeFL da = concatFL . mapFL_FL (canonize da) . sortCoalesceFL .+ concatFL . mapFL_FL (canonize da)+ coalesce (x :> y) = coalesceRev (y :< x)
src/Darcs/Patch/Prim/V1/Commute.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V1.Commute ( Perhaps(..) , subcommutes, WrappedCommuteFunction(..)@@ -7,13 +8,14 @@ import Prelude hiding ( pi ) import Control.Monad ( MonadPlus, msum, mzero, mplus )+import Control.Applicative ( Applicative(..), Alternative(..) ) import qualified Data.ByteString as B (ByteString, concat) import qualified Data.ByteString.Char8 as BC (pack) -import Darcs.Patch.FileName ( FileName, fn2fp, movedirfilename )-import Darcs.Witnesses.Ordered ( (:<)(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Util.Path ( FileName, fn2fp, movedirfilename )+import Darcs.Patch.Witnesses.Ordered ( (:<)(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Prim.V1.Core ( Prim(..), FilePatchType(..) ) import Darcs.Patch.Invert ( Invert(..) )@@ -22,7 +24,6 @@ import Darcs.Patch.TokenReplace ( tryTokInternal ) #include "impossible.h"-#include "gadts.h" isInDirectory :: FileName -> FileName -> Bool isInDirectory d f = iid (fn2fp d) (fn2fp f)@@ -35,21 +36,35 @@ data Perhaps a = Unknown | Failed | Succeeded a +instance Functor Perhaps where+ fmap _ Unknown = Unknown+ fmap _ Failed = Failed+ fmap f (Succeeded x) = Succeeded (f x)++instance Applicative Perhaps where+ pure = Succeeded+ _ <*> Failed = Failed+ _ <*> Unknown = Unknown+ Failed <*> _ = Failed+ Unknown <*> _ = Unknown+ Succeeded f <*> Succeeded x = Succeeded (f x)+ instance Monad Perhaps where (Succeeded x) >>= k = k x Failed >>= _ = Failed Unknown >>= _ = Unknown- Failed >> _ = Failed- (Succeeded _) >> k = k- Unknown >> k = k return = Succeeded fail _ = Unknown +instance Alternative Perhaps where+ empty = Unknown+ Unknown <|> ys = ys+ Failed <|> _ = Failed+ (Succeeded x) <|> _ = Succeeded x+ instance MonadPlus Perhaps where- mzero = Unknown- Unknown `mplus` ys = ys- Failed `mplus` _ = Failed- (Succeeded x) `mplus` _ = Succeeded x+ mzero = Unknown+ mplus = (<|>) toMaybe :: Perhaps a -> Maybe a toMaybe (Succeeded x) = Just x@@ -81,7 +96,7 @@ speedyCommute _other = Unknown everythingElseCommute :: CommuteFunction-everythingElseCommute x = eec x+everythingElseCommute = eec where eec :: CommuteFunction eec (ChangePref p f t :<p1) = Succeeded (unsafeCoerceP p1 :< ChangePref p f t)@@ -114,8 +129,7 @@ if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerceP p2) :< FP f1 (unsafeCoerceP p1) ) else commuteFP f1 (p1 :< p2) commuteFiledir (DP d1 p1 :< DP d2 p2) =- if (not $ isInDirectory d1 d2) && (not $ isInDirectory d2 d1) &&- d1 /= d2+ if not (isInDirectory d1 d2 || isInDirectory d2 d1) && d1 /= d2 then Succeeded ( DP d2 (unsafeCoerceP p2) :< DP d1 (unsafeCoerceP p1) ) else Failed commuteFiledir (DP d dp :< FP f fp) =@@ -144,7 +158,7 @@ commuteFiledir _ = Unknown -type CommuteFunction = FORALL(x y) (Prim :< Prim) C(x y) -> Perhaps ((Prim :< Prim) C(x y))+type CommuteFunction = forall wX wY . (Prim :< Prim) wX wY -> Perhaps ((Prim :< Prim) wX wY) newtype WrappedCommuteFunction = WrappedCommuteFunction { runWrappedCommuteFunction :: CommuteFunction } subcommutes :: [(String, WrappedCommuteFunction)]@@ -159,8 +173,8 @@ commuteFilepatches (FP f1 p1 :< FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :< p2) commuteFilepatches _ = Unknown -commuteFP :: FileName -> (FilePatchType :< FilePatchType) C(x y)- -> Perhaps ((Prim :< Prim) C(x y))+commuteFP :: FileName -> (FilePatchType :< FilePatchType) wX wY+ -> Perhaps ((Prim :< Prim) wX wY) commuteFP f (Hunk line1 [] [] :< p2) = seq f $ Succeeded (FP f (unsafeCoerceP p2) :< FP f (Hunk line1 [] [])) commuteFP f (p2 :< Hunk line1 [] []) =@@ -185,8 +199,8 @@ FP f (TokReplace t o n)) commuteFP _ _ = Unknown -commuteHunk :: FileName -> (FilePatchType :< FilePatchType) C(x y)- -> Maybe ((Prim :< Prim) C(x y))+commuteHunk :: FileName -> (FilePatchType :< FilePatchType) wX wY+ -> Maybe ((Prim :< Prim) wX wY) commuteHunk f (Hunk line2 old2 new2 :< Hunk line1 old1 new1) | seq f $ line1 + lengthnew1 < line2 = Just (FP f (Hunk line1 old1 new1) :<@@ -211,5 +225,5 @@ tryTokReplace :: String -> String -> String -> [B.ByteString] -> Maybe [B.ByteString]-tryTokReplace t o n mss =- mapM (fmap B.concat . tryTokInternal t (BC.pack o) (BC.pack n)) mss+tryTokReplace t o n =+ mapM (fmap B.concat . tryTokInternal t (BC.pack o) (BC.pack n))
src/Darcs/Patch/Prim/V1/Core.hs view
@@ -17,7 +17,6 @@ {-# LANGUAGE CPP #-} -#include "gadts.h" module Darcs.Patch.Prim.V1.Core ( Prim(..),@@ -31,28 +30,29 @@ import qualified Data.ByteString as B (ByteString) -import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, normPath )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Util.Path ( FileName, fn2fp, fp2fn, normPath )+import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) ) import Darcs.Patch.Permutations () -- for Invert instance of FL import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimClassify(..) ) -data Prim C(x y) where- Move :: !FileName -> !FileName -> Prim C(x y)- DP :: !FileName -> !(DirPatchType C(x y)) -> Prim C(x y)- FP :: !FileName -> !(FilePatchType C(x y)) -> Prim C(x y)- ChangePref :: !String -> !String -> !String -> Prim C(x y)+data Prim wX wY where+ Move :: !FileName -> !FileName -> Prim wX wY+ DP :: !FileName -> !(DirPatchType wX wY) -> Prim wX wY+ FP :: !FileName -> !(FilePatchType wX wY) -> Prim wX wY+ ChangePref :: !String -> !String -> !String -> Prim wX wY -data FilePatchType C(x y) = RmFile | AddFile+data FilePatchType wX wY = RmFile | AddFile | Hunk !Int [B.ByteString] [B.ByteString] | TokReplace !String !String !String | Binary B.ByteString B.ByteString deriving (Eq,Ord) -data DirPatchType C(x y) = RmDir | AddDir+data DirPatchType wX wY = RmDir | AddDir deriving (Eq,Ord) instance MyEq FilePatchType where@@ -61,7 +61,7 @@ instance MyEq DirPatchType where unsafeCompare a b = a == unsafeCoerceP b -isIdentity :: Prim C(x y) -> EqCheck C(x y)+isIdentity :: Prim wX wY -> EqCheck wX wY isIdentity (FP _ (Binary old new)) | old == new = unsafeCoerceP IsEq isIdentity (FP _ (Hunk _ old new)) | old == new = unsafeCoerceP IsEq isIdentity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerceP IsEq@@ -148,6 +148,8 @@ hunkMatches _ (ChangePref _ _ _) = False hunkMatches _ (Move _ _) = False +instance PatchDebug Prim+ instance MyEq Prim where unsafeCompare (Move a b) (Move c d) = a == c && b == d unsafeCompare (DP d1 p1) (DP d2 p2)@@ -158,14 +160,14 @@ = c1 == c2 && b1 == b2 && a1 == a2 unsafeCompare _ _ = False -instance Eq (Prim C(x y)) where+instance Eq (Prim wX wY) where (==) = unsafeCompare -- | 'comparePrim' @p1 p2@ is used to provide an arbitrary ordering between -- @p1@ and @p2@. Basically, identical patches are equal and -- @Move < DP < FP < ChangePref@. -- Everything else is compared in dictionary order of its arguments.-comparePrim :: Prim C(x y) -> Prim C(w z) -> Ordering+comparePrim :: Prim wX wY -> Prim wW wZ -> Ordering comparePrim (Move a b) (Move c d) = compare (a, b) (c, d) comparePrim (Move _ _) _ = LT comparePrim _ (Move _ _) = GT
src/Darcs/Patch/Prim/V1/Details.hs view
@@ -9,15 +9,14 @@ ( Prim(..), FilePatchType(..), DirPatchType(..) ) import Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) ) -#include "gadts.h" instance PrimDetails Prim where summarizePrim (FP f (Hunk _ o n)) = [SummFile SummMod f (length o) (length n) 0] summarizePrim (FP f (Binary _ _)) = [SummFile SummMod f 0 0 0] summarizePrim (FP f AddFile) = [SummFile SummAdd f 0 0 0] summarizePrim (FP f RmFile) = [SummFile SummRm f 0 0 0]- summarizePrim (FP f (TokReplace _ _ _)) = [SummFile SummMod f 0 0 1]+ summarizePrim (FP f (TokReplace{})) = [SummFile SummMod f 0 0 1] summarizePrim (DP d AddDir) = [SummAddDir d] summarizePrim (DP d RmDir) = [SummRmDir d] summarizePrim (Move f1 f2) = [SummMv f1 f2]- summarizePrim (ChangePref _ _ _) = [SummNone]+ summarizePrim (ChangePref{}) = [SummNone]
src/Darcs/Patch/Prim/V1/Read.hs view
@@ -6,7 +6,7 @@ ( Prim(..), DirPatchType(..), FilePatchType(..) ) -import Darcs.Patch.FileName ( fn2fp )+import Darcs.Util.Path ( fn2fp ) import Darcs.Patch.Format ( FileNameFormat(..) ) import Darcs.Patch.Read ( ReadPatch(..), readFileName ) import Darcs.Patch.ReadMonads (ParserM, takeTillChar,@@ -15,15 +15,14 @@ anyChar, char, myLex', skipSpace, skipWhile, linesStartingWith) -import Darcs.Witnesses.Sealed ( seal )+import Darcs.Patch.Witnesses.Sealed ( seal ) -import ByteStringUtils ( fromHex2PS )+import Darcs.Util.ByteString ( fromHex2PS ) import Control.Monad ( liftM ) import qualified Data.ByteString as B ( ByteString, init, tail, concat ) import qualified Data.ByteString.Char8 as BC ( unpack, pack ) -#include "gadts.h" instance ReadPatch Prim where readPatch' = readPrim OldFormat@@ -39,7 +38,7 @@ , return' $ readRmDir x , return' $ readTok x , return' $ readBinary x- , return' $ readChangePref+ , return' readChangePref ] where return' = liftM seal@@ -71,7 +70,7 @@ changepref :: B.ByteString changepref = BC.pack "changepref" -readHunk :: ParserM m => FileNameFormat -> m (Prim C(x y))+readHunk :: ParserM m => FileNameFormat -> m (Prim wX wY) readHunk x = do string hunk' fi <- myLex'@@ -88,7 +87,7 @@ skipNewline :: ParserM m => m Bool skipNewline = option False (char '\n' >> return True) -readTok :: ParserM m => FileNameFormat -> m (Prim C(x y))+readTok :: ParserM m => FileNameFormat -> m (Prim wX wY) readTok x = do string replace f <- myLex'@@ -111,7 +110,7 @@ -- > newhex -- > *HEXHEXHEX -- > ...-readBinary :: ParserM m => FileNameFormat -> m (Prim C(x y))+readBinary :: ParserM m => FileNameFormat -> m (Prim wX wY) readBinary x = do string binary' fi <- myLex'@@ -125,23 +124,23 @@ (fromHex2PS $ B.concat old) (fromHex2PS $ B.concat new) -readAddFile :: ParserM m => FileNameFormat -> m (Prim C(x y))+readAddFile :: ParserM m => FileNameFormat -> m (Prim wX wY) readAddFile x = do string addfile f <- myLex' return $ FP (readFileName x f) AddFile -readRmFile :: ParserM m => FileNameFormat -> m (Prim C(x y))+readRmFile :: ParserM m => FileNameFormat -> m (Prim wX wY) readRmFile x = do string rmfile f <- myLex' return $ FP (readFileName x f) RmFile -readMove :: ParserM m => FileNameFormat -> m (Prim C(x y))+readMove :: ParserM m => FileNameFormat -> m (Prim wX wY) readMove x = do string move d <- myLex' d' <- myLex' return $ Move (readFileName x d) (readFileName x d') -readChangePref :: ParserM m => m (Prim C(x y))+readChangePref :: ParserM m => m (Prim wX wY) readChangePref = do string changepref p <- myLex'@@ -152,12 +151,12 @@ t <- takeTillChar '\n' return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t) -readAddDir :: ParserM m => FileNameFormat -> m (Prim C(x y))+readAddDir :: ParserM m => FileNameFormat -> m (Prim wX wY) readAddDir x = do string adddir f <- myLex' return $ DP (readFileName x f) AddDir -readRmDir :: ParserM m => FileNameFormat -> m (Prim C(x y))+readRmDir :: ParserM m => FileNameFormat -> m (Prim wX wY) readRmDir x = do string rmdir f <- myLex' return $ DP (readFileName x f) RmDir
src/Darcs/Patch/Prim/V1/Show.hs view
@@ -1,19 +1,19 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE ViewPatterns, UndecidableInstances #-} -- XXX Undecidable only in GHC < 7+{-# LANGUAGE ViewPatterns #-} module Darcs.Patch.Prim.V1.Show ( showHunk ) where import Prelude hiding ( pi ) -import ByteStringUtils ( fromPS2Hex )+import Darcs.Util.ByteString ( fromPS2Hex ) import qualified Data.ByteString as B (ByteString, length, take, drop) import qualified Data.ByteString.Char8 as BC (head) import Storage.Hashed.Tree( Tree ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..), showFileHunk )-import Darcs.Patch.FileName ( FileName )+import Darcs.Util.Path ( FileName ) import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), formatFileName ) import Darcs.Patch.Apply( ApplyState )@@ -24,13 +24,13 @@ import Darcs.Patch.Prim.V1.Core ( Prim(..), FilePatchType(..), DirPatchType(..) ) import Darcs.Patch.Prim.V1.Details ()-import Darcs.Witnesses.Show ( appPrec, Show1(..), Show2(..), ShowDict(..) )-import Printer ( Doc, vcat,+import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(..) )+import Darcs.Util.Printer ( Doc, vcat, text, userchunk, invisibleText, invisiblePS, blueText, ($$), (<+>), (<>), )+import Darcs.Util.Show ( appPrec, BSWrapper(..) ) -#include "gadts.h" -- TODO this instance shouldn't really be necessary, as Prims aren't used generically instance PatchListFormat Prim@@ -45,7 +45,7 @@ summaryFL = plainSummaryPrims thing _ = "change" -instance Show (Prim C(x y)) where+instance Show (Prim wX wY) where showsPrec d (Move fn1 fn2) = showParen (d > appPrec) $ showString "Move " . showsPrec (appPrec + 1) fn1 . showString " " . showsPrec (appPrec + 1) fn2@@ -63,10 +63,10 @@ instance Show2 Prim where showDict2 = ShowDictClass -instance Show1 (Prim C(x)) where+instance Show1 (Prim wX) where showDict1 = ShowDictClass -instance Show (FilePatchType C(x y)) where+instance Show (FilePatchType wX wY) where showsPrec _ RmFile = showString "RmFile" showsPrec _ AddFile = showString "AddFile" showsPrec d (Hunk line old new) | all ((==1) . B.length) old && all ((==1) . B.length) new@@ -78,26 +78,21 @@ showsPrecC ss = showParen True $ showString "packStringLetters " . showsPrec (appPrec + 1) (map BC.head ss) showsPrec d (Hunk line old new) = showParen (d > appPrec) $ showString "Hunk " . showsPrec (appPrec + 1) line . showString " " .- showsPrec (appPrec + 1) old . showString " " .- showsPrec (appPrec + 1) new+ showsPrec (appPrec + 1) (map BSWrapper old) . showString " " .+ showsPrec (appPrec + 1) (map BSWrapper new) showsPrec d (TokReplace t old new) = showParen (d > appPrec) $ showString "TokReplace " . showsPrec (appPrec + 1) t . showString " " . showsPrec (appPrec + 1) old . showString " " . showsPrec (appPrec + 1) new -- this case may not work usefully showsPrec d (Binary old new) = showParen (d > appPrec) $ showString "Binary " .- showsPrec (appPrec + 1) old . showString " " .- showsPrec (appPrec + 1) new+ showsPrec (appPrec + 1) (BSWrapper old) . showString " " .+ showsPrec (appPrec + 1) (BSWrapper new) -instance Show (DirPatchType C(x y)) where+instance Show (DirPatchType wX wY) where showsPrec _ RmDir = showString "RmDir" showsPrec _ AddDir = showString "AddDir" -{--instance Show (Prim C(x y)) where- show p = renderString (showPrim p) ++ "\n"--}- instance PrimShow Prim where showPrim x (FP f AddFile) = showAddFile x f showPrim x (FP f RmFile) = showRmFile x f@@ -142,9 +137,9 @@ showBinary x f o n = blueText "binary" <+> formatFileName x f $$ invisibleText "oldhex"- $$ (vcat $ map makeprintable $ breakEvery 78 $ fromPS2Hex o)+ $$ vcat (map makeprintable $ breakEvery 78 $ fromPS2Hex o) $$ invisibleText "newhex"- $$ (vcat $ map makeprintable $ breakEvery 78 $ fromPS2Hex n)+ $$ vcat (map makeprintable $ breakEvery 78 $ fromPS2Hex n) where makeprintable ps = invisibleText "*" <> invisiblePS ps breakEvery :: Int -> B.ByteString -> [B.ByteString]
src/Darcs/Patch/Prim/V3/Apply.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-} module Darcs.Patch.Prim.V3.Apply ( ObjectMap(..) ) where import Darcs.Patch.Apply ( Apply(..) )@@ -15,18 +15,19 @@ -- import Darcs.Patch.ApplyMonad ( ApplyMonad(..) ) -import Darcs.Witnesses.Ordered ( FL(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..) ) import Storage.Hashed.Hash( Hash(..) ) -#include "gadts.h" #include "impossible.h" instance Apply Prim where type ApplyState Prim = ObjectMap- apply (Manifest id (dirid, name)) = editDirectory dirid (M.insert name id)+ apply (Manifest i (dirid, name)) = editDirectory dirid (M.insert name i) apply (Demanifest _ (dirid, name)) = editDirectory dirid (M.delete name)- apply (TextHunk id hunk) = editFile id (hunkEdit hunk)- apply (BinaryHunk id hunk) = editFile id (hunkEdit hunk)+ apply (TextHunk i hunk) = editFile i (hunkEdit hunk)+ apply (BinaryHunk i hunk) = editFile i (hunkEdit hunk)+ apply Identity = return ()+ apply (Move{}) = bug "apply for move not implemented" instance RepairToFL Prim where applyAndTryToFixFL p = apply p >> return Nothing@@ -38,20 +39,20 @@ instance ToTree ObjectMap -- TODO editObject :: (Monad m) => UUID -> (Maybe (Object m) -> Object m) -> (StateT (ObjectMap m) m) ()-editObject id edit = do load <- gets getObject- store <- gets putObject- obj <- lift $ load id- new <- lift $ store id $ edit obj- put new- return ()+editObject i edit = do load <- gets getObject+ store <- gets putObject+ obj <- lift $ load i+ new <- lift $ store i $ edit obj+ put new+ return () instance (Functor m, Monad m) => ApplyMonad (StateT (ObjectMap m) m) ObjectMap where type ApplyMonadBase (StateT (ObjectMap m) m) = m- editFile id edit = editObject id edit'+ editFile i edit = editObject i edit' where edit' (Just (Blob x _)) = Blob (edit `fmap` x) NoHash edit' (Just (Directory x)) = Directory x -- error? edit' Nothing = Blob (return $ edit "") NoHash- editDirectory id edit = editObject id edit'+ editDirectory i edit = editObject i edit' where edit' (Just (Directory x)) = Directory $ edit x edit' (Just (Blob x y)) = Blob x y -- error? edit' Nothing = Directory $ edit M.empty
src/Darcs/Patch/Prim/V3/Coalesce.hs view
@@ -2,17 +2,14 @@ module Darcs.Patch.Prim.V3.Coalesce () where import Darcs.Patch.Prim.Class ( PrimCanonize(..) )-import Darcs.Witnesses.Ordered( FL(..) )+import Darcs.Patch.Witnesses.Ordered( FL(..) ) import Darcs.Patch.Prim.V3.Core( Prim ) -#include "gadts.h"-#include "impossible.h"- -- TODO instance PrimCanonize Prim where tryToShrink = error "tryToShrink" tryShrinkingInverse _ = error "tryShrinkingInverse" sortCoalesceFL = id- canonize = (:>: NilFL)- canonizeFL = id- join = const Nothing+ canonize _ = (:>: NilFL)+ canonizeFL _ = id+ coalesce = const Nothing
src/Darcs/Patch/Prim/V3/Commute.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-overlapping-patterns #-}+{-# LANGUAGE CPP #-} module Darcs.Patch.Prim.V3.Commute ( CommuteMonad(..) ) where@@ -7,14 +8,13 @@ import qualified Data.ByteString as BS (length) -import Darcs.Witnesses.Ordered ( (:>)(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Prim.V3.Core ( Prim(..), Hunk(..), touches ) import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Permutations () -- for Invert instance of FL #include "impossible.h"-#include "gadts.h" class Monad m => CommuteMonad m where commuteFail :: m a@@ -40,22 +40,22 @@ | not (a `typematch` b) = commuteFail | otherwise = commuteOverlapping (a :> b) --- Commute patches that have actual overlap in terms of touched objects, and their types allow +-- Commute patches that have actual overlap in terms of touched objects, and their types allow commuteOverlapping :: (CommuteMonad m) => (Prim :> Prim) wX wY -> m ((Prim :> Prim) wX wY)-commuteOverlapping ((BinaryHunk a x) :> (BinaryHunk _ y)) =+commuteOverlapping (BinaryHunk a x :> BinaryHunk _ y) = do (y' :> x') <- commuteHunk (x :> y) return $ unsafeCoerceP (BinaryHunk a y' :> BinaryHunk a x')-commuteOverlapping ((TextHunk a x) :> (TextHunk _ y)) =+commuteOverlapping (TextHunk a x :> TextHunk _ y) = do (y' :> x') <- commuteHunk (x :> y) return $ unsafeCoerceP (TextHunk a y' :> TextHunk a x') commuteOverlapping _ = commuteFail -commuteHunk :: (CommuteMonad m) => (Hunk :> Hunk) C(x y) -> m ((Hunk :> Hunk) C(y x))-commuteHunk ((Hunk off1 old1 new1) :> (Hunk off2 old2 new2))+commuteHunk :: (CommuteMonad m) => (Hunk :> Hunk) wX wY -> m ((Hunk :> Hunk) wY wX)+commuteHunk (Hunk off1 old1 new1 :> Hunk off2 old2 new2) | off1 + lengthnew1 < off2 = return $ Hunk (off2 - lengthnew1 + lengthold1) old2 new2 :> Hunk off1 old1 new1 | off2 + lengthold2 < off1 =- return $ (Hunk off2 old2 new2) :> Hunk (off1 + lengthnew2 - lengthold2) old1 new1+ return $ Hunk off2 old2 new2 :> Hunk (off1 + lengthnew2 - lengthold2) old1 new1 | off1 + lengthnew1 == off2 && lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 = return $ Hunk (off2 - lengthnew1 + lengthold1) old2 new2 :> Hunk off1 old1 new1
src/Darcs/Patch/Prim/V3/Core.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings, StandaloneDeriving #-} -- Copyright (C) 2011 Petr Rockai --@@ -22,7 +22,6 @@ -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. -#include "gadts.h" module Darcs.Patch.Prim.V3.Core ( Prim(..), Hunk(..), UUID(..), Location, Object(..), touches, hunkEdit )@@ -30,7 +29,8 @@ import qualified Data.ByteString as BS -import Darcs.Witnesses.Eq ( MyEq(..) )+import Darcs.Patch.Witnesses.Eq ( MyEq(..) )+import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) ) import Darcs.Patch.FileHunk( IsHunk(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) )@@ -39,13 +39,20 @@ -- TODO: elaborate -data Hunk C(x y) where- Hunk :: !Int -> BS.ByteString -> BS.ByteString -> Hunk C(x y)+data Hunk wX wY where+ Hunk :: !Int -> BS.ByteString -> BS.ByteString -> Hunk wX wY+ deriving Show -invertHunk :: Hunk C(x y) -> Hunk C(y x)+instance Show1 (Hunk wX) where+ showDict1 = ShowDictClass++instance Show2 Hunk where+ showDict2 = ShowDictClass++invertHunk :: Hunk wX wY -> Hunk wY wX invertHunk (Hunk off old new) = Hunk off new old -hunkEdit :: Hunk C(x y) -> BS.ByteString -> BS.ByteString+hunkEdit :: Hunk wX wY -> BS.ByteString -> BS.ByteString hunkEdit (Hunk off old new) bs = case splice bs (off) (off + BS.length old) of x | x == old -> BS.concat [ BS.take off bs, new, BS.drop (off + BS.length old) bs ] | otherwise -> error $ "error applying hunk: " ++ show off ++ " " ++ show old ++ " "@@ -55,19 +62,27 @@ instance MyEq Hunk where unsafeCompare (Hunk i x y) (Hunk i' x' y') = i == i' && x == x' && y == y' -data Prim C(x y) where- BinaryHunk :: !UUID -> Hunk C(x y) -> Prim C(x y)- TextHunk :: !UUID -> Hunk C(x y) -> Prim C(x y)+data Prim wX wY where+ BinaryHunk :: !UUID -> Hunk wX wY -> Prim wX wY+ TextHunk :: !UUID -> Hunk wX wY -> Prim wX wY -- TODO: String is not the right type here. However, what it represents is -- a single file *name* (not a path). No slashes allowed, no "." and ".." -- allowed either.- Manifest :: !UUID -> Location -> Prim C(x y)- Demanifest :: !UUID -> Location -> Prim C(x y)- Move :: !UUID -> Location -> Location -> Prim C(x y)- Identity :: Prim C(x x)+ Manifest :: !UUID -> Location -> Prim wX wY+ Demanifest :: !UUID -> Location -> Prim wX wY+ Move :: !UUID -> Location -> Location -> Prim wX wY+ Identity :: Prim wX wX -touches :: Prim C(x y) -> [UUID]+deriving instance Show (Prim wX wY)++instance Show1 (Prim wX) where+ showDict1 = ShowDictClass++instance Show2 Prim where+ showDict2 = ShowDictClass++touches :: Prim wX wY -> [UUID] touches (BinaryHunk x _) = [x] touches (TextHunk x _) = [x] touches (Manifest _ (x, _)) = [x]@@ -129,5 +144,5 @@ unsafeCompare Identity Identity = True unsafeCompare _ _ = False -instance Eq (Prim C(x y)) where+instance Eq (Prim wX wY) where (==) = unsafeCompare
src/Darcs/Patch/Prim/V3/Details.hs view
@@ -6,7 +6,6 @@ import Darcs.Patch.Prim.Class ( PrimDetails(..) ) import Darcs.Patch.Prim.V3.Core ( Prim(..) ) -#include "gadts.h" -- TODO instance PrimDetails Prim where
src/Darcs/Patch/Prim/V3/Read.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns, OverloadedStrings #-}+{-# LANGUAGE CPP, ViewPatterns, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V3.Read () where import Darcs.Patch.Read ( ReadPatch(..) )@@ -6,7 +6,7 @@ import Darcs.Patch.Prim.Class( PrimRead(..) ) import Darcs.Patch.Prim.V3.Core( Prim(..), Hunk(..) ) import Darcs.Patch.Prim.V3.ObjectMap-import Darcs.Witnesses.Sealed( seal )+import Darcs.Patch.Witnesses.Sealed( seal ) import Control.Applicative ( (<$>) ) import Control.Monad ( liftM, liftM2 )@@ -14,6 +14,8 @@ import qualified Data.ByteString.Char8 as BC import Data.Char ( chr ) +#include "impossible.h"+ instance PrimRead Prim where readPrim _ = do skipSpace choice $ map (liftM seal) [@@ -49,4 +51,5 @@ _ -> error "malformed filename" decodeWhite (BC.uncons -> Just (c, cs)) = c `BC.cons` decodeWhite cs decodeWhite (BC.uncons -> Nothing) = BC.empty+decodeWhite _ = impossible
src/Darcs/Patch/Prim/V3/Show.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE ViewPatterns, OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module Darcs.Patch.Prim.V3.Show ( showHunk ) where@@ -16,10 +16,9 @@ import Darcs.Patch.Prim.Class ( PrimShow(..) ) import Darcs.Patch.Prim.V3.Core ( Prim(..), Hunk(..), UUID(..) ) import Darcs.Patch.Prim.V3.Details ()-import Darcs.Witnesses.Show ( Show1(..), Show2(..), ShowDict(..) )-import Printer ( renderString, text, packedString, blueText, (<+>), (<>), Doc )+import Darcs.Util.Printer ( text, packedString, blueText, (<+>), (<>), Doc ) -#include "gadts.h"+#include "impossible.h" -- TODO this instance shouldn't really be necessary, as Prims aren't used generically instance PatchListFormat Prim@@ -33,21 +32,13 @@ summaryFL = plainSummaryPrims thing _ = "change" -instance Show (Prim C(x y)) where- show = renderString . showPrim undefined--instance Show2 Prim where- showDict2 = ShowDictClass--instance Show1 (Prim C(x)) where- showDict1 = ShowDictClass- instance PrimShow Prim where showPrim _ (TextHunk u h) = showHunk "hunk" u h showPrim _ (BinaryHunk u h) = showHunk "binhunk" u h showPrim _ (Manifest f (d,p)) = showManifest "manifest" d f p showPrim _ (Demanifest f (d,p)) = showManifest "demanifest" d f p showPrim _ Identity = blueText "identity"+ showPrim _ (Move{}) = bug "show for move not implemented" showManifest :: String -> UUID -> UUID -> BC.ByteString -> Doc showManifest txt dir file path = blueText txt <+>@@ -55,7 +46,7 @@ formatUUID dir <+> packedString (encodeWhite path) -showHunk :: String -> UUID -> Hunk C(x y) -> Doc+showHunk :: String -> UUID -> Hunk wX wY -> Doc showHunk txt uid (Hunk off old new) = blueText txt <+> formatUUID uid <+> text (show off) <+>
+ src/Darcs/Patch/Progress.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP, GADTs #-}++module Darcs.Patch.Progress+ ( progressRL+ , progressFL+ , progressRLShowTags+ ) where++import System.IO.Unsafe ( unsafePerformIO )++import Darcs.Patch.Info ( justName, isTag )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), lengthRL, lengthFL )++import Darcs.Util.Progress ( minlist, beginTedious, endTedious, progress,+ progressKeepLatest, tediousSize, finishedOne )++startProgress :: a -> String -> Int -> a+startProgress x k len = unsafePerformIO $ do beginTedious k+ tediousSize k len+ return x++-- | Evaluate an 'FL' list and report progress.+progressFL :: String -> FL a wX wY -> FL a wX wY+progressFL _ NilFL = NilFL+progressFL k xxs@(x :>: xs) = if xxsLen < minlist+ then xxs+ else startProgress x k xxsLen :>: pl xs+ where+ xxsLen = lengthFL xxs++ pl :: FL a wX wY -> FL a wX wY+ pl NilFL = NilFL+ pl (y :>: NilFL) = unsafePerformIO $ do endTedious k+ return (y :>: NilFL)+ pl (y :>: ys) = progress k y :>: pl ys++-- | Evaluate an 'RL' list and report progress.+progressRL :: String -> RL a wX wY -> RL a wX wY+progressRL _ NilRL = NilRL+progressRL k xxs@(x :<: xs) =+ if xxsLen < minlist+ then xxs+ else startProgress x k xxsLen :<: pl xs+ where+ xxsLen = lengthRL xxs+ pl :: RL a wX wY -> RL a wX wY+ pl NilRL = NilRL+ pl (y:<:NilRL) = unsafePerformIO $ do endTedious k+ return (y:<:NilRL)+ pl (y:<:ys) = progress k y :<: pl ys++-- | Evaluate an 'RL' list and report progress. In addition to printing+-- the number of patches we got, show the name of the last tag we got.+progressRLShowTags :: String -> RL (PatchInfoAnd p) wX wY+ -> RL (PatchInfoAnd p) wX wY+progressRLShowTags _ NilRL = NilRL+progressRLShowTags k xxs@(x :<: xs) =+ if xxsLen < minlist+ then xxs+ else startProgress x k xxsLen :<: pl xs+ where+ xxsLen = lengthRL xxs++ pl :: RL (PatchInfoAnd p) wX wY -> RL (PatchInfoAnd p) wX wY+ pl NilRL = NilRL+ pl (y :<: NilRL) = unsafePerformIO $ do endTedious k+ return (y :<: NilRL)+ pl (y :<: ys) =+ if isTag iy+ then finishedOne k ("back to "++ justName iy) y :<: pl ys+ else progressKeepLatest k y :<: pl ys+ where+ iy = info y
src/Darcs/Patch/Read.hs view
@@ -25,37 +25,36 @@ import Prelude hiding ( pi ) -import ByteStringUtils ( dropSpace )+import Darcs.Util.ByteString ( dropSpace ) import qualified Data.ByteString as B (ByteString, null) import Darcs.Patch.Bracketed ( Bracketed(..), unBracketedFL )-import Darcs.Patch.FileName ( FileName, fp2fn, ps2fn, decodeWhite )+import Darcs.Util.Path ( FileName, fp2fn, ps2fn, decodeWhite ) import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) ) import Darcs.Patch.ReadMonads (ParserM, parseStrictly, choice, lexChar, lexString, checkConsumes ) -import Darcs.Witnesses.Ordered ( FL(..), RL, reverseFL )-import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL, reverseFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) import Control.Applicative ( (<$>), (<|>) ) import Control.Monad ( mzero ) import qualified Data.ByteString.Char8 as BC ( ByteString, unpack ) -#include "gadts.h" class ReadPatch p where readPatch'- :: ParserM m => m (Sealed (p C(x )))+ :: ParserM m => m (Sealed (p wX)) -readPatchPartial :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString)+readPatchPartial :: ReadPatch p => B.ByteString -> Maybe (Sealed (p wX), B.ByteString) readPatchPartial ps = case parseStrictly readPatch' ps of Just (p, ps') -> Just (p, ps') _ -> Nothing -readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )))+readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p wX)) readPatch ps = case readPatchPartial ps of Just (p, ps') | B.null (dropSpace ps') -> Just p@@ -78,7 +77,7 @@ = mapSeal unBracketedFL <$> readPatch' | otherwise = read_patches- where read_patches :: ParserM m => m (Sealed (FL p C(x )))+ where read_patches :: ParserM m => m (Sealed (FL p wX)) read_patches = do --tracePeek "starting FL read" -- checkConsumes is needed to make sure that something is read, -- to avoid stack overflow when parsing FL (FL p)@@ -95,11 +94,11 @@ readPatch' = mapSeal reverseFL <$> readPatch' {-# INLINE bracketedFL #-}-bracketedFL :: forall p m C(x) . (ParserM m) =>- (FORALL(y) m (Sealed (p C(y)))) -> Char -> Char -> m (Sealed (FL p C(x)))+bracketedFL :: forall p m wX . (ParserM m) =>+ (forall wY . m (Sealed (p wY))) -> Char -> Char -> m (Sealed (FL p wX)) bracketedFL parser pre post = peekforc pre bfl mzero- where bfl :: FORALL(z) m (Sealed (FL p C(z)))+ where bfl :: forall wZ . m (Sealed (FL p wZ)) bfl = peekforc post (return $ Sealed NilFL) (do Sealed p <- parser Sealed ps <- bfl
src/Darcs/Patch/ReadMonads.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} -- | 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.@@ -10,13 +9,14 @@ checkConsumes, linesStartingWith, linesStartingWithEndingWith) where -import ByteStringUtils ( dropSpace, breakSpace, breakFirstPS,+import Darcs.Util.ByteString ( dropSpace, breakSpace, breakFirstPS, readIntPS, breakLastPS ) import qualified Data.ByteString as B (null, drop, length, tail, empty, ByteString) import qualified Data.ByteString.Char8 as BC ( uncons, dropWhile, break , splitAt, length, head ) import Control.Applicative ( Alternative(..), Applicative(..), (<$>) )+import Data.Foldable ( asum ) import Control.Monad ( MonadPlus(..) ) -- | 'lexChar' checks if the next space delimited token from@@ -131,11 +131,11 @@ linesStartingWith' :: Char -> B.ByteString -> Maybe (ParserState [B.ByteString]) linesStartingWith' c thes = Just (lsw [] thes)- where lsw acc s | B.null s || BC.head s /= c = (reverse acc :*: s)+ where lsw acc s | B.null s || BC.head s /= c = reverse acc :*: s lsw acc s = let s' = B.tail s in case breakFirstPS '\n' s' of Just (l, r) -> lsw (l:acc) r- Nothing -> (reverse (s':acc) :*: B.empty)+ Nothing -> reverse (s':acc) :*: B.empty -- | This is a highly optimized way to read lines that start with a -- particular character, and stops when it reaches a particular |@@ -147,15 +147,13 @@ -- | Helper function for 'linesStartingWithEndingWith'. linesStartingWithEndingWith' :: Char -> Char -> B.ByteString -> Maybe (ParserState [B.ByteString])-linesStartingWithEndingWith' st en s = lswew s+linesStartingWithEndingWith' st en = lswew where- lswew x | B.null x = Nothing- lswew x =- if BC.head x == en- then Just ([] :*: B.tail x)- else if BC.head x /= st- then Nothing- else case BC.break ((==) '\n') $ B.tail x of+ lswew x+ | B.null x = Nothing+ | BC.head x == en = Just $ [] :*: B.tail x+ | BC.head x /= st = Nothing+ | otherwise = case BC.break ('\n' ==) $ B.tail x of (l,r) -> case lswew $ B.tail r of Just (ls :*: r') -> Just ((l:ls) :*: r') Nothing ->@@ -177,7 +175,7 @@ -- | Attempts each option until one succeeds. choice :: Alternative f => [f a] -> f a-choice = foldr (<|>) empty+choice = asum -- |Ensure that a parser consumes input when producing a result -- Causes the initial state of the input stream to be held on to while the@@ -242,7 +240,7 @@ fail = failSM instance ParserM SM where- work f = SM f+ work = SM maybeWork f = SM $ \s -> case f s of Just (x :*: s') -> Just (Just x :*: s') Nothing -> Just (Nothing :*: s)
+ src/Darcs/Patch/Rebase.hs view
@@ -0,0 +1,559 @@+-- Copyright (C) 2009 Ganesh Sittampalam+--+-- BSD3+{-# LANGUAGE CPP, GADTs, PatternGuards, TypeOperators, NoMonomorphismRestriction, ViewPatterns, UndecidableInstances #-}+module Darcs.Patch.Rebase+ ( Rebasing(..), RebaseItem(..), RebaseName(..), RebaseFixup(..)+ , simplifyPush, simplifyPushes+ , mkSuspended+ , takeHeadRebase, takeHeadRebaseFL, takeHeadRebaseRL+ , takeAnyRebase, takeAnyRebaseAndTrailingPatches+ , countToEdit+ ) where++import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Commute ( selfCommuter )+import Darcs.Patch.CommuteFn ( CommuteFn )+import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) )+import Darcs.Patch.Debug ( PatchDebug(..) )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Format ( PatchListFormat(..), ListFormat, copyListFormat )+import Darcs.Patch.Matchable ( Matchable )+import Darcs.Patch.MaybeInternal ( MaybeInternal(..), InternalChecker(..) )+import Darcs.Patch.Merge ( Merge(..) )+import Darcs.Patch.Named ( Named(..), patchcontents, namepatch+ , commuterIdNamed+ )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )+import Darcs.Patch.Patchy ( Invert(..), Commute(..), Patchy, Apply(..),+ ShowPatch(..), ReadPatch(..),+ PatchInspect(..)+ )+import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim(..), FromPrim(..), canonizeFL )+import Darcs.Patch.Read ( bracketedFL )+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )+import Darcs.Patch.Rebase.Name+ ( RebaseName(..)+ , commutePrimName, commuteNamePrim+ )+import Darcs.Patch.Rebase.NameHack ( NameHack(..) )+import Darcs.Patch.Rebase.Recontext ( RecontextRebase(..), RecontextRebase1(..), RecontextRebase2(..) )+import Darcs.Patch.Repair ( Check(..), RepairToFL(..) )+import Darcs.Patch.Set ( PatchSet(..) )+import Darcs.Patch.Show ( ShowPatchBasic(..) )+import Darcs.Patch.ReadMonads ( ParserM, lexString, myLex' )+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show+ ( Show1(..), Show2(..), showsPrec2+ , ShowDict(ShowDictClass), appPrec+ )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )+import Darcs.Util.IsoDate ( getIsoDateTime )+import Darcs.Util.Text ( formatParas )+import Darcs.Util.Printer ( vcat, text, blueText, ($$), (<+>) )++import Prelude hiding ( pi )+import Control.Applicative ( (<$>), (<|>) )+import Control.Arrow ( (***), second )+import Control.Monad ( when )+import Data.Maybe ( catMaybes )+import qualified Data.ByteString as B ( ByteString )+import qualified Data.ByteString.Char8 as BC ( pack )++#include "impossible.h"++{- Notes++Note [Rebase representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The entire rebase state is stored in a single Suspended patch.++This is both unnatural and inefficient:++ - Unnatural because the rebase state is not really a patch and+ treating it as one requires various hacks:++ - It has to be given a fake name: see mkSuspended++ - Since 'Named p' actually contains 'FL p', we have to+ assume/assert that the FL either contains a sequence of Normals+ or a single Suspended++ - When 'Named ps' commutes past 'Named (Suspended items :> NilFL)',+ we need to inject the name from 'Named ps' into 'items', which+ is a layering violation: see Darcs.Patch.Rebase.NameHack++ - We need to hide the patch in the UI: see Darcs.Patch.MaybeInternal++ - We need a conditional hook so that amend-record can change the+ Suspended patch itself: see Darcs.Patch.Rebase.Recontext+ (something like this might be necessary no matter what the+ representation)++ - Inefficient because we need to write the entire rebase state out+ each time, even though most operations will only affect a small+ portion near the beginning.++ - This also means that we need to commute the rebase patch back+ to the head of the repo lazily: we only do so when a rebase+ operation requires it. Otherwise, pulling in 100 patches+ would entail writing out the entire rebase patch to disk 100+ times.++The obvious alternative is to store the rebase state at the repository+level, using inventories in some appropriate way.++The main reason this wasn't done is that the repository handling code+is quite fragile and hard to modify safely.++Also, rebase relies heavily on witnesses to check correctness, and+the witnesses on the Repository type are not as reliable as those+on patch types, partly because of the cruft in the repository code,+and partly because it's inherently harder to track witnesses when+the objects being manipulated are stored on disk and being changed+imperatively.++If and when the repository code becomes easier to work with, rebase+should be changed accordingly.++-}++-- TODO: move some of the docs of types to individual constructors+-- once http://trac.haskell.org/haddock/ticket/43 is fixed.++-- |A patch that lives in a repository where a rebase is in+-- progress. Such a repository will consist of @Normal@ patches+-- along with exactly one @Suspended@ patch.+--+-- Most rebase operations will require the @Suspended@ patch+-- to be at the end of the repository.+--+-- @Normal@ represents a normal patch within a respository where a+-- rebase is in progress. @Normal p@ is given the same on-disk+-- representation as @p@, so a repository can be switched into+-- and out of rebasing mode simply by adding or removing a+-- @Suspended@ patch and setting the appropriate format flag.+--+-- The single @Suspended@ patch contains the entire rebase+-- state, in the form of 'RebaseItem's.+--+-- Note that the witnesses are such that the @Suspended@+-- patch has no effect on the context of the rest of the+-- repository; in a sense the patches within it are+-- dangling off to one side from the main repository.+--+-- See Note [Rebase representation] in the source for a discussion+-- of the design choice to embed the rebase state in a single patch.+data Rebasing p wX wY where+ Normal :: p wX wY -> Rebasing p wX wY+ Suspended :: FL (RebaseItem p) wX wY -> Rebasing p wX wX++instance (Show2 p, Show2 (PrimOf p)) => Show (Rebasing p wX wY) where+ showsPrec d (Normal p) =+ showParen (d > appPrec) $ showString "Darcs.Patch.Rebase.Normal " . showsPrec2 (appPrec + 1) p+ showsPrec d (Suspended p) =+ showParen (d > appPrec) $ showString "Darcs.Patch.Rebase.Suspended " . showsPrec2 (appPrec + 1) p++instance (Show2 p, Show2 (PrimOf p)) => Show1 (Rebasing p wX) where+ showDict1 = ShowDictClass++instance (Show2 p, Show2 (PrimOf p)) => Show2 (Rebasing p) where+ showDict2 = ShowDictClass++-- |A single item in the rebase state consists of either+-- a patch that is being edited, or a fixup that adjusts+-- the context so that a subsequent patch that is being edited+-- \"makes sense\".+--+-- @ToEdit@ holds a patch that is being edited. The name ('PatchInfo') of+-- the patch will typically be the name the patch had before+-- it was added to the rebase state; if it is moved back+-- into the repository it must be given a fresh name to account+-- for the fact that it will not necessarily have the same+-- dependencies as the original patch. This is typically+-- done by changing the @Ignore-This@ junk.+--+-- @Fixup@ adjusts the context so that a subsequent @ToEdit@ patch+-- is correct. Where possible, @Fixup@ changes are commuted+-- as far as possible into the rebase state, so any remaining+-- ones will typically cause a conflict when the @ToEdit@ patch+-- is moved back into the repository.+data RebaseItem p wX wY where+ ToEdit :: Named p wX wY -> RebaseItem p wX wY+ Fixup :: RebaseFixup p wX wY -> RebaseItem p wX wY++instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY) where+ showsPrec d (ToEdit p) =+ showParen (d > appPrec) $ showString "ToEdit " . showsPrec2 (appPrec + 1) p+ showsPrec d (Fixup p) =+ showParen (d > appPrec) $ showString "Fixup " . showsPrec2 (appPrec + 1) p++instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX) where+ showDict1 = ShowDictClass++instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p) where+ showDict2 = ShowDictClass++countToEdit :: FL (RebaseItem p) wX wY -> Int+countToEdit NilFL = 0+countToEdit (ToEdit _ :>: ps) = 1 + countToEdit ps+countToEdit (_ :>: ps) = countToEdit ps++commuterRebasing :: (PrimPatchBase p, Commute p, Invert p, FromPrim p, Effect p)+ => D.DiffAlgorithm -> CommuteFn p p+ -> CommuteFn (Rebasing p) (Rebasing p)+commuterRebasing _ commuter (Normal p :> Normal q) = do+ q' :> p' <- commuter (p :> q)+ return (Normal q' :> Normal p')++-- Two rebases in sequence must have the same starting context,+-- so they should trivially commute.+-- This case shouldn't actually happen since each repo only has+-- a single Suspended patch.+commuterRebasing _ _ (p@(Suspended _) :> q@(Suspended _)) =+ return (q :> p)++commuterRebasing da _ (Normal p :> Suspended qs) =+ return (unseal Suspended (addFixup da p qs) :> Normal p)++commuterRebasing da _ (Suspended ps :> Normal q) =+ return (Normal q :> unseal Suspended (addFixup da (invert q) ps))+++instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Commute p) => Commute (Rebasing p) where+ commute = commuterRebasing D.MyersDiff commute++instance (PrimPatchBase p, FromPrim p, Effect p, Commute p) => NameHack (Rebasing p) where+ nameHack da = Just (pushIn . AddName, pushIn . DelName)+ where+ pushIn :: RebaseName p wX wX -> FL (Rebasing p) wX wY -> FL (Rebasing p) wX wY+ pushIn n (Suspended ps :>: NilFL) = unseal (\qs -> Suspended qs :>: NilFL) (simplifyPush da (NameFixup n) ps)+ pushIn _ ps = ps++instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Commute p, CommuteNoConflicts p) => CommuteNoConflicts (Rebasing p) where+ commuteNoConflicts = commuterRebasing D.MyersDiff commuteNoConflicts++instance (PrimPatchBase p, FromPrim p, Effect p, Invert p, Merge p) => Merge (Rebasing p) where+ merge (Normal p :\/: Normal q) = case merge (p :\/: q) of+ q' :/\: p' -> Normal q' :/\: Normal p'+ merge (p@(Suspended _) :\/: q@(Suspended _)) = q :/\: p+ merge (Normal p :\/: Suspended qs) = unseal Suspended (addFixup D.MyersDiff (invert p) qs) :/\: Normal p+ merge (Suspended ps :\/: Normal q) = Normal q :/\: unseal Suspended (addFixup D.MyersDiff (invert q) ps)++instance (PrimPatchBase p, PatchInspect p) => PatchInspect (Rebasing p) where+ listTouchedFiles (Normal p) = listTouchedFiles p+ listTouchedFiles (Suspended ps) = concat $ mapFL ltfItem ps+ where ltfItem :: RebaseItem p wX wY -> [FilePath]+ ltfItem (ToEdit q) = listTouchedFiles q+ ltfItem (Fixup (PrimFixup q)) = listTouchedFiles q+ ltfItem (Fixup (NameFixup _)) = []+ hunkMatches f (Normal p) = hunkMatches f p+ hunkMatches f (Suspended ps) = or $ mapFL hmItem ps+ where hmItem :: RebaseItem p wA wB -> Bool+ hmItem (ToEdit q) = hunkMatches f q+ hmItem (Fixup (PrimFixup q)) = hunkMatches f q+ hmItem (Fixup (NameFixup _)) = False++instance Invert p => Invert (Rebasing p) where+ invert (Normal p) = Normal (invert p)+ invert (Suspended ps) = Suspended ps -- TODO is this sensible?++instance Effect p => Effect (Rebasing p) where+ effect (Normal p) = effect p+ effect (Suspended _) = NilFL++instance (PrimPatchBase p, PatchListFormat p, Patchy p, FromPrim p, Conflict p, Effect p, CommuteNoConflicts p, IsHunk p)+ => Patchy (Rebasing p)++instance PatchDebug p => PatchDebug (Rebasing p)++instance ( PrimPatchBase p, PatchListFormat p, Patchy p+ , FromPrim p, Conflict p, Effect p+ , PatchInspect p+ , CommuteNoConflicts p, IsHunk p+ )+ => Matchable (Rebasing p)++instance (Conflict p, FromPrim p, Effect p, Invert p, Commute p) => Conflict (Rebasing p) where+ resolveConflicts (Normal p) = resolveConflicts p+ resolveConflicts (Suspended _) = []++instance Apply p => Apply (Rebasing p) where+ type ApplyState (Rebasing p) = ApplyState p+ apply (Normal p) = apply p+ apply (Suspended _) = return ()++instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Rebasing p) where+ showPatch (Normal p) = showPatch p+ showPatch (Suspended ps) = blueText "rebase" <+> text "0.0" <+> blueText "{"+ $$ vcat (mapFL showPatch ps)+ $$ blueText "}"++instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p)+ => ShowPatch (Rebasing p) where++ summary (Normal p) = summary p+ summary (Suspended ps) = summaryFL ps+ summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts++instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseItem p) where+ showPatch (ToEdit p) = blueText "rebase-toedit" <+> blueText "(" $$ showPatch p $$ blueText ")"+ showPatch (Fixup (PrimFixup p)) = blueText "rebase-fixup" <+> blueText "(" $$ showPatch p $$ blueText ")"+ showPatch (Fixup (NameFixup p)) = blueText "rebase-name" <+> blueText "(" $$ showPatch p $$ blueText ")"++instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p)+ => ShowPatch (RebaseItem p) where++ summary (ToEdit p) = summary p+ summary (Fixup (PrimFixup p)) = summary p+ summary (Fixup (NameFixup n)) = summary n+ summaryFL ps = vcat (mapFL summary ps) -- TODO sort out summaries properly, considering expected conflicts+++instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (RebaseItem p) where+ readPatch' = mapSeal ToEdit <$> readWith (BC.pack "rebase-toedit") <|>+ mapSeal (Fixup . PrimFixup) <$> readWith (BC.pack "rebase-fixup" ) <|>+ mapSeal (Fixup . NameFixup) <$> readWith (BC.pack "rebase-name" )+ where readWith :: forall m q wX . (ParserM m, ReadPatch q) => B.ByteString -> m (Sealed (q wX))+ readWith str = do lexString str+ lexString (BC.pack "(")+ res <- readPatch'+ lexString (BC.pack ")")+ return res++instance PrimPatchBase p => PrimPatchBase (Rebasing p) where+ type PrimOf (Rebasing p) = PrimOf p++instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (Rebasing p) where+ readPatch' =+ do lexString (BC.pack "rebase")+ version <- myLex'+ when (version /= BC.pack "0.0") $ error $ "can't handle rebase version " ++ show version+ (lexString (BC.pack "{}") >> return (seal (Suspended NilFL)))+ <|>+ (unseal (Sealed . Suspended) <$> bracketedFL readPatch' '{' '}')+ <|> mapSeal Normal <$> readPatch'++instance IsHunk p => IsHunk (Rebasing p) where+ isHunk (Normal p) = isHunk p+ isHunk (Suspended _) = Nothing++instance FromPrim p => FromPrim (Rebasing p) where+ fromPrim p = Normal (fromPrim p)++instance Check p => Check (Rebasing p) where+ isInconsistent (Normal p) = isInconsistent p+ isInconsistent (Suspended ps) =+ case catMaybes (mapFL isInconsistent ps) of+ [] -> Nothing+ xs -> Just (vcat xs)++instance Check p => Check (RebaseItem p) where+ isInconsistent (Fixup _) = Nothing+ isInconsistent (ToEdit p) = isInconsistent p++instance RepairToFL p => RepairToFL (Rebasing p) where+ applyAndTryToFixFL (Normal p) = fmap (second $ mapFL_FL Normal) <$> applyAndTryToFixFL p+ -- TODO: ideally we would apply ps in a sandbox to check the individual patches+ -- are consistent with each other.+ applyAndTryToFixFL (Suspended ps) =+ return . fmap (unlines *** ((:>: NilFL) . Suspended)) $ repairInternal ps++-- Just repair the internals of the patch, without applying it to anything+-- or checking against an external context.+-- Included for the internal implementation of applyAndTryToFixFL for Rebasing,+-- consider either generalising it for use everywhere, or removing once+-- the implementation works in a sandbox and thus can use the "full" Repair on the+-- contained patches.+class RepairInternalFL p where+ repairInternalFL :: p wX wY -> Maybe ([String], FL p wX wY)++class RepairInternal p where+ repairInternal :: p wX wY -> Maybe ([String], p wX wY)++instance RepairInternalFL p => RepairInternal (FL p) where+ repairInternal NilFL = Nothing+ repairInternal (x :>: ys) =+ case (repairInternalFL x, repairInternal ys) of+ (Nothing , Nothing) -> Nothing+ (Just (e, rxs), Nothing) -> Just (e , rxs +>+ ys )+ (Nothing , Just (e', rys)) -> Just (e' , x :>: rys)+ (Just (e, rxs), Just (e', rys)) -> Just (e ++ e', rxs +>+ rys)++instance RepairInternalFL (RebaseItem p) where+ repairInternalFL (ToEdit _) = Nothing+ repairInternalFL (Fixup p) = fmap (second $ mapFL_FL Fixup) $ repairInternalFL p++instance RepairInternalFL (RebaseFixup p) where+ repairInternalFL (PrimFixup _) = Nothing+ repairInternalFL (NameFixup _) = Nothing++instance PatchListFormat p => PatchListFormat (Rebasing p) where+ patchListFormat = copyListFormat (patchListFormat :: ListFormat p)++instance RepoPatch p => RepoPatch (Rebasing p)++instance (Commute p, PrimPatchBase p, FromPrim p, Effect p) => RecontextRebase (Rebasing p) where+ recontextRebase = Just (RecontextRebase1 recontext)+ where+ recontext :: forall wY wZ . Named (Rebasing p) wY wZ -> (EqCheck wY wZ, RecontextRebase2 (Rebasing p) wY wZ)++ recontext (patchcontents -> (Suspended ps :>: NilFL))+ = (IsEq, RecontextRebase2 (\fixups -> unseal mkSuspended(simplifyPushes D.MyersDiff (mapFL_FL translateFixup fixups) ps)))++ recontext _ = (NotEq, bug "trying to recontext rebase without rebase patch at head")++ translateFixup :: RebaseFixup (Rebasing p) wX wY -> RebaseFixup p wX wY+ translateFixup (PrimFixup p) = PrimFixup p+ translateFixup (NameFixup n) = NameFixup (translateName n)++ translateName :: RebaseName (Rebasing p) wX wY -> RebaseName p wX wY+ translateName (AddName name) = AddName name+ translateName (DelName name) = DelName name+ translateName (Rename old new) = Rename old new++instance MaybeInternal (Rebasing p) where+ patchInternalChecker = Just (InternalChecker rebaseIsInternal)+ where rebaseIsInternal :: FL (Rebasing p) wX wY -> EqCheck wX wY+ rebaseIsInternal (Suspended _ :>: NilFL) = IsEq+ rebaseIsInternal _ = NotEq++addFixup :: (PrimPatchBase p, Commute p, FromPrim p, Effect p) => D.DiffAlgorithm -> p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)+addFixup da p = simplifyPushes da (mapFL_FL PrimFixup (effect p))++canonizeNamePair :: (RebaseName p :> RebaseName p) wX wY -> FL (RebaseName p) wX wY+canonizeNamePair (AddName n :> Rename old new) | n == old = AddName new :>: NilFL+canonizeNamePair (Rename old new :> DelName n) | n == new = DelName old :>: NilFL+canonizeNamePair (Rename old1 new1 :> Rename old2 new2) | new1 == old2 = Rename old1 new2 :>: NilFL+canonizeNamePair (n1 :> n2) = n1 :>: n2 :>: NilFL++-- |Given a list of rebase items, try to push a new fixup as far as possible into+-- the list as possible, using both commutation and coalescing. If the fixup+-- commutes past all the 'ToEdit' patches then it is dropped entirely.+simplifyPush :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)+ => D.DiffAlgorithm -> RebaseFixup p wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)++simplifyPush _ _f NilFL = Sealed NilFL++simplifyPush da (PrimFixup f1) (Fixup (PrimFixup f2) :>: ps)+ | IsEq <- isInverse = Sealed ps+ | otherwise+ = case commute (f1 :> f2) of+ Nothing -> Sealed (mapFL_FL (Fixup . PrimFixup) (canonizeFL da (f1 :>: f2 :>: NilFL)) +>+ ps)+ Just (f2' :> f1') -> mapSeal (Fixup (PrimFixup f2') :>:) (simplifyPush da (PrimFixup f1') ps)+ where isInverse = invert f1 =\/= f2++simplifyPush da (PrimFixup f) (Fixup (NameFixup n) :>: ps)+ = case commutePrimName (f :> n) of+ n' :> f' -> mapSeal (Fixup (NameFixup n') :>:) (simplifyPush da (PrimFixup f') ps)++simplifyPush da (PrimFixup f) (ToEdit e :>: ps)+ = case commuterIdNamed selfCommuter (fromPrim f :> e) of+ Nothing -> Sealed (Fixup (PrimFixup f) :>: ToEdit e :>: ps)+ Just (e' :> f') -> mapSeal (ToEdit e' :>:) (simplifyPushes da (mapFL_FL PrimFixup (effect f')) ps)++simplifyPush da (NameFixup n1) (Fixup (NameFixup n2) :>: ps)+ | IsEq <- isInverse = Sealed ps+ | otherwise+ = case commute (n1 :> n2) of+ Nothing -> Sealed (mapFL_FL (Fixup . NameFixup) (canonizeNamePair (n1 :> n2)) +>+ ps)+ Just (n2' :> n1') -> mapSeal (Fixup (NameFixup n2') :>:) (simplifyPush da (NameFixup n1') ps)+ where isInverse = invert n1 =\/= n2++simplifyPush da (NameFixup n) (Fixup (PrimFixup f) :>: ps) =+ case commuteNamePrim (n :> f) of+ f' :> n' -> mapSeal (Fixup (PrimFixup f') :>:) (simplifyPush da (NameFixup n') ps)++simplifyPush da (NameFixup (AddName an)) (p@(ToEdit (NamedP pn deps _)) :>: ps)+ | an == pn = impossible+ | an `elem` deps = Sealed (Fixup (NameFixup (AddName an)) :>: p :>: ps)+ | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (AddName an)) ps)+simplifyPush da (NameFixup (DelName dn)) (p@(ToEdit (NamedP pn deps _)) :>: ps)+ -- this case can arise if a patch is suspended then a fresh copy is pulled from another repo+ | dn == pn = Sealed (Fixup (NameFixup (DelName dn)) :>: p :>: ps)+ | dn `elem` deps = impossible+ | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (DelName dn)) ps)+simplifyPush da (NameFixup (Rename old new)) (p@(ToEdit (NamedP pn deps body)) :>: ps)+ | old == pn = impossible+ | new == pn = impossible+ | old `elem` deps = impossible+ | new `elem` deps =+ let newdeps = map (\dep -> if new == dep then old else dep) deps+ in mapSeal (ToEdit (NamedP pn newdeps (unsafeCoerceP body)) :>:) (simplifyPush da (NameFixup (Rename old new)) ps)+ | otherwise = mapSeal (unsafeCoerceP p :>:) (simplifyPush da (NameFixup (Rename old new)) ps)++-- |Like 'simplifyPush' but for a list of fixups.+simplifyPushes :: (PrimPatchBase p, Commute p, FromPrim p, Effect p)+ => D.DiffAlgorithm -> FL (RebaseFixup p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)+simplifyPushes _ NilFL ps = Sealed ps+simplifyPushes da (f :>: fs) ps = unseal (simplifyPush da f) (simplifyPushes da fs ps)++mkSuspended :: FL (RebaseItem p) wX wY -> IO (Named (Rebasing p) wX wX)+mkSuspended ps = do+ let name = "DO NOT TOUCH: Rebase patch"+ let desc = formatParas 72+ ["This patch is an internal implementation detail of rebase, used to store suspended patches, " +++ "and should not be visible in the user interface. Please report a bug if a darcs " +++ "command is showing you this patch."]+ date <- getIsoDateTime+ let author = "Invalid <invalid@invalid>"+ namepatch date name author desc (Suspended ps :>: NilFL)++-- |given the repository contents, get the rebase container patch, and its contents+-- The rebase patch can be anywhere in the repository and is returned without being+-- commuted to the end.+takeAnyRebase :: PatchSet (Rebasing p) wA wB+ -> (Sealed2 (PatchInfoAnd (Rebasing p)),+ Sealed2 (FL (RebaseItem p)))+takeAnyRebase (PatchSet NilRL _) =+ -- it should never be behind a tag so we can stop now+ error "internal error: no suspended patch found"+takeAnyRebase (PatchSet (p :<: ps) pss)+ | Suspended rs :>: NilFL <- patchcontents (hopefully p) = (Sealed2 p, Sealed2 rs)+ | otherwise = takeAnyRebase (PatchSet ps pss)++-- |given the repository contents, get the rebase container patch, its contents, and the+-- rest of the repository contents. Commutes the patch to the end of the repository+-- if necessary. The rebase patch must be at the head of the repository.+takeAnyRebaseAndTrailingPatches+ :: PatchSet (Rebasing p) wA wB+ -> FlippedSeal (PatchInfoAnd (Rebasing p) :> RL (PatchInfoAnd (Rebasing p))) wB+takeAnyRebaseAndTrailingPatches (PatchSet NilRL _) =+ -- it should never be behind a tag so we can stop now+ error "internal error: no suspended patch found"+takeAnyRebaseAndTrailingPatches (PatchSet (p :<: ps) pss)+ | Suspended _ :>: NilFL <- patchcontents (hopefully p) = FlippedSeal (p :> NilRL)+ | otherwise = case takeAnyRebaseAndTrailingPatches (PatchSet ps pss) of+ FlippedSeal (r :> ps') -> FlippedSeal (r :> (p :<: ps'))++-- |given the repository contents, get the rebase container patch, its contents, and the+-- rest of the repository contents. The rebase patch must be at the head of the repository.+takeHeadRebase :: PatchSet (Rebasing p) wA wB+ -> (PatchInfoAnd (Rebasing p) wB wB,+ Sealed (FL (RebaseItem p) wB),+ PatchSet (Rebasing p) wA wB)+takeHeadRebase (PatchSet NilRL _) = error "internal error: must have a rebase container patch at end of repository"+takeHeadRebase (PatchSet (p :<: ps) pss)+ | Suspended rs :>: NilFL <- patchcontents (hopefully p) = (p, Sealed rs, PatchSet ps pss)+ | otherwise = error "internal error: must have a rebase container patch at end of repository"++takeHeadRebaseRL :: RL (PatchInfoAnd (Rebasing p)) wA wB+ -> (PatchInfoAnd (Rebasing p) wB wB,+ Sealed (FL (RebaseItem p) wB),+ RL (PatchInfoAnd (Rebasing p)) wA wB)+takeHeadRebaseRL NilRL = error "internal error: must have a suspended patch at end of repository"+takeHeadRebaseRL (p :<: ps)+ | Suspended rs :>: NilFL <- patchcontents (hopefully p) = (p, Sealed rs, ps)+ | otherwise = error "internal error: must have a suspended patch at end of repository"++takeHeadRebaseFL :: FL (PatchInfoAnd (Rebasing p)) wA wB+ -> (PatchInfoAnd (Rebasing p) wB wB,+ Sealed (FL (RebaseItem p) wB),+ FL (PatchInfoAnd (Rebasing p)) wA wB)+takeHeadRebaseFL ps = let (a, b, c) = takeHeadRebaseRL (reverseFL ps) in (a, b, reverseRL c)+
+ src/Darcs/Patch/Rebase/Fixup.hs view
@@ -0,0 +1,161 @@+-- Copyright (C) 2011-2 Ganesh Sittampalam +--+-- BSD3++{-# LANGUAGE UndecidableInstances #-}+module Darcs.Patch.Rebase.Fixup+ ( RebaseFixup(..)+ , commuteNamedFixup, commuteFixupNamed, commuteNamedFixups+ , flToNamesPrims+ ) where++import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute(..), selfCommuter )+import Darcs.Patch.CommuteFn ( totalCommuterIdFL )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.Prim ( FromPrim(..) )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Named ( Named(..), commuterNamedId, commuterIdNamed )+import Darcs.Patch.Prim ( PrimPatchBase, PrimOf )+import Darcs.Patch.Rebase.Name+ ( RebaseName+ , commuteNamedName, commuteNameNamed+ , commutePrimName, commuteNamePrim+ )+import Darcs.Patch.Witnesses.Eq ( MyEq(..) )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), mapFL_FL, (:>)(..), (+>+) )+import Darcs.Patch.Witnesses.Show+ ( Show1(..), Show2(..), showsPrec2+ , ShowDict(ShowDictClass), appPrec+ )++-- |A single rebase fixup, needed to ensure that the actual patches+-- being stored in the rebase state have the correct context.+data RebaseFixup p wX wY where+ PrimFixup :: PrimOf p wX wY -> RebaseFixup p wX wY+ NameFixup :: RebaseName p wX wY -> RebaseFixup p wX wY++instance Show2 (PrimOf p) => Show (RebaseFixup p wX wY) where+ showsPrec d (PrimFixup p) =+ showParen (d > appPrec) $ showString "PrimFixup " . showsPrec2 (appPrec + 1) p+ showsPrec d (NameFixup p) =+ showParen (d > appPrec) $ showString "NameFixup " . showsPrec2 (appPrec + 1) p++instance Show2 (PrimOf p) => Show1 (RebaseFixup p wX) where+ showDict1 = ShowDictClass++instance Show2 (PrimOf p) => Show2 (RebaseFixup p) where+ showDict2 = ShowDictClass++instance PrimPatchBase p => PrimPatchBase (RebaseFixup p) where+ type PrimOf (RebaseFixup p) = PrimOf p++instance (PrimPatchBase p, Apply p, ApplyState p ~ ApplyState (PrimOf p)) => Apply (RebaseFixup p) where+ type ApplyState (RebaseFixup p) = ApplyState p+ apply (PrimFixup p) = apply p+ apply (NameFixup p) = apply p++instance Effect (RebaseFixup p) where+ effect (PrimFixup p) = p :>: NilFL+ effect (NameFixup p) = effect p++instance MyEq (PrimOf p) => MyEq (RebaseFixup p) where+ PrimFixup p1 `unsafeCompare` PrimFixup p2 = p1 `unsafeCompare` p2+ PrimFixup _ `unsafeCompare` _ = False+ _ `unsafeCompare` PrimFixup _ = False++ NameFixup n1 `unsafeCompare` NameFixup n2 = n1 `unsafeCompare` n2+ -- NameFixup _ `unsafeCompare` _ = False+ -- _ `unsafeCompare` NameFixup _ = False++instance Invert (PrimOf p) => Invert (RebaseFixup p) where+ invert (PrimFixup p) = PrimFixup (invert p)+ invert (NameFixup n) = NameFixup (invert n)++instance PatchInspect (PrimOf p) => PatchInspect (RebaseFixup p) where+ listTouchedFiles (PrimFixup p) = listTouchedFiles p+ listTouchedFiles (NameFixup n) = listTouchedFiles n++ hunkMatches f (PrimFixup p) = hunkMatches f p+ hunkMatches f (NameFixup n) = hunkMatches f n++instance PrimPatchBase p => Commute (RebaseFixup p) where+ commute (PrimFixup p :> PrimFixup q) = do+ q' :> p' <- commute (p :> q)+ return (PrimFixup q' :> PrimFixup p')++ commute (NameFixup p :> NameFixup q) = do+ q' :> p' <- commute (p :> q)+ return (NameFixup q' :> NameFixup p')++ commute (PrimFixup p :> NameFixup q) = do+ q' :> p' <- return $ commutePrimName (p :> q)+ return (NameFixup q' :> PrimFixup p')++ commute (NameFixup p :> PrimFixup q) = do+ q' :> p' <- return $ commuteNamePrim (p :> q)+ return (PrimFixup q' :> NameFixup p')++-- |Split a sequence of fixups into names and prims+flToNamesPrims :: PrimPatchBase p+ => FL (RebaseFixup p) wX wY+ -> (FL (RebaseName p) :> FL (PrimOf p)) wX wY+flToNamesPrims NilFL = NilFL :> NilFL+flToNamesPrims (NameFixup n :>: fs) =+ case flToNamesPrims fs of+ names :> prims -> (n :>: names) :> prims+flToNamesPrims (PrimFixup p :>: fs) =+ case flToNamesPrims fs of+ names :> prims ->+ case totalCommuterIdFL commutePrimName (p :> names) of+ names' :> p' -> names' :> (p' :>: prims)++-- Note that this produces a list result because of the need to use effect to+-- extract the result.+-- Some general infrastructure for commuting p with PrimOf p would be helpful here,+commuteNamedPrim :: (FromPrim p, Effect p, Commute p)+ => (Named p :> PrimOf p) wX wY+ -> Maybe ((FL (PrimOf p) :> Named p) wX wY)+commuteNamedPrim (p :> q) = do+ q' :> p' <- commuterNamedId selfCommuter (p :> fromPrim q)+ return (effect q' :> p')++commutePrimNamed :: (FromPrim p, Effect p, Commute p)+ => (PrimOf p :> Named p) wX wY+ -> Maybe ((Named p :> FL (PrimOf p)) wX wY)+commutePrimNamed (p :> q) = do+ q' :> p' <- commuterIdNamed selfCommuter (fromPrim p :> q)+ return (q' :> effect p')++commuteNamedFixup :: (FromPrim p, Effect p, Commute p, Invert p)+ => (Named p :> RebaseFixup p) wX wY+ -> Maybe ((FL (RebaseFixup p) :> Named p) wX wY)+commuteNamedFixup (p :> PrimFixup q) = do+ qs' :> p' <- commuteNamedPrim (p :> q)+ return (mapFL_FL PrimFixup qs' :> p')+commuteNamedFixup (p :> NameFixup n) = do+ n' :> p' <- commuteNamedName (p :> n)+ return ((NameFixup n' :>: NilFL) :> p')+++commuteNamedFixups :: (FromPrim p, Effect p, Commute p, Invert p)+ => (Named p :> FL (RebaseFixup p)) wX wY+ -> Maybe ((FL (RebaseFixup p) :> Named p) wX wY)+commuteNamedFixups (p :> NilFL) = return (NilFL :> p)+commuteNamedFixups (p :> (q :>: rs)) = do+ qs' :> p' <- commuteNamedFixup (p :> q)+ rs' :> p'' <- commuteNamedFixups (p' :> rs)+ return ((qs' +>+ rs') :> p'')+++commuteFixupNamed :: (FromPrim p, Effect p, Commute p, Invert p)+ => (RebaseFixup p :> Named p) wX wY+ -> Maybe ((Named p :> FL (RebaseFixup p)) wX wY)+commuteFixupNamed (PrimFixup p :> q) = do+ q' :> ps' <- commutePrimNamed (p :> q)+ return (q' :> mapFL_FL PrimFixup ps')+commuteFixupNamed (NameFixup n :> q) = do+ q' :> n' <- commuteNameNamed (n :> q)+ return (q' :> (NameFixup n' :>: NilFL))
+ src/Darcs/Patch/Rebase/Name.hs view
@@ -0,0 +1,206 @@+-- Copyright (C) 2011-2 Ganesh Sittampalam+--+-- BSD3++{-# LANGUAGE CPP #-}+module Darcs.Patch.Rebase.Name+ ( RebaseName(..)+ , commuteNamePrim, commutePrimName+ , commuteNameNamed, commuteNamedName+ ) where++import Darcs.Patch.CommuteFn ( CommuteFn )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.Info ( PatchInfo, isInverted, showPatchInfo, readPatchInfo )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Named ( Named(..) )+import Darcs.Patch.Patchy+ ( Invert(..), Commute(..), Patchy, Apply(..)+ , ShowPatch(..), ReadPatch(..)+ )+import Darcs.Patch.Permutations ( inverseCommuter )+import Darcs.Patch.Prim ( PrimPatchBase, PrimOf )+import Darcs.Patch.ReadMonads ( lexString )+import Darcs.Patch.Show ( ShowPatchBasic(..) )+import Darcs.Patch.Witnesses.Eq ( MyEq(..) )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Show+ ( Show1(..), Show2(..)+ , ShowDict(ShowDictClass)+ )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )++import Darcs.Util.Printer ( empty, blueText, ($$) )++import Control.Applicative ( (<|>) )+import qualified Data.ByteString.Char8 as BC ( pack )++#include "impossible.h"++-- Note: in principle this is a general concept not limited to+-- rebase, and we might be able to generalise this type and+-- refactor named patches to use it too.+-- | A 'RebaseName' encapsulates the concept of the name of a patch,+-- without any contents. This allows us to track explicit dependencies+-- in the rebase state, changing them to follow uses of amend-record+-- or unsuspend on a depended-on patch, and warning the user if any+-- are lost entirely.+data RebaseName (p :: * -> * -> *) wX wY where+ AddName :: PatchInfo -> RebaseName p wX wY+ DelName :: PatchInfo -> RebaseName p wX wY+ Rename :: PatchInfo -> PatchInfo -> RebaseName p wX wY+ deriving Show++instance Show1 (RebaseName p wX) where+ showDict1 = ShowDictClass++instance Show2 (RebaseName p) where+ showDict2 = ShowDictClass++instance ShowPatchBasic (RebaseName p) where+ showPatch (AddName n) = blueText "addname" $$ showPatchInfo n+ showPatch (DelName n) = blueText "delname" $$ showPatchInfo n+ showPatch (Rename old new) = blueText "rename" $$ showPatchInfo old $$ showPatchInfo new++instance ShowPatch (RebaseName p) where+ summary _ = empty -- TODO improve this?+ summaryFL _ = empty++instance ReadPatch (RebaseName p) where+ readPatch' = readAddName <|> readDelName <|> readRename+ where+ readAddName = do lexString (BC.pack "addname")+ n <- readPatchInfo+ return (Sealed (AddName n))+ readDelName = do lexString (BC.pack "delname")+ n <- readPatchInfo+ return (Sealed (DelName n))+ readRename = do lexString (BC.pack "rename")+ old <- readPatchInfo+ new <- readPatchInfo+ return (Sealed (Rename old new))++instance Commute (RebaseName p) where+ commute (AddName n1 :> AddName n2)+ | n1 == n2 = impossible+ | otherwise = Just (AddName n2 :> AddName n1)+ commute (DelName n1 :> DelName n2)+ | n1 == n2 = impossible+ | otherwise = Just (DelName n2 :> DelName n1)+ commute (AddName n1 :> DelName n2)+ | n1 /= n2 = Just (DelName n2 :> AddName n1)+ | otherwise = Nothing+ commute (DelName n1 :> AddName n2)+ | n1 /= n2 = Just (AddName n2 :> DelName n1)+ | otherwise = Nothing+ commute (Rename old new :> AddName n)+ | n == old = Nothing+ | n == new = impossible -- precondition of Add is that n doesn't exist+ | otherwise = Just (AddName n :> Rename old new)+ commute (AddName n :> Rename old new)+ | n == old = Nothing+ | n == new = impossible -- precondition of Rename is that new doesn't exist+ | otherwise = Just (Rename old new :> AddName n)+ commute (Rename old new :> DelName n)+ | n == old = impossible -- precondition of Del is that n does exist+ | n == new = Nothing+ | otherwise = Just (DelName n :> Rename old new)+ commute (DelName n :> Rename old new)+ | n == old = impossible -- precondition of Rename is that old does exist+ | n == new = Nothing+ | otherwise = Just (Rename old new :> DelName n)+ commute (Rename old1 new1 :> Rename old2 new2)+ | old1 == old2 = impossible+ | new1 == new2 = impossible+ | old1 == new2 = Nothing+ | new1 == old2 = Nothing+ | otherwise = Just (Rename old2 new2 :> Rename old1 new1)++instance Invert (RebaseName p) where+ invert (AddName n) = DelName n+ invert (DelName n) = AddName n+ invert (Rename old new) = Rename new old++instance PatchInspect (RebaseName p) where+ listTouchedFiles _ = []+ hunkMatches _ _ = False++instance Apply p => Apply (RebaseName p) where+ type ApplyState (RebaseName p) = ApplyState p+ apply _ = return ()++instance Apply p => Patchy (RebaseName p)++instance PrimPatchBase p => PrimPatchBase (RebaseName p) where+ type PrimOf (RebaseName p) = PrimOf p++instance Effect (RebaseName p) where+ effect _ = unsafeCoerceP NilFL++instance MyEq (RebaseName p) where+ AddName n1 `unsafeCompare` AddName n2 = n1 == n2+ AddName _ `unsafeCompare` _ = False+ _ `unsafeCompare` AddName _ = False++ DelName n1 `unsafeCompare` DelName n2 = n1 == n2+ DelName _ `unsafeCompare` _ = False+ _ `unsafeCompare` DelName _ = False++ Rename old1 new1 `unsafeCompare` Rename old2 new2 = old1 == old2 && new1 == new2+ -- Rename _ _ `unsafeCompare` _ = False+ -- _ `unsafeCompare` Rename _ _ = False+++-- |Commute a name patch and a primitive patch. They trivially+-- commute so this just involves changing the witnesses.+commuteNamePrim :: PrimPatchBase p => (RebaseName p :> PrimOf p) wX wY -> (PrimOf p :> RebaseName p) wX wY+commuteNamePrim (n :> f) = unsafeCoerceP f :> unsafeCoerceP n++-- |Commute a primitive patch and a name patch. They trivially+-- commute so this just involves changing the witnesses.+commutePrimName :: PrimPatchBase p => (PrimOf p :> RebaseName p) wX wY -> (RebaseName p :> PrimOf p) wX wY+commutePrimName (f :> n) = unsafeCoerceP n :> unsafeCoerceP f++-- |Commute a name patch and a named patch. In most cases this is+-- trivial but we do need to check explicit dependencies.+commuteNameNamed :: Invert p => CommuteFn (RebaseName p) (Named p)+commuteNameNamed pair@(_ :> NamedP pn _ _)+ | isInverted pn = inverseCommuter commuteNamedName pair+commuteNameNamed (AddName an :> p@(NamedP pn deps _))+ | an == pn = impossible+ | an `elem` deps = Nothing+ | otherwise = Just (unsafeCoerceP p :> AddName an)+commuteNameNamed (DelName dn :> p@(NamedP pn deps _))+ | dn == pn = impossible+ | dn `elem` deps = impossible+ | otherwise = Just (unsafeCoerceP p :> DelName dn)+commuteNameNamed (Rename old new :> NamedP pn deps body)+ | old == pn = impossible+ | new == pn = impossible+ | old `elem` deps = impossible+ | otherwise =+ let newdeps = map (\dep -> if new == dep then old else dep) deps+ in Just (NamedP pn newdeps (unsafeCoerceP body) :> Rename old new)++-- |Commute a named patch and a name patch. In most cases this is+-- trivial but we do need to check explicit dependencies.+commuteNamedName :: Invert p => CommuteFn (Named p) (RebaseName p)+commuteNamedName pair@(NamedP pn _ _ :> _)+ | isInverted pn = inverseCommuter commuteNameNamed pair+commuteNamedName (p@(NamedP pn deps _) :> AddName an)+ | an == pn = impossible -- the NamedP introduces pn, then AddName introduces it again+ | an `elem` deps = impossible -- the NamedP depends on an before it is introduced+ | otherwise = Just (AddName an :> unsafeCoerceP p)+commuteNamedName (p@(NamedP pn deps _) :> DelName dn)+ | dn == pn = Nothing+ | dn `elem` deps = Nothing+ | otherwise = Just (DelName dn :> unsafeCoerceP p)+commuteNamedName (NamedP pn deps body :> Rename old new)+ | old == pn = Nothing+ | new == pn = impossible+ | new `elem` deps = impossible+ | otherwise =+ let newdeps = map (\dep -> if old == dep then new else dep) deps+ in Just (Rename old new :> NamedP pn newdeps (unsafeCoerceP body))+
+ src/Darcs/Patch/Rebase/NameHack.hs view
@@ -0,0 +1,23 @@+-- Copyright (C) 2009-2012 Ganesh Sittampalam+--+-- BSD3+module Darcs.Patch.Rebase.NameHack+ ( NameHack(..)+ ) where++import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Witnesses.Ordered ( FL )+import qualified Darcs.Util.Diff as D ( DiffAlgorithm )++-- |When commuting a @Normal@ patch past a @Suspended@ one, we need to adjust the+-- internals of the @Suspended@ one to take account of the effect of the @Normal@ patch.+-- This includes the name of the @Normal@ patch - but the layering is such that we+-- are actually commuting patches of type @Named (Rebasing p)@ - i.e. @Rebasing p@+-- doesn't actually contain the name. We therefore need to add a hook to the @Commute@+-- instances for @Named@ which @Rebasing@ can then implement.+--+-- There is a default so that other patch types only need to declare the instance.+class NameHack p where+ nameHack :: D.DiffAlgorithm -> Maybe (PatchInfo -> FL p wX wY -> FL p wX wY, PatchInfo -> FL p wW wZ -> FL p wW wZ)+ nameHack = \_ -> Nothing+
+ src/Darcs/Patch/Rebase/Recontext.hs view
@@ -0,0 +1,45 @@+-- Copyright (C) 2012 Ganesh Sittampalam+--+-- BSD3+module Darcs.Patch.Rebase.Recontext+ (+ RecontextRebase(..)+ , RecontextRebase1(..)+ , RecontextRebase2(..)+ ) where++import Darcs.Patch.Named ( Named )+import Darcs.Patch.Rebase.Fixup ( RebaseFixup )+import Darcs.Patch.Witnesses.Eq ( EqCheck )+import Darcs.Patch.Witnesses.Ordered ( FL )++-- |Check whether a given patch is a suspended rebase patch, and if so provide+-- evidence that the start and end contexts are the same (from the point of view+-- of the containing repo), and return a function that produces a new version+-- with some fixups added.+--+-- Nested in a type to avoid needing an impredicative argument to 'Maybe'.+newtype RecontextRebase1 p =+ RecontextRebase1 {+ recontextFunc1 :: forall wY wZ . Named p wY wZ -> (EqCheck wY wZ, RecontextRebase2 p wY wZ)+ }++-- |Return a suspended patch with the given fixups added.+--+-- Nested in a type to avoid needing an impredicative argument to a tuple.+newtype RecontextRebase2 p wY wZ =+ RecontextRebase2 {+ recontextFunc2 :: forall wX . FL (RebaseFixup p) wX wY -> IO (Named p wX wX)+ }++-- |Some non-rebase code needs to manipulate the rebase state if one exists.+-- This class provides the hook for them to do so without needing to explicitly+-- detect that there is a rebase state: 'recontextRebase' abstracts out that+-- information.+--+-- The hook is used in amend-record - look there for an explanation of how.+--+-- There is a default so that other patch types only need to declare the instance.+class RecontextRebase p where+ recontextRebase :: Maybe (RecontextRebase1 p)+ recontextRebase = Nothing
+ src/Darcs/Patch/Rebase/Viewing.hs view
@@ -0,0 +1,569 @@+-- Copyright (C) 2009 Ganesh Sittampalam+--+-- BSD3+{-# LANGUAGE CPP, GADTs, UndecidableInstances #-}+module Darcs.Patch.Rebase.Viewing+ ( RebaseSelect(..)+ , toRebaseSelect, fromRebaseSelect, extractRebaseSelect, reifyRebaseSelect+ , partitionUnconflicted+ , rsToNamed+ , WithDroppedDeps(..), WDDNamed, commuterIdWDD+ , RebaseChange(..), toRebaseChanges+ ) where++import Darcs.Patch.Commute ( selfCommuter )+import Darcs.Patch.CommuteFn ( CommuteFn, commuterIdFL, commuterRLId, MergeFn+ , totalCommuterIdFL+ )+import Darcs.Patch.Conflict+ ( Conflict(..), CommuteNoConflicts(..)+ , IsConflictedPrim+ )+import Darcs.Patch.Debug ( PatchDebug(..) )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Invert ( invertFL, invertRL )+import Darcs.Patch.Matchable ( Matchable )+import Darcs.Patch.MaybeInternal ( MaybeInternal(..) )+import Darcs.Patch.Merge ( Merge(..), selfMerger )+import Darcs.Patch.Named+ ( Named(..), namepatch, infopatch+ , mergerIdNamed+ , adddeps, getdeps+ , patch2patchinfo, patchcontents+ )++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )+import Darcs.Patch.Patchy ( Invert(..), Commute(..), Patchy, Apply(..),+ ShowPatch(..), ReadPatch(..),+ PatchInspect(..)+ )+import Darcs.Patch.Prim+ ( PrimPatch, PrimPatchBase, PrimOf, FromPrim(..), FromPrims(..)+ )+import Darcs.Patch.Rebase+ ( Rebasing(..), RebaseItem(..)+ )+import Darcs.Patch.Rebase.Fixup+ ( RebaseFixup(..)+ , commuteFixupNamed, commuteNamedFixups+ , flToNamesPrims+ )+import Darcs.Patch.Rebase.Name ( RebaseName(..) )+import Darcs.Patch.Rebase.NameHack ( NameHack(..) )+import Darcs.Patch.Show ( ShowPatchBasic(..) )+import Darcs.Patch.Summary ( plainSummary )+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show+ ( Show1(..), Show2(..), ShowDict(ShowDictClass)+ , showsPrec2+ )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )+import Darcs.Util.IsoDate ( getIsoDateTime )+import Darcs.Util.Printer ( ($$), redText, empty, vcat )+import Darcs.Util.Show ( appPrec )++import Prelude hiding ( pi )+import Control.Applicative ( (<$>) )+import Data.List ( nub, (\\) )+import Data.Maybe ( fromMaybe )++#include "impossible.h"++-- |Encapsulate a single patch in the rebase state together with its fixups.+-- Used during interactive selection to make sure that each item presented+-- to the user corresponds to a patch.+data RebaseSelect p wX wY where+ -- The normal case for a RebaseSelect - a patch that points forwards.+ RSFwd :: FL (RebaseFixup p) wX wY -> Named p wY wZ -> RebaseSelect p wX wZ+ -- We need an 'Invert' instance. We just represent inverses+ -- with a different constructor instead of trying to come up with some logical+ -- inversion of the individual components. Typically they get uninverted+ -- before anything significant is done with them, so a lot of code that+ -- processes 'RebaseSelect' patches just uses 'impossible' for 'RSRev'.+ RSRev :: FL (RebaseFixup p) wX wY -> Named p wY wZ -> RebaseSelect p wZ wX+++instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseSelect p wX wY) where+ showsPrec d (RSFwd fixups toedit) =+ showParen (d > appPrec) $+ showString "RSFwd " . showsPrec2 (appPrec + 1) fixups .+ showString " " . showsPrec2 (appPrec + 1) toedit+ showsPrec d (RSRev fixups toedit) =+ showParen (d > appPrec) $+ showString "RSRev " . showsPrec2 (appPrec + 1) fixups .+ showString " " . showsPrec2 (appPrec + 1) toedit++instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseSelect p wX) where+ showDict1 = ShowDictClass++instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseSelect p) where+ showDict2 = ShowDictClass++-- TODO: merge with RebaseSelect.+-- |Used for displaying during 'rebase changes'.+-- 'Named (RebaseChange p)' is very similar to 'RebaseSelect p' but slight+-- mismatches ('Named' embeds an 'FL') makes it not completely trivial to merge+-- them.+data RebaseChange p wX wY where+ RCFwd :: FL (RebaseFixup p) wX wY -> FL p wY wZ -> RebaseChange p wX wZ+ RCRev :: FL (RebaseFixup p) wX wY -> FL p wY wZ -> RebaseChange p wZ wX++instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseChange p wX) where+ showDict1 = ShowDictClass++instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseChange p) where+ showDict2 = ShowDictClass++instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseChange p wX wY) where+ showsPrec d (RCFwd fixups changes) =+ showParen (d > appPrec) $+ showString "RCFwd " . showsPrec2 (appPrec + 1) fixups .+ showString " " . showsPrec2 (appPrec + 1) changes+ showsPrec d (RCRev fixups changes) =+ showParen (d > appPrec) $+ showString "RCRev " . showsPrec2 (appPrec + 1) fixups .+ showString " " . showsPrec2 (appPrec + 1) changes++-- |Get hold of the 'Named' patch inside a 'RebaseSelect'.+rsToNamed :: RebaseSelect p wX wY -> Sealed2 (Named p)+rsToNamed (RSFwd _ toEdit) = Sealed2 toEdit+rsToNamed (RSRev _ toEdit) = Sealed2 toEdit++instance PrimPatchBase p => PrimPatchBase (RebaseSelect p) where+ type PrimOf (RebaseSelect p) = PrimOf p++instance (PrimPatchBase p, PatchListFormat p, Conflict p, FromPrim p, Effect p, CommuteNoConflicts p, IsHunk p, Patchy p, ApplyState p ~ ApplyState (PrimOf p), NameHack p)+ => Patchy (RebaseSelect p)++instance ( PrimPatchBase p, Apply p, ApplyState p ~ ApplyState (PrimOf p)+ , Invert p+ )+ => Patchy (RebaseChange p)++instance PatchDebug p => PatchDebug (RebaseSelect p)++instance PatchDebug p => PatchDebug (RebaseChange p)++instance (PrimPatchBase p, Invert p, Apply p, ApplyState p ~ ApplyState (PrimOf p)) => Apply (RebaseSelect p) where+ type ApplyState (RebaseSelect p) = ApplyState p+ apply (RSFwd fixups toedit) = apply fixups >> apply toedit+ apply (RSRev fixups toedit) = apply (invert toedit) >> apply (invertFL fixups)++instance ( PrimPatchBase p, Invert p, Apply p+ , ApplyState p ~ ApplyState (PrimOf p)+ )+ => Apply (RebaseChange p) where++ type ApplyState (RebaseChange p) = ApplyState p+ apply (RCFwd fixups contents) = apply fixups >> apply contents+ apply (RCRev fixups contents) = apply (invert contents) >> apply (invertFL fixups)++instance (PrimPatchBase p, FromPrim p, Conflict p, CommuteNoConflicts p, Invert p) => Conflict (RebaseSelect p) where+ resolveConflicts (RSFwd _ toedit) = resolveConflicts toedit+ resolveConflicts (RSRev{}) = impossible++-- newtypes to help the type-checker with the 'changeAsMerge' abstraction+newtype ResolveConflictsResult p wY =+ ResolveConflictsResult {+ getResolveConflictsResult :: [[Sealed (FL (PrimOf p) wY)]]+ }++newtype ListConflictedFilesResult (p :: * -> * -> *) wY =+ ListConflictedFilesResult {+ getListConflictedFilesResult :: [FilePath]+ }++newtype ConflictedEffectResult p wY =+ ConflictedEffectResult {+ getConflictedEffectResult :: [IsConflictedPrim (PrimOf p)]+ }++changeAsMerge+ :: (PrimPatchBase p, Invert p, FromPrim p, Merge p)+ => (forall wX' . FL p wX' wY -> result p wY)+ -> RebaseChange p wX wY+ -> result p wY+changeAsMerge f (RCFwd fixups changes) =+ case flToNamesPrims fixups of+ _names :> prims ->+ case merge (invert (fromPrims prims) :\/: changes) of+ changes' :/\: _ifixups' ->+ -- it might make sense to pass+ -- (changes' +>+ invert _ifixups') to resolveConflicts,+ -- but this isn't actually treated as a conflict by+ -- either V1 or V2 patches (not quite sure why)+ f (unsafeCoercePEnd changes')+changeAsMerge _ (RCRev _ _) = impossible++instance+ ( PrimPatchBase p, Invert p, Effect p+ , FromPrim p, Merge p, Conflict p, CommuteNoConflicts p+ )+ => Conflict (RebaseChange p) where+ resolveConflicts =+ getResolveConflictsResult . changeAsMerge (ResolveConflictsResult . resolveConflicts)++ listConflictedFiles =+ getListConflictedFilesResult . changeAsMerge (ListConflictedFilesResult . listConflictedFiles)++ conflictedEffect =+ getConflictedEffectResult . changeAsMerge (ConflictedEffectResult . conflictedEffect)++instance (PrimPatchBase p, Invert p, Effect p) => Effect (RebaseSelect p) where+ effect (RSFwd fixups toedit) =+ concatFL (mapFL_FL effect fixups) +>+ effect toedit+ effect (RSRev fixups toedit) = invertRL . reverseFL . effect $ RSFwd fixups toedit++instance (PrimPatchBase p, Invert p, Effect p) => Effect (RebaseChange p) where+ effect (RCFwd fixups changes) =+ concatFL (mapFL_FL effect fixups) +>+ effect changes+ effect (RCRev fixups changes) =+ invertRL . reverseFL . effect $ RCFwd fixups changes++instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RebaseSelect p) where+ showPatch (RSFwd fixups toedit) =+ showPatch (Suspended (mapFL_FL Fixup fixups +>+ ToEdit toedit :>: NilFL))+ showPatch (RSRev {}) = impossible++instance (PrimPatchBase p, PatchListFormat p, ShowPatchBasic p)+ => ShowPatchBasic (RebaseChange p) where+ showPatch (RCFwd fixups contents) =+ vcat (mapFL showPatch contents) $$+ (if nullFL fixups+ then empty+ else+ redText "" $$+ redText "conflicts:" $$+ redText "" $$+ vcat (mapRL showFixup (invertFL fixups))+ )+ where+ showFixup (PrimFixup p) = showPatch p+ showFixup (NameFixup n) = showPatch n+ showPatch (RCRev {}) = impossible++instance (PrimPatchBase p, PatchListFormat p, Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, ShowPatch p)+ => ShowPatch (RebaseSelect p) where++ description (RSFwd _ toedit) = description toedit+ description (RSRev _ _toedit) = impossible++ summary = summaryFL . fromRebaseSelect . (:>: NilFL)+ summaryFL = summaryFL . fromRebaseSelect++instance+ ( PrimPatchBase p, PatchListFormat p, ShowPatchBasic p+ , Invert p, Effect p, Merge p, FromPrim p+ , Conflict p, CommuteNoConflicts p+ )+ => ShowPatch (RebaseChange p) where++ summary = plainSummary+ summaryFL = plainSummary+++instance ReadPatch p => ReadPatch (RebaseSelect p) where+ readPatch' = error "can't read RebaseSelect patches"++instance ReadPatch (RebaseChange p) where+ readPatch' = error "can't read RebaseChange patches"++-- |Turn a list of rebase items being rebased into a list suitable for use+-- by interactive selection. Each actual patch being rebased is grouped+-- together with any fixups needed.+toRebaseSelect :: PrimPatchBase p => FL (RebaseItem p) wX wY -> FL (RebaseSelect p) wX wY++-- |Turn a list of items back from the format used for interactive selection+-- into a normal list+fromRebaseSelect :: FL (RebaseSelect p) wX wY -> FL (RebaseItem p) wX wY++fromRebaseSelect NilFL = NilFL+fromRebaseSelect (RSFwd fixups toedit :>: ps)+ = mapFL_FL Fixup fixups +>+ ToEdit toedit :>: fromRebaseSelect ps+fromRebaseSelect (RSRev {} :>: _) = impossible++toRebaseSelect NilFL = NilFL+toRebaseSelect (Fixup f :>: ps) =+ case toRebaseSelect ps of+ RSFwd fixups toedit :>: rest -> RSFwd (f :>: fixups) toedit :>: rest+ NilFL -> bug "rebase chain with Fixup at end"+ _ -> impossible+toRebaseSelect (ToEdit te :>: ps) = RSFwd NilFL te :>: toRebaseSelect ps++toRebaseChanges+ :: PrimPatchBase p+ => FL (RebaseItem p) wX wY+ -> FL (PatchInfoAnd (RebaseChange p)) wX wY+toRebaseChanges = mapFL_FL toChange . toRebaseSelect++toChange :: RebaseSelect p wX wY -> PatchInfoAnd (RebaseChange p) wX wY+toChange (RSFwd fixups named) =+ n2pia $+ flip adddeps (getdeps named) $+ infopatch (patch2patchinfo named) $+ (:>: NilFL) $+ RCFwd fixups (patchcontents named)+toChange (RSRev fixups named) =+ n2pia $+ flip adddeps (getdeps named) $+ infopatch (patch2patchinfo named) $+ (:>: NilFL) $+ RCRev fixups (patchcontents named)++instance PrimPatch (PrimOf p) => PrimPatchBase (RebaseChange p) where+ type PrimOf (RebaseChange p) = PrimOf p+++instance Invert p => Invert (RebaseSelect p) where+ invert (RSFwd fixups edit) = RSRev fixups edit+ invert (RSRev fixups edit) = RSFwd fixups edit++instance Invert (RebaseChange p) where+ invert (RCFwd fixups contents) = RCRev fixups contents+ invert (RCRev fixups contents) = RCFwd fixups contents++instance (PrimPatchBase p, Commute p, MyEq p) => MyEq (RebaseSelect p) where+ RSFwd fixups1 edit1 =\/= RSFwd fixups2 edit2+ | IsEq <- fixups1 =\/= fixups2, IsEq <- edit1 =\/= edit2 = IsEq+ RSRev fixups1 edit1 =\/= RSRev fixups2 edit2+ | IsEq <- edit1 =/\= edit2, IsEq <- fixups1 =/\= fixups2 = IsEq++ _ =\/= _ = impossible++instance (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p, NameHack p) => Commute (RebaseSelect p) where+ commute (RSFwd {} :> RSRev {}) = impossible+ commute (RSRev {} :> RSFwd {}) = impossible+ commute (RSRev fixups1 edit1 :> RSRev fixups2 edit2) =+ do RSFwd fixups1' edit1' :> RSFwd fixups2' edit2'+ <- commute (RSFwd fixups2 edit2 :> RSFwd fixups1 edit1)+ return (RSRev fixups2' edit2' :> RSRev fixups1' edit1')++ commute (RSFwd fixups1 edit1 :> RSFwd fixups2 edit2)+ = do+ fixups2' :> edit1' <- commuteNamedFixups (edit1 :> fixups2)+ edit2' :> edit1'' <- commute (edit1' :> edit2)+ fixupsS :> (fixups2'' :> edit2'') :> fixups1' <- return $ pushThrough (fixups1 :> (fixups2' :> edit2'))+ return (RSFwd (fixupsS +>+ fixups2'') edit2'' :> RSFwd fixups1' edit1'')++instance Commute (RebaseChange p) where+ commute _ = impossible++instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseSelect p) where+ listTouchedFiles (RSFwd fixup toedit) = nub (listTouchedFiles fixup ++ listTouchedFiles toedit)+ listTouchedFiles (RSRev fixup toedit) = nub (listTouchedFiles fixup ++ listTouchedFiles toedit)++ hunkMatches f (RSFwd fixup toedit) = hunkMatches f fixup || hunkMatches f toedit+ hunkMatches f (RSRev fixup toedit) = hunkMatches f fixup || hunkMatches f toedit++instance (PrimPatchBase p, PatchInspect p) => PatchInspect (RebaseChange p) where+ listTouchedFiles (RCFwd fixup contents) = nub (listTouchedFiles fixup ++ listTouchedFiles contents)+ listTouchedFiles (RCRev fixup contents) = nub (listTouchedFiles fixup ++ listTouchedFiles contents)++ hunkMatches f (RCFwd fixup contents) = hunkMatches f fixup || hunkMatches f contents+ hunkMatches f (RCRev fixup contents) = hunkMatches f fixup || hunkMatches f contents++-- |Split a list of rebase patches into those that will+-- have conflicts if unsuspended and those that won't.+partitionUnconflicted+ :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p, NameHack p)+ => FL (RebaseSelect p) wX wY+ -> (FL (RebaseSelect p) :> RL (RebaseSelect p)) wX wY+partitionUnconflicted = partitionUnconflictedAcc NilRL++partitionUnconflictedAcc :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p, NameHack p)+ => RL (RebaseSelect p) wX wY -> FL (RebaseSelect p) wY wZ+ -> (FL (RebaseSelect p) :> RL (RebaseSelect p)) wX wZ+partitionUnconflictedAcc right NilFL = NilFL :> right+partitionUnconflictedAcc right (p :>: ps) =+ case commuterRLId selfCommuter (right :> p) of+ Just (p'@(RSFwd NilFL _) :> right')+ -> case partitionUnconflictedAcc right' ps of+ left' :> right'' -> (p' :>: left') :> right''+ _ -> partitionUnconflictedAcc (p :<: right) ps++-- | A patch, together with a list of patch names that it used to depend on,+-- but were lost during the rebasing process. The UI can use this information+-- to report them to the user.+data WithDroppedDeps p wX wY =+ WithDroppedDeps {+ wddPatch :: p wX wY,+ wddDependedOn :: [PatchInfo]+ }++noDroppedDeps :: p wX wY -> WithDroppedDeps p wX wY+noDroppedDeps p = WithDroppedDeps p []++instance PrimPatchBase p => PrimPatchBase (WithDroppedDeps p) where+ type PrimOf (WithDroppedDeps p) = PrimOf p++instance Effect p => Effect (WithDroppedDeps p) where+ effect = effect . wddPatch++-- Note, this could probably be rewritten using a generalised commuteWhatWeCanFL from+-- Darcs.Patch.Permutations.+-- |@pushThrough (ps :> (qs :> te))@ tries to commute as much of @ps@ as possible through+-- both @qs@ and @te@, giving @psStuck :> (qs' :> te') :> psCommuted@.+-- Anything that can be commuted ends up in @psCommuted@ and anything that can't goes in+-- @psStuck@.+pushThrough :: (PrimPatchBase p, FromPrim p, Effect p, Commute p, Invert p)+ => (FL (RebaseFixup p) :> (FL (RebaseFixup p) :> Named p)) wX wY+ -> (FL (RebaseFixup p) :> (FL (RebaseFixup p) :> Named p) :> FL (RebaseFixup p)) wX wY+pushThrough (NilFL :> v) = NilFL :> v :> NilFL+pushThrough ((p :>: ps) :> v) =+ case pushThrough (ps :> v) of+ psS :> v'@(qs:>te) :> ps' ->+ fromMaybe ((p :>: psS) :> v' :> ps') $ do+ psS' :> p' <- commuterIdFL selfCommuter (p :> psS)+ qs' :> p'' <- commuterIdFL selfCommuter (p' :> qs)+ te' :> p''' <- commuteFixupNamed (p'' :> te)+ return (psS' :> (qs' :> te') :> (p''' +>+ ps'))++type WDDNamed p = WithDroppedDeps (Named p)++mergerIdWDD :: MergeFn p1 p2 -> MergeFn p1 (WithDroppedDeps p2)+mergerIdWDD merger (p1 :\/: WithDroppedDeps p2 deps) =+ case merger (p1 :\/: p2) of+ p2' :/\: p1' -> WithDroppedDeps p2' deps :/\: p1'+++commuterIdWDD :: CommuteFn p q -> CommuteFn p (WithDroppedDeps q)+commuterIdWDD commuter (p :> WithDroppedDeps q deps)+ = do -- no need to worry about names, because by definition a dropped dep+ -- is a name we no longer have+ -- TODO consistency checking?+ -- TODO consider inverse commutes, e.g. what happens if we wanted to+ -- commute (WithDroppedDeps ... [n] :> AddName n)?+ q' :> p' <- commuter (p :> q)+ return (WithDroppedDeps q' deps :> p')++-- |Forcibly commute a 'RebaseName' with a patch, dropping any dependencies+-- if necessary and recording them in the patch+forceCommuteName :: (RebaseName p :> WDDNamed p) wX wY -> (WDDNamed p :> RebaseName p) wX wY+forceCommuteName (AddName an :> WithDroppedDeps (NamedP pn deps body) ddeps)+ | an == pn = impossible+ | otherwise = WithDroppedDeps (NamedP pn (deps \\ [an]) (unsafeCoerceP body)) (if an `elem` deps then an:ddeps else ddeps) :> AddName an+forceCommuteName (DelName dn :> p@(WithDroppedDeps (NamedP pn deps _body) _ddeps))+ | dn == pn = impossible+ | dn `elem` deps = impossible+ | otherwise = unsafeCoerceP p :> DelName dn+forceCommuteName (Rename old new :> WithDroppedDeps (NamedP pn deps body) ddeps)+ | old == pn = impossible+ | new == pn = impossible+ | old `elem` deps = impossible+ | otherwise =+ let newdeps = map (\dep -> if new == dep then old else dep) deps+ in WithDroppedDeps (NamedP pn newdeps (unsafeCoerceP body)) ddeps :> Rename old new++forceCommutePrim :: (Commute p, Merge p, Invert p, Effect p, FromPrim p)+ => (PrimOf p :> WDDNamed p) wX wY+ -> (WDDNamed p :> FL (PrimOf p)) wX wY+forceCommutePrim (p :> q) =+ case mergerIdWDD (mergerIdNamed selfMerger) (invert (fromPrim p) :\/: q) of+ q' :/\: invp' -> q' :> effect (invert invp')+++forceCommutesPrim :: (Commute p, Merge p, Invert p, Effect p, FromPrim p)+ => (PrimOf p :> FL (WDDNamed p)) wX wY+ -> (FL (WDDNamed p) :> FL (PrimOf p)) wX wY+forceCommutesPrim (p :> NilFL) = NilFL :> (p :>: NilFL)+forceCommutesPrim (p :> (q :>: qs)) =+ case forceCommutePrim (p :> q) of+ q' :> p' -> case forceCommutessPrim ( p' :> qs) of+ qs' :> p'' -> (q' :>: qs') :> p''++forceCommutessPrim :: (Commute p, Merge p, Invert p, Effect p, FromPrim p)+ => (FL (PrimOf p) :> FL (WDDNamed p)) wX wY+ -> (FL (WDDNamed p) :> FL (PrimOf p)) wX wY+forceCommutessPrim (NilFL :> qs) = qs :> NilFL+forceCommutessPrim ((p :>: ps) :> qs) =+ case forceCommutessPrim (ps :> qs) of+ qs' :> ps' ->+ case forceCommutesPrim (p :> qs') of+ qs'' :> p' -> qs'' :> (p' +>+ ps')++forceCommutess :: (Commute p, Merge p, Invert p, Effect p, FromPrim p)+ => (FL (RebaseFixup p) :> FL (WDDNamed p)) wX wY+ -> (FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY+forceCommutess (NilFL :> qs) = qs :> NilFL+forceCommutess ((NameFixup n :>: ps) :> qs) =+ case forceCommutess (ps :> qs) of+ qs' :> ps' ->+ case totalCommuterIdFL forceCommuteName (n :> qs') of+ qs'' :> n' -> qs'' :> (NameFixup n' :>: ps')+forceCommutess ((PrimFixup p :>: ps) :> qs) =+ case forceCommutess (ps :> qs) of+ qs' :> ps' ->+ case forceCommutesPrim (p :> qs') of+ qs'' :> p' -> qs'' :> (mapFL_FL PrimFixup p' +>+ ps')++-- |Turn a selected rebase patch back into a patch we can apply to+-- the main repository, together with residual fixups that need+-- to go back into the rebase state (unless the rebase is now finished).+-- Any fixups associated with the patch will turn into conflicts.+extractRebaseSelect :: (Commute p, Merge p, Invert p, Effect p, FromPrim p, PrimPatchBase p)+ => FL (RebaseSelect p) wX wY+ -> (FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY+extractRebaseSelect NilFL = NilFL :> NilFL+extractRebaseSelect (RSFwd fixups toedit :>: rest)+ = case extractRebaseSelect rest of+ toedits2 :> fixups2 ->+ case forceCommutess (fixups :> (WithDroppedDeps toedit [] :>: toedits2)) of+ toedits' :> fixups' ->+ toedits' :> (fixups' +>+ fixups2)++extractRebaseSelect (RSRev{} :>: _) = impossible++-- signature to be compatible with extractRebaseSelect+-- | Like 'extractRebaseSelect', but any fixups are "reified" into a separate patch.+reifyRebaseSelect :: forall p wX wY+ . (PrimPatchBase p, Commute p, Merge p, Invert p, Effect p, FromPrim p)+ => FL (RebaseSelect p) wX wY+ -> IO ((FL (WDDNamed p) :> FL (RebaseFixup p)) wX wY)+reifyRebaseSelect rs = do res <- concatFL <$> mapFL_FL_M reifyOne rs+ return (res :> NilFL)+ where reifyOne :: RebaseSelect p wA wB -> IO (FL (WDDNamed p) wA wB)+ reifyOne (RSFwd fixups toedit) =+ case flToNamesPrims fixups of+ names :> NilFL ->+ return (mapFL_FL (noDroppedDeps . mkDummy) names +>+ noDroppedDeps toedit :>: NilFL)+ names :> prims -> do+ n <- mkReified prims+ return (mapFL_FL (noDroppedDeps . mkDummy) names +>+ noDroppedDeps n :>: noDroppedDeps toedit :>: NilFL)+ reifyOne (RSRev{}) = impossible++mkReified :: FromPrim p => FL (PrimOf p) wX wY -> IO (Named p wX wY)+mkReified ps = do+ let name = "Reified fixup patch"+ let desc = []+ date <- getIsoDateTime+ let author = "Invalid <invalid@invalid>"+ namepatch date name author desc (mapFL_FL fromPrim ps)++mkDummy :: RebaseName p wX wY -> Named p wX wY+mkDummy (AddName pi) = infopatch pi (unsafeCoerceP NilFL)+mkDummy (DelName _) = error "internal error: can't make a dummy patch from a delete"+mkDummy (Rename _ _) = error "internal error: can't make a dummy patch from a rename"++instance CommuteNoConflicts (RebaseChange p) where+ commuteNoConflicts _ = impossible++instance MaybeInternal (RebaseChange p)++instance IsHunk p => IsHunk (RebaseChange p) where+ -- RebaseChange is a compound patch, so it doesn't really make sense to+ -- ask whether it's a hunk. TODO: get rid of the need for this.+ isHunk _ = Nothing++instance NameHack (RebaseChange p)+instance PatchListFormat (RebaseChange p)++instance ( PrimPatchBase p, Apply p, Invert p+ , PatchInspect p+ , ApplyState p ~ ApplyState (PrimOf p)+ )+ => Matchable (RebaseChange p)
src/Darcs/Patch/RegChars.hs view
@@ -19,10 +19,10 @@ module Darcs.Patch.RegChars ( regChars, ) where -(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+(&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool (&&&) a b c = a c && b c -(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+(|||) :: (a -> Bool) -> (a -> Bool) -> a -> Bool (|||) a b c = a c || b c {-# INLINE regChars #-}@@ -38,7 +38,7 @@ -- if it is not escaped, but the default 'filename_toks' in -- Darcs.Commands.Replace uses an escaped dot (WHY?). -regChars :: String -> (Char -> Bool)+regChars :: String -> Char -> Bool regChars ('^':cs) = not . normalRegChars (unescapeChars cs) regChars ('\\':'^':cs) = normalRegChars $ unescapeChars $ '^':cs regChars cs = normalRegChars $ unescapeChars cs@@ -63,7 +63,7 @@ -- chars, and also unescaping of escaped special chars. If a non-special -- char is still escaped by now we get a failure. -normalRegChars :: String -> (Char -> Bool)+normalRegChars :: String -> Char -> Bool normalRegChars ('\\':'.':cs) = (=='.') ||| normalRegChars cs normalRegChars ('\\':'-':cs) = (=='-') ||| normalRegChars cs normalRegChars ('\\':'\\':cs) = (=='\\') ||| normalRegChars cs
src/Darcs/Patch/Repair.hs view
@@ -4,15 +4,14 @@ import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.ApplyMonad ( ApplyMonad )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), mapFL, mapRL, (+>+) )-import Printer ( Doc )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), mapFL, mapRL, (+>+) )+import Darcs.Util.Printer ( Doc ) import Data.Maybe ( catMaybes, listToMaybe ) -#include "gadts.h" class Check p where- isInconsistent :: p C(x y) -> Maybe Doc+ isInconsistent :: p wX wY -> Maybe Doc isInconsistent _ = Nothing -- |'Repair' and 'RepairToFL' deal with repairing old patches that were@@ -20,13 +19,13 @@ -- 'Repair' is implemented by collections of patches (FL, Named, PatchInfoAnd) that -- might need repairing. class Repair p where- applyAndTryToFix :: ApplyMonad m (ApplyState p) => p C(x y) -> m (Maybe (String, p C(x y)))+ applyAndTryToFix :: ApplyMonad m (ApplyState p) => p wX wY -> m (Maybe (String, p wX wY)) -- |'RepairToFL' is implemented by single patches that can be repaired (Prim, Patch, RealPatch) -- There is a default so that patch types with no current legacy problems don't need to -- have an implementation. class Apply p => RepairToFL p where- applyAndTryToFixFL :: ApplyMonad m (ApplyState p) => p C(x y) -> m (Maybe (String, FL p C(x y)))+ applyAndTryToFixFL :: ApplyMonad m (ApplyState p) => p wX wY -> m (Maybe (String, FL p wX wY)) applyAndTryToFixFL p = do apply p; return Nothing mapMaybeSnd :: (a -> b) -> Maybe (c, a) -> Maybe (c, b)
src/Darcs/Patch/RepoPatch.hs view
@@ -1,18 +1,29 @@-module Darcs.Patch.RepoPatch ( RepoPatch ) where+module Darcs.Patch.RepoPatch ( RepoPatch )+ where import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts ) import Darcs.Patch.Effect ( Effect ) import Darcs.Patch.FileHunk ( IsHunk ) import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Matchable ( Matchable )+import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Patch.Merge ( Merge ) import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.Patchy.Instances () import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Rebase.NameHack ( NameHack )+import Darcs.Patch.Rebase.Recontext ( RecontextRebase ) import Darcs.Patch.Repair ( RepairToFL, Check )+import Darcs.Patch.Show ( ShowPatch ) -class (Patchy p, Merge p, Effect p, IsHunk p, FromPrim p, Conflict p, CommuteNoConflicts p,+class (Patchy p, Merge p, Effect p, IsHunk p,+ PatchInspect p, ReadPatch p, ShowPatch p,+ FromPrim p, Conflict p, CommuteNoConflicts p, Check p, RepairToFL p, PatchListFormat p,- PrimPatchBase p, Patchy (PrimOf p), IsHunk (PrimOf p)+ PrimPatchBase p, Patchy (PrimOf p), IsHunk (PrimOf p),+ MaybeInternal p, RecontextRebase p, NameHack p,+ Matchable p ) => RepoPatch p-
src/Darcs/Patch/Set.hs view
@@ -15,62 +15,110 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, EmptyDataDecls #-}--#include "gadts.h"+{-# LANGUAGE CPP, EmptyDataDecls, StandaloneDeriving #-} -module Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin,- progressPatchSet, tags, appendPSFL,- newset2RL, newset2FL ) where+module Darcs.Patch.Set+ ( PatchSet(..)+ , Tagged(..)+ , SealedPatchSet+ , Origin+ , progressPatchSet+ , tags+ , emptyPatchSet+ , appendPSFL+ , newset2RL+ , newset2FL+ ) where -import Progress ( progress ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )-import Darcs.Witnesses.Ordered ( FL, RL(..), (+<+), reverseFL,- reverseRL, mapRL_RL, concatRL, mapRL )-import Darcs.Witnesses.Sealed ( Sealed )+import Darcs.Patch.Witnesses.Sealed ( Sealed )+import Darcs.Patch.Witnesses.Ordered+ ( FL, RL(..), (+<+), reverseFL, reverseRL,+ mapRL_RL, concatRL, mapRL )+import Darcs.Patch.Witnesses.Show ( Show1(..), Show2(..), ShowDict(ShowDictClass) ) +import Darcs.Util.Progress ( progress )++-- |'Origin' is a type used to represent the initial context of a repo. data Origin -type SealedPatchSet p C(start) = Sealed ((PatchSet p) C(start))+type SealedPatchSet p wStart = Sealed ((PatchSet p) wStart) --- A PatchSet is a list of patches since the last tag, and a list of tagged--- patch lists that form a repo's history.-data PatchSet p C(start y) where- PatchSet :: RL (PatchInfoAnd p) C(x y) -> RL (Tagged p) C(start x) -> PatchSet p C(start y)+-- |The patches in a repository are stored in chunks broken up at \"clean\"+-- tags. A tag is clean if the only patches before it in the current+-- repository ordering are ones that the tag depends on (either directly+-- or indirectly). Each chunk is stored in a separate inventory file on disk.+--+-- A 'PatchSet' represents a repo's history as the list of patches since the+-- last clean tag, and then a list of patch lists each delimited by clean tags.+data PatchSet p wStart wY where+ PatchSet :: RL (PatchInfoAnd p) wX wY -> RL (Tagged p) wStart wX+ -> PatchSet p wStart wY --- A Tagged is a Tag, the hash of the 'previous' inventory (if it exists) and--- the list of patches since that previous inventory.-data Tagged p C(x z) where- Tagged :: PatchInfoAnd p C(y z) -> Maybe String- -> RL (PatchInfoAnd p) C(x y) -> Tagged p C(x z)+deriving instance Show2 p => Show (PatchSet p wStart wY) --- |newset2RL takes a PatchSet and returns an equivalent, linear RL of patches.-newset2RL :: PatchSet p C(start x) -> RL (PatchInfoAnd p) C(start x)+instance Show2 p => Show1 (PatchSet p wStart) where+ showDict1 = ShowDictClass++instance Show2 p => Show2 (PatchSet p) where+ showDict2 = ShowDictClass+++emptyPatchSet :: PatchSet p wX wX+emptyPatchSet = PatchSet NilRL NilRL++-- |A 'Tagged' is a single chunk of a 'PatchSet'.+-- It has a 'PatchInfo' representing a clean tag,+-- the hash of the previous inventory (if it exists),+-- and the list of patches since that previous inventory.+data Tagged p wX wZ where+ Tagged :: PatchInfoAnd p wY wZ -> Maybe String+ -> RL (PatchInfoAnd p) wX wY -> Tagged p wX wZ++deriving instance Show2 p => Show (Tagged p wX wZ)++instance Show2 p => Show1 (Tagged p wX) where+ showDict1 = ShowDictClass++instance Show2 p => Show2 (Tagged p) where+ showDict2 = ShowDictClass+++-- |'newset2RL' takes a 'PatchSet' and returns an equivalent, linear 'RL' of+-- patches.+newset2RL :: PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX newset2RL (PatchSet ps ts) = ps +<+ concatRL (mapRL_RL ts2rl ts)- where ts2rl :: Tagged p C(y z) -> RL (PatchInfoAnd p) C(y z)- ts2rl (Tagged t _ ps2) = t :<: ps2+ where+ ts2rl :: Tagged p wY wZ -> RL (PatchInfoAnd p) wY wZ+ ts2rl (Tagged t _ ps2) = t :<: ps2 --- |newset2FL takes a PatchSet and returns an equivalent, linear FL of patches.-newset2FL :: PatchSet p C(start x) -> FL (PatchInfoAnd p) C(start x)+-- |'newset2FL' takes a 'PatchSet' and returns an equivalent, linear 'FL' of+-- patches.+newset2FL :: PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX newset2FL = reverseRL . newset2RL --- |appendPSFL takes a PatchSet and a FL of patches that 'follow' the PatchSet,--- and concatenates the patches into the PatchSet.-appendPSFL :: PatchSet p C(start x) -> FL (PatchInfoAnd p) C(x y)- -> PatchSet p C(start y)+-- |'appendPSFL' takes a 'PatchSet' and a 'FL' of patches that "follow" the+-- PatchSet, and concatenates the patches into the PatchSet.+appendPSFL :: PatchSet p wStart wX -> FL (PatchInfoAnd p) wX wY+ -> PatchSet p wStart wY appendPSFL (PatchSet ps ts) newps = PatchSet (reverseFL newps +<+ ps) ts -- |Runs a progress action for each tag and patch in a given PatchSet, using -- the passed progress message. Does not alter the PatchSet.-progressPatchSet :: String -> PatchSet p C(start x) -> PatchSet p C(start x)-progressPatchSet k (PatchSet ps0 ts0) = PatchSet (mapRL_RL prog ps0) $ mapRL_RL pts ts0- where prog = progress k- pts :: Tagged p C(y z) -> Tagged p C(y z)- pts (Tagged t h ps) = Tagged (prog t) h (mapRL_RL prog ps)+progressPatchSet :: String -> PatchSet p wStart wX -> PatchSet p wStart wX+progressPatchSet k (PatchSet ps ts) =+ PatchSet (mapRL_RL prog ps) $ mapRL_RL progressTagged ts+ where+ prog = progress k --- |tags returns the PatchInfos corresponding to the tags of a given PatchSet.-tags :: PatchSet p C(start x) -> [PatchInfo]-tags (PatchSet _ ts) = mapRL f ts- where f :: Tagged p C(y z) -> PatchInfo- f (Tagged t _ _) = info t+ progressTagged :: Tagged p wY wZ -> Tagged p wY wZ+ progressTagged (Tagged t h tps) = Tagged (prog t) h (mapRL_RL prog tps)++-- |'tags' returns the PatchInfos corresponding to the tags of a given+-- 'PatchSet'.+tags :: PatchSet p wStart wX -> [PatchInfo]+tags (PatchSet _ ts) = mapRL taggedTagInfo ts+ where+ taggedTagInfo :: Tagged p wY wZ -> PatchInfo+ taggedTagInfo (Tagged t _ _) = info t
src/Darcs/Patch/Show.hs view
@@ -18,41 +18,37 @@ {-# LANGUAGE CPP #-} module Darcs.Patch.Show- ( ShowPatchBasic(..), ShowPatch(..)+ ( ShowPatchBasic(..)+ , ShowPatch(..) , showNamedPrefix- , writePatch, gzWritePatch , formatFileName- )- where+ ) where import Prelude hiding ( pi ) -import Darcs.Lock ( writeDocBinFile, gzWriteDocFile )-import Darcs.Patch.FileName ( FileName, fn2ps, encodeWhite, fn2fp )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.ApplyMonad ( ApplyMonadTrans, ApplyMonad ) import Darcs.Patch.Format ( FileNameFormat(..) ) import Darcs.Patch.Info ( PatchInfo, showPatchInfo )-import Darcs.Witnesses.Ordered ( FL )--import English ( plural, Noun(Noun) )-import Printer ( Doc, vcat, blueText, ($$), (<>), text, packedString )-import Darcs.Patch.ApplyMonad ( ApplyMonadTrans, ApplyMonad )-import Darcs.Patch.Apply ( ApplyState )-+import Darcs.Patch.Witnesses.Ordered ( FL ) -#include "gadts.h"+import Darcs.Util.English ( plural, Noun(Noun) )+import Darcs.Util.Path ( FileName, fn2ps, encodeWhite, fn2fp )+import Darcs.Util.Printer ( Doc, vcat, blueText, ($$), text, packedString ) showNamedPrefix :: PatchInfo -> [PatchInfo] -> Doc showNamedPrefix n d = showPatchInfo n- $$ blueText "<"- $$ vcat (map showPatchInfo d)- $$ blueText ">"+ $$ blueText "<"+ $$ vcat (map showPatchInfo d)+ $$ blueText ">" class ShowPatchBasic p where- showPatch :: p C(x y) -> Doc+ showPatch :: p wX wY -> Doc class ShowPatchBasic p => ShowPatch p where- showNicely :: p C(x y) -> Doc+ showNicely :: p wX wY -> Doc showNicely = showPatch+ -- | showContextPatch is used to add context to a patch, as diff -- -u does. Thus, it differs from showPatch only for hunks. It is -- used for instance before putting it into a bundle. As this@@ -60,21 +56,21 @@ -- requires access to the tree. showContextPatch :: (Monad m, ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p))- => p C(x y) -> m Doc+ => p wX wY -> m Doc showContextPatch p = return $ showPatch p- description :: p C(x y) -> Doc++ description :: p wX wY -> Doc description = showPatch- summary :: p C(x y) -> Doc- summaryFL :: FL p C(x y) -> Doc- thing :: p C(x y) -> String++ summary :: p wX wY -> Doc++ summaryFL :: FL p wX wY -> Doc++ thing :: p wX wY -> String thing _ = "patch"- things :: p C(x y) -> String- things x = plural (Noun $ thing x) "" -writePatch :: ShowPatchBasic p => FilePath -> p C(x y) -> IO ()-writePatch f p = writeDocBinFile f $ showPatch p <> text "\n"-gzWritePatch :: ShowPatchBasic p => FilePath -> p C(x y) -> IO ()-gzWritePatch f p = gzWriteDocFile f $ showPatch p <> text "\n"+ things :: p wX wY -> String+ things x = plural (Noun $ thing x) "" formatFileName :: FileNameFormat -> FileName -> Doc formatFileName OldFormat = packedString . fn2ps
src/Darcs/Patch/Split.hs view
@@ -26,8 +26,8 @@ import Data.List ( intersperse ) -import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) import Darcs.Patch.Patchy ( ReadPatch(..), showPatch, ShowPatch(..), Invert(..) )@@ -37,12 +37,12 @@ import Darcs.Patch.Read () import Darcs.Patch.Viewing () -import Printer ( renderPS )+import Darcs.Util.Printer ( renderPS, RenderMode(..) )+import qualified Darcs.Util.Diff as D ( DiffAlgorithm ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -#include "gadts.h" -- |A splitter is something that can take a patch and (possibly) render it -- as text in some format of its own choosing.@@ -62,9 +62,9 @@ -- splitters for Prim etc, and the generality doesn't cost anything. data Splitter p = Splitter {- applySplitter :: FORALL(x y) p C(x y)+ applySplitter :: forall wX wY . D.DiffAlgorithm -> p wX wY -> Maybe (B.ByteString,- B.ByteString -> Maybe (FL p C(x y)))+ B.ByteString -> Maybe (FL p wX wY)) -- canonization is needed to undo the effects of splitting -- Typically, the list returned by applySplitter will not -- be in the simplest possible form (since the user will have@@ -74,7 +74,8 @@ -- we might record (or whatever) a rather strange looking patch. -- This hook allows the splitter to provide an appropriate -- function for doing this.- ,canonizeSplit :: FORALL(x y) FL p C(x y) -> FL p C(x y)+ ,canonizeSplit :: forall wX wY . D.DiffAlgorithm -> FL p wX wY+ -> FL p wX wY } {- Some facts that probably ought to be true about splitters: should make some QC@@ -87,7 +88,7 @@ -} -- Does not canonize as there is no generic operation to do this.-withEditedHead :: Invert p => p C(x y) -> p C(x z) -> FL p C(x y)+withEditedHead :: Invert p => p wX wY -> p wX wZ -> FL p wX wY withEditedHead p res = res :>: invert res :>: p :>: NilFL -- |This generic splitter just lets the user edit the printed representation of the patch@@ -95,23 +96,24 @@ rawSplitter :: (ShowPatch p, ReadPatch p, Invert p) => Splitter p rawSplitter = Splitter { applySplitter =- \p -> Just (renderPS . showPatch $ p,+ \_ p -> Just (renderPS Standard . showPatch $ p, \str -> case parseStrictly readPatch' str of Just (Sealed res, _) -> Just (withEditedHead p res) _ -> Nothing )- ,canonizeSplit = id+ ,canonizeSplit = \_ b -> id b } -- |Never splits. In other code we normally pass around Maybe Splitter instead of using this -- as the default, because it saves clients that don't care about splitting from having to -- import this module just to get noSplitter. noSplitter :: Splitter p-noSplitter = Splitter { applySplitter = const Nothing, canonizeSplit = id }+noSplitter = Splitter { applySplitter = \_ -> const Nothing, canonizeSplit = \_ b -> id b } -doPrimSplit :: PrimPatch prim => prim C(x y) -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim C(x y)))-doPrimSplit = doPrimSplit_ True explanation+doPrimSplit :: PrimPatch prim => D.DiffAlgorithm -> prim wX wY+ -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim wX wY))+doPrimSplit da = doPrimSplit_ da True explanation where explanation = map BC.pack [ "Interactive hunk edit:"@@ -124,7 +126,13 @@ , "" ] -doPrimSplit_ edit_before_part helptext (isHunk -> Just (FileHunk fn n before after))+doPrimSplit_ :: (PrimPatch prim, IsHunk p)+ => D.DiffAlgorithm+ -> Bool+ -> [B.ByteString]+ -> p wX wY+ -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim wX wY))+doPrimSplit_ da edit_before_part helptext (isHunk -> Just (FileHunk fn n before after)) = Just (B.concat $ intersperse (BC.pack "\n") $ concat [ helptext , [mkSep " BEFORE (reference) =========================="]@@ -142,13 +150,13 @@ then hunk before before' +>+ hunk before' after' +>+ hunk after' after else hunk before after' +>+ hunk after' after) where sep = BC.pack "=========================="- hunk :: PrimPatch prim => [B.ByteString] -> [B.ByteString] -> FL prim C(a b)- hunk b a = canonize (primFromHunk (FileHunk fn n b a))+ hunk :: PrimPatch prim => [B.ByteString] -> [B.ByteString] -> FL prim wA wB+ hunk b a = canonize da (primFromHunk (FileHunk fn n b a)) mkSep s = BC.append sep (BC.pack s) breakSep xs = case break (sep `BC.isPrefixOf`) xs of (_, []) -> Nothing (ys, _:zs) -> Just (ys, zs)-doPrimSplit_ _ _ _ = Nothing+doPrimSplit_ _ _ _ _ = Nothing -- |Split a primitive hunk patch up -- by allowing the user to edit both the before and after lines, then insert fixup patches@@ -157,9 +165,10 @@ primSplitter = Splitter { applySplitter = doPrimSplit , canonizeSplit = canonizeFL } -doReversePrimSplit :: PrimPatch prim => prim C(x y) -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim C(x y)))-doReversePrimSplit prim = do- (text, parser) <- doPrimSplit_ False reverseExplanation (invert prim)+doReversePrimSplit :: PrimPatch prim => D.DiffAlgorithm -> prim wX wY+ -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim wX wY))+doReversePrimSplit da prim = do+ (text, parser) <- doPrimSplit_ da False reverseExplanation (invert prim) let parser' p = do patch <- parser p return . reverseRL $ invertFL patch
src/Darcs/Patch/Summary.hs view
@@ -3,30 +3,29 @@ xmlSummary ) where -import Darcs.Patch.FileName ( fn2fp )+import Darcs.Util.Path ( fn2fp ) import Darcs.Patch.Conflict ( Conflict(..), IsConflictedPrim(IsC), ConflictState(..) ) import Darcs.Patch.Effect ( Effect ) import Darcs.Patch.Prim.Class ( PrimDetails(..), PrimPatchBase ) import Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) )-import Darcs.Witnesses.Ordered ( FL, mapFL )+import Darcs.Patch.Witnesses.Ordered ( FL, mapFL ) -import Printer ( Doc, empty, vcat,+import Darcs.Util.Printer ( Doc, empty, vcat, text, minus, plus, ($$), (<+>), (<>), ) -#include "gadts.h" -plainSummaryPrim :: PrimDetails prim => prim C(x y) -> Doc+plainSummaryPrim :: PrimDetails prim => prim wX wY -> Doc plainSummaryPrim = vcat . map summChunkToLine . genSummary . (:[]) . IsC Okay -plainSummaryPrims :: PrimDetails prim => FL prim C(x y) -> Doc+plainSummaryPrims :: PrimDetails prim => FL prim wX wY -> Doc plainSummaryPrims = vcat . map summChunkToLine . genSummary . mapFL (IsC Okay) -plainSummary :: (Conflict e, Effect e, PrimPatchBase e) => e C(x y) -> Doc+plainSummary :: (Conflict e, Effect e, PrimPatchBase e) => e wX wY -> Doc plainSummary = vcat . map summChunkToLine . genSummary . conflictedEffect -xmlSummary :: (Effect p, Conflict p, PrimPatchBase p) => p C(x y) -> Doc+xmlSummary :: (Effect p, Conflict p, PrimPatchBase p) => p wX wY -> Doc xmlSummary p = text "<summary>" $$ (vcat . map summChunkToXML . genSummary . conflictedEffect $ p) $$ text "</summary>"@@ -39,8 +38,8 @@ strReplace :: Char -> String -> String -> String strReplace _ _ [] = [] strReplace x y (z:zs)- | x == z = y ++ (strReplace x y zs)- | otherwise = z : (strReplace x y zs)+ | x == z = y ++ strReplace x y zs+ | otherwise = z : strReplace x y zs -- end yuck duplicated code. -- | High-level representation of a piece of patch summary@@ -51,7 +50,7 @@ genSummary p = combine $ concatMap s2 p where s2 :: IsConflictedPrim p -> [SummChunk]- s2 (IsC c x) = map (\d -> SummChunk d c) $ summarizePrim x+ s2 (IsC c x) = map (`SummChunk` c) $ summarizePrim x combine (x1@(SummChunk d1 c1) : x2@(SummChunk d2 c2) : ss) = case combineDetail d1 d2 of Nothing -> x1 : combine (x2:ss)
src/Darcs/Patch/SummaryData.hs view
@@ -1,6 +1,6 @@ module Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) ) where -import Darcs.Patch.FileName ( FileName )+import Darcs.Util.Path ( FileName ) data SummDetail = SummAddDir FileName | SummRmDir FileName
src/Darcs/Patch/TokenReplace.hs view
@@ -2,47 +2,56 @@ ( tryTokInternal , forceTokReplace- )- where--import Darcs.Patch.RegChars ( regChars )--import ByteStringUtils ( substrPS, linesPS, unlinesPS )+ , breakOutToken+ ) where import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Maybe ( isNothing ) -tryTokInternal :: String -> B.ByteString -> B.ByteString- -> B.ByteString -> Maybe [B.ByteString]-tryTokInternal _ o n s | isNothing (substrPS o s) &&- isNothing (substrPS n s) = Just [s]-tryTokInternal t o n s =- case BC.break (regChars t) s of- (before,s') ->- case BC.break (not . regChars t) s' of- (tok,after) ->- case tryTokInternal t o n after of- Nothing -> Nothing- Just rest ->- if tok == o- then Just $ before : n : rest- else if tok == n- then Nothing- else Just $ before : tok : rest+import Darcs.Util.ByteString ( substrPS, linesPS, unlinesPS )+import Darcs.Patch.RegChars ( regChars ) -forceTokReplace :: String -> String -> String- -> B.ByteString -> Maybe B.ByteString-forceTokReplace t os ns c = Just $ unlinesPS $ map forceReplace $ linesPS c- where o = BC.pack os- n = BC.pack ns- tokchar = regChars t- toks_and_intratoks ps | B.null ps = []- toks_and_intratoks ps =- let (before,s') = BC.break tokchar ps- (tok, after) = BC.break (not . tokchar) s'- in before : tok : toks_and_intratoks after- forceReplace ps = B.concat $ map o_t_n $ toks_and_intratoks ps- o_t_n s | s == o = n- | otherwise = s+-- | breakOutToken takes a String of token chars and an input ByteString, and+-- returns the ByteString triple of (beforeToken, token, afterToken).+breakOutToken :: String -> BC.ByteString+ -> (BC.ByteString, BC.ByteString, BC.ByteString)+breakOutToken tokChars input =+ let isTokChar = regChars tokChars+ (before, tokAndRest) = BC.break isTokChar input+ (tok, remaining) = BC.break (not . isTokChar) tokAndRest in+ (before, tok, remaining) +-- | tryTokInternal takes a String of token chars, an oldToken ByteString, a+-- newToken ByteString and returns the list of token-delimited ByteStrings,+-- with any tokens matching oldToken being replaced by newToken. If newToken is+-- already in the input, we return Nothing.+tryTokInternal :: String -> B.ByteString -> B.ByteString -> B.ByteString+ -> Maybe [B.ByteString]+tryTokInternal _ oldToken newToken input+ | isNothing (substrPS oldToken input) &&+ isNothing (substrPS newToken input) = Just [ input ]+tryTokInternal tokChars oldToken newToken input =+ let (before, tok, remaining) = breakOutToken tokChars input in+ case tryTokInternal tokChars oldToken newToken remaining of+ Nothing -> Nothing+ Just rest | tok == oldToken -> Just $ before : newToken : rest+ | tok == newToken -> Nothing+ | otherwise -> Just $ before : tok : rest++-- | forceTokReplace replaces all occurrences of the old token with the new+-- token, throughout the input ByteString.+forceTokReplace :: String -> B.ByteString -> B.ByteString -> B.ByteString+ -> B.ByteString+forceTokReplace tokChars oldToken newToken = forceReplaceLines+ where+ forceReplaceLines = unlinesPS . map forceReplace . linesPS+ breakOutAllTokens input | B.null input = []+ breakOutAllTokens input =+ let (before, tok, remaining) = breakOutToken tokChars input in+ before : tok : breakOutAllTokens remaining++ forceReplace = B.concat . map replaceMatchingToken . breakOutAllTokens++ replaceMatchingToken input | input == oldToken = newToken+ | otherwise = input
src/Darcs/Patch/TouchesFiles.hs view
@@ -17,7 +17,6 @@ {-# LANGUAGE CPP #-} -#include "gadts.h" module Darcs.Patch.TouchesFiles ( lookTouch, chooseTouching, choosePreTouching, selectTouching,@@ -26,51 +25,47 @@ import Control.Applicative ( (<$>) ) import Data.List ( isSuffixOf, nub ) -import Darcs.Patch.Choices ( PatchChoices, Tag, TaggedPatch,- patchChoices, tag, getChoices,- forceFirsts, forceLasts, tpPatch,+import Darcs.Patch.Choices ( PatchChoices, Label, LabelledPatch,+ patchChoices, label, getChoices,+ forceFirsts, forceLasts, lpPatch, ) import Darcs.Patch ( Patchy, invert ) import Darcs.Patch.Apply ( ApplyState, applyToFilePaths, effectOnFilePaths )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) )-import Darcs.Witnesses.Sealed ( Sealed, seal )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) )+import Darcs.Patch.Witnesses.Sealed ( Sealed, seal ) import Storage.Hashed.Tree( Tree ) -selectTouching :: (Patchy p, ApplyState p ~ Tree)- => Maybe [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+labelTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Bool+ -> [FilePath] -> FL (LabelledPatch p) wX wY -> [Label]+labelTouching _ _ NilFL = []+labelTouching wantTouching fs (lp :>: lps) =+ case lookTouchOnlyEffect fs (lpPatch lp) of+ (doesTouch, fs') ->+ let rest = labelTouching wantTouching fs' lps+ in (if doesTouch == wantTouching then (label lp :) else id) rest++labelNotTouchingFM :: (PatchInspect p, Patchy p, ApplyState p ~ Tree)+ => [FilePath] -> PatchChoices p wX wY -> [Label]+labelNotTouchingFM files pc = case getChoices pc of+ fc :> mc :> _ -> labelTouching False (map fix files) (fc +>+ mc)++selectTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree)+ => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY selectTouching Nothing pc = pc selectTouching (Just files) pc = forceFirsts xs pc- where ct :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]- ct _ NilFL = []- ct fs (tp:>:tps) = case lookTouchOnlyEffect fs (tpPatch tp) of- (True, fs') -> tag tp:ct fs' tps- (False, fs') -> ct fs' tps- xs = case getChoices pc of- _ :> mc :> lc -> ct (map fix files) (mc +>+ lc)+ where xs = case getChoices pc of+ _ :> mc :> lc -> labelTouching True (map fix files) (mc +>+ lc) -deselectNotTouching :: (Patchy p, ApplyState p ~ Tree)- => Maybe [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+deselectNotTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree)+ => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY deselectNotTouching Nothing pc = pc-deselectNotTouching (Just files) pc = forceLasts xs pc- where ct :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]- ct _ NilFL = []- ct fs (tp:>:tps) = case lookTouchOnlyEffect fs (tpPatch tp) of- (True, fs') -> ct fs' tps- (False, fs') -> tag tp:ct fs' tps- xs = case getChoices pc of- fc :> mc :> _ -> ct (map fix files) (fc +>+ mc)+deselectNotTouching (Just files) pc = forceLasts (labelNotTouchingFM files pc) pc -selectNotTouching :: (Patchy p, ApplyState p ~ Tree)- => Maybe [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+selectNotTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree)+ => Maybe [FilePath] -> PatchChoices p wX wY -> PatchChoices p wX wY selectNotTouching Nothing pc = pc-selectNotTouching (Just files) pc = forceFirsts xs pc- where ct :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]- ct _ NilFL = []- ct fs (tp:>:tps) = case lookTouchOnlyEffect fs (tpPatch tp) of- (True, fs') -> ct fs' tps- (False, fs') -> tag tp:ct fs' tps- xs = case getChoices pc of- fc :> mc :> _ -> ct (map fix files) (fc +>+ mc)+selectNotTouching (Just files) pc = forceFirsts (labelNotTouchingFM files pc) pc fix :: FilePath -> FilePath fix f | "/" `isSuffixOf` f = fix $ init f@@ -78,25 +73,25 @@ fix "." = "." fix f = "./" ++ f -chooseTouching :: (Patchy p, ApplyState p ~ Tree)- => Maybe [FilePath] -> FL p C(x y) -> Sealed (FL p C(x))+chooseTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree)+ => Maybe [FilePath] -> FL p wX wY -> Sealed (FL p wX) chooseTouching Nothing p = seal p chooseTouching files p = case getChoices $ selectTouching files $ patchChoices p of- fc :> _ :> _ -> seal $ mapFL_FL tpPatch fc+ fc :> _ :> _ -> seal $ mapFL_FL lpPatch fc -choosePreTouching :: (Patchy p, ApplyState p ~ Tree)- => Maybe [FilePath] -> FL p C(x y) -> Sealed (FL p C(x))+choosePreTouching :: (Patchy p, PatchInspect p, ApplyState p ~ Tree)+ => Maybe [FilePath] -> FL p wX wY -> Sealed (FL p wX) choosePreTouching files patch = chooseTouching filesBeforePatch patch where filesBeforePatch = effectOnFilePaths (invert patch) <$> files -lookTouchOnlyEffect :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> p C(x y)+lookTouchOnlyEffect :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => [FilePath] -> p wX wY -> (Bool, [FilePath]) lookTouchOnlyEffect fs p = (wasTouched, fs') where (wasTouched, _, fs', _) = lookTouch Nothing fs p -lookTouch :: (Patchy p, ApplyState p ~ Tree) => Maybe [(FilePath, FilePath)]- -> [FilePath] -> p C(x y)+lookTouch :: (Patchy p, PatchInspect p, ApplyState p ~ Tree) => Maybe [(FilePath, FilePath)]+ -> [FilePath] -> p wX wY -> (Bool, [FilePath], [FilePath], [(FilePath, FilePath)]) lookTouch renames fs p = (anyTouched, touchedFs, fs', renames') where
+ src/Darcs/Patch/Type.hs view
@@ -0,0 +1,7 @@+module Darcs.Patch.Type ( PatchType(..), patchType ) where++-- |Used for indicating a patch type without having a concrete patch+data PatchType (p :: * -> * -> *) = PatchType++patchType :: p wX wY -> PatchType p+patchType _ = PatchType
src/Darcs/Patch/V1.hs view
@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1 ( Patch ) where +import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.Patchy ( Patchy ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.RepoPatch ( RepoPatch )@@ -13,4 +14,5 @@ import Darcs.Patch.V1.Viewing () instance PrimPatch prim => Patchy (Patch prim)+instance PrimPatch prim => Matchable (Patch prim) instance PrimPatch prim => RepoPatch (Patch prim)
src/Darcs/Patch/V1/Apply.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Apply () where -import Darcs.Patch.Apply ( Apply, apply )+import Darcs.Patch.Apply ( ApplyState, Apply, apply ) import Darcs.Patch.Prim ( PrimPatch, applyPrimFL ) import Darcs.Patch.Repair ( RepairToFL, applyAndTryToFixFL, mapMaybeSnd )@@ -9,11 +9,9 @@ import Darcs.Patch.V1.Commute () import Darcs.Patch.V1.Core ( Patch(..) )-import Darcs.Patch.Apply( ApplyState ) -import Darcs.Witnesses.Ordered ( mapFL_FL )+import Darcs.Patch.Witnesses.Ordered ( mapFL_FL ) -#include "gadts.h" instance PrimPatch prim => Apply (Patch prim) where type ApplyState (Patch prim) = ApplyState prim
src/Darcs/Patch/V1/Commute.hs view
@@ -15,10 +15,9 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-} {-# LANGUAGE CPP #-} -#include "gadts.h" module Darcs.Patch.V1.Commute (@@ -29,10 +28,13 @@ where import Control.Monad ( MonadPlus, mplus, msum, mzero, guard )+import Control.Applicative ( Applicative(..), Alternative(..) )+import Data.Maybe ( isJust ) -import Darcs.Patch.Commute ( toFwdCommute )+import Darcs.Patch.Commute ( toFwdCommute, selfCommuter )+import Darcs.Patch.CommuteFn ( commuterIdFL, commuterFLId ) import Darcs.Patch.ConflictMarking ( mangleUnravelled )-import Darcs.Patch.FileName ( FileName )+import Darcs.Util.Path ( FileName ) import Darcs.Patch.Invert ( invertRL ) import Darcs.Patch.Merge ( Merge(..) ) import Darcs.Patch.Patchy ( Commute(..), PatchInspect(..), Invert(..) )@@ -45,45 +47,58 @@ import Darcs.Patch.Prim ( FromPrim(..), PrimPatch, is_filepatch, sortCoalesceFL, )-import Darcs.Patch.Permutations ( headPermutationsRL, simpleHeadPermutationsFL,- commuterIdFL, commuterFLId, selfCommuter )-import Printer ( text, vcat, ($$) )+import Darcs.Patch.Permutations ( headPermutationsRL, simpleHeadPermutationsFL )+import Darcs.Util.Printer ( text, vcat, ($$) ) import Darcs.Patch.V1.Show ( showPatch_ ) import Data.List ( nub, nubBy )-import Darcs.Witnesses.Sealed ( unsafeUnseal, unsafeUnsealFlipped )-import Darcs.Utils ( nubsort )+import Data.List.Ordered ( nubSort ) #include "impossible.h"-import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal, unseal, FlippedSeal(..), mapFlipped )-import Darcs.Witnesses.Eq ( EqCheck(..), MyEq(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart- , unsafeCoercePEnd )-import Darcs.Witnesses.Ordered ( mapFL_FL,- FL(..), RL(..),- (:/\:)(..), (:<)(..), (:\/:)(..), (:>)(..),- lengthFL, mapRL,- reverseFL, reverseRL, concatFL- )----import Darcs.ColorPrinter ( traceDoc )---import Printer ( greenText )+import Darcs.Patch.Witnesses.Sealed+ ( Sealed(..) , mapSeal, unseal, FlippedSeal(..), mapFlipped+ , unsafeUnseal, unsafeUnsealFlipped )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..), MyEq(..) )+import Darcs.Patch.Witnesses.Unsafe+ ( unsafeCoerceP, unsafeCoercePStart+ , unsafeCoercePEnd )+import Darcs.Patch.Witnesses.Ordered+ ( mapFL_FL,+ FL(..), RL(..),+ (:/\:)(..), (:<)(..), (:\/:)(..), (:>)(..),+ lengthFL, mapRL,+ reverseFL, reverseRL, concatFL+ ) data Perhaps a = Unknown | Failed | Succeeded a +instance Functor Perhaps where+ fmap _ Unknown = Unknown+ fmap _ Failed = Failed+ fmap f (Succeeded x) = Succeeded (f x)++instance Applicative Perhaps where+ pure = Succeeded+ _ <*> Failed = Failed+ _ <*> Unknown = Unknown+ Failed <*> _ = Failed+ Unknown <*> _ = Unknown+ Succeeded f <*> Succeeded x = Succeeded (f x)+ instance Monad Perhaps where (Succeeded x) >>= k = k x Failed >>= _ = Failed Unknown >>= _ = Unknown- Failed >> _ = Failed- (Succeeded _) >> k = k- Unknown >> k = k return = Succeeded fail _ = Unknown +instance Alternative Perhaps where+ empty = Unknown+ Unknown <|> ys = ys+ Failed <|> _ = Failed+ (Succeeded x) <|> _ = Succeeded x+ instance MonadPlus Perhaps where- mzero = Unknown- Unknown `mplus` ys = ys- Failed `mplus` _ = Failed- (Succeeded x) `mplus` _ = Succeeded x+ mzero = Unknown+ mplus = (<|>) toMaybe :: Perhaps a -> Maybe a toMaybe (Succeeded x) = Just x@@ -93,6 +108,14 @@ toPerhaps (Just x) = Succeeded x toPerhaps Nothing = Failed +-- | 'cleverCommute' attempts to commute two patches @p1@ and @p2@, in their+-- original order, with the given commute function. If the commute function+-- doesn't know how to handle the patches (i.e. it returns Unknown as a+-- result), then we try again with @invert p2@ and @invert p1@ (inverting the+-- results, if succesful).+--+-- TODO: when can the first attempt fail, but the second not? What's so clever+-- in this function? cleverCommute :: Invert prim => CommuteFunction prim -> CommuteFunction prim cleverCommute c (p1:<p2) = case c (p1 :< p2) of@@ -103,21 +126,21 @@ Failed -> Failed Unknown -> Unknown +-- | If we have two Filepatches which modify different files, we can return a+-- result early, since the patches trivially commute. speedyCommute :: PrimPatch prim => CommuteFunction prim-speedyCommute (p1 :< p2) -- Deal with common case quickly!- | p1_modifies /= Nothing && p2_modifies /= Nothing &&+speedyCommute (p1 :< p2)+ | isJust p1_modifies && isJust p2_modifies && p1_modifies /= p2_modifies = Succeeded (unsafeCoerceP p2 :< unsafeCoerceP p1) | otherwise = Unknown where p1_modifies = isFilepatchMerger p1 p2_modifies = isFilepatchMerger p2 everythingElseCommute :: forall prim . PrimPatch prim => CommuteFunction prim-everythingElseCommute x = eec x- where- eec :: CommuteFunction prim- eec (PP px :< PP py) = toPerhaps $ do x' :> y' <- commute (py :> px)- return (PP y' :< PP x')- eec _xx =+everythingElseCommute (PP px :< PP py) = toPerhaps $ do+ x' :> y' <- commute (py :> px)+ return (PP y' :< PP x')+everythingElseCommute _xx = msum [ cleverCommute commuteRecursiveMerger _xx ,cleverCommute otherCommuteRecursiveMerger _xx@@ -134,10 +157,11 @@ then commutex (B^-1, A^-1) == Just (A'^-1, B'^-1) -} -unsafeMerger :: PrimPatch prim => String -> Patch prim C(x y) -> Patch prim C(x z) -> Patch prim C(a b)+unsafeMerger :: PrimPatch prim => String -> Patch prim wX wY -> Patch prim wX wZ -> Patch prim wA wB unsafeMerger x p1 p2 = unsafeCoercePStart $ unsafeUnseal $ merger x p1 p2 -mergerCommute :: PrimPatch prim => (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))+-- | Attempt to commute two patches, the first of which is a Merger patch.+mergerCommute :: PrimPatch prim => (Patch prim :< Patch prim) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY) mergerCommute (Merger _ _ p1 p2 :< pA) | unsafeCompare pA p1 = Succeeded (unsafeMerger "0.0" p2 p1 :< unsafeCoercePStart p2) | unsafeCompare pA (invert (unsafeMerger "0.0" p2 p1)) = Failed@@ -153,16 +177,15 @@ instance PrimPatch prim => Merge (Patch prim) where merge (y :\/: z) = case actualMerge (y:\/:z) of+ -- actualMerge returns one "arm" of a merge result (@y'@, which applies+ -- "after" @z@), but we need to return both arms. We therefore commute+ -- @z@ and @y'@, to obtain a @z'@, which applies "after" @y'' == y@. Sealed y' -> case commute (z :> y') of Nothing -> bugDoc $ text "merge_patches bug" $$ showPatch_ y $$ showPatch_ z $$ showPatch_ y'- Just (_ :> z') -> -- actualMerge returns one arm of a- -- merge result, so commuting then gives- -- us the other arm but we have to assert- -- that the starting context is correct- unsafeCoercePStart z' :/\: y'+ Just (_ :> z') -> unsafeCoercePStart z' :/\: y' instance PrimPatch prim => Commute (Patch prim) where commute x = toMaybe $ msum@@ -173,13 +196,13 @@ instance PrimPatch prim => PatchInspect (Patch prim) where -- Recurse on everything, these are potentially spoofed patches- listTouchedFiles (Merger _ _ p1 p2) = nubsort $ listTouchedFiles p1+ listTouchedFiles (Merger _ _ p1 p2) = nubSort $ listTouchedFiles p1 ++ listTouchedFiles p2- listTouchedFiles c@(Regrem _ _ _ _) = listTouchedFiles $ invert c+ listTouchedFiles c@(Regrem{}) = listTouchedFiles $ invert c listTouchedFiles (PP p) = listTouchedFiles p hunkMatches f (Merger _ _ p1 p2) = hunkMatches f p1 || hunkMatches f p2- hunkMatches f c@(Regrem _ _ _ _) = hunkMatches f $ invert c+ hunkMatches f c@(Regrem{}) = hunkMatches f $ invert c hunkMatches f (PP p) = hunkMatches f p commuteNoMerger :: PrimPatch prim => MaybeCommute prim@@ -187,7 +210,7 @@ toMaybe $ msum [speedyCommute x, everythingElseCommute x] -isFilepatchMerger :: PrimPatch prim => Patch prim C(x y) -> Maybe FileName+isFilepatchMerger :: PrimPatch prim => Patch prim wX wY -> Maybe FileName isFilepatchMerger (PP p) = is_filepatch p isFilepatchMerger (Merger _ _ p1 p2) = do f1 <- isFilepatchMerger p1@@ -196,7 +219,7 @@ isFilepatchMerger (Regrem und unw p1 p2) = isFilepatchMerger (Merger und unw p1 p2) -commuteRecursiveMerger :: PrimPatch prim => (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))+commuteRecursiveMerger :: PrimPatch prim => (Patch prim :< Patch prim) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY) commuteRecursiveMerger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $ do (_ :> pA') <- commuterIdFL selfCommuter (pA :> undo) _ <- commuterIdFL selfCommuter (pA' :> invert undo)@@ -216,7 +239,7 @@ where undo = mergerUndo p commuteRecursiveMerger _ = Unknown -otherCommuteRecursiveMerger :: PrimPatch prim => (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))+otherCommuteRecursiveMerger :: PrimPatch prim => (Patch prim :< Patch prim) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY) otherCommuteRecursiveMerger (pA':< p_old@(Merger _ _ p1' p2')) = toPerhaps $ do (pA :> _) <- commuterFLId selfCommuter (mergerUndo p_old :> pA')@@ -236,19 +259,21 @@ return (p :< pA) otherCommuteRecursiveMerger _ = Unknown -type CommuteFunction prim = FORALL(x y) (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))-type MaybeCommute prim = FORALL(x y) (Patch prim :< Patch prim) C(x y) -> Maybe ((Patch prim :< Patch prim) C(x y))+type CommuteFunction prim = forall wX wY . (Patch prim :< Patch prim) wX wY -> Perhaps ((Patch prim :< Patch prim) wX wY)+type MaybeCommute prim = forall wX wY . (Patch prim :< Patch prim) wX wY -> Maybe ((Patch prim :< Patch prim) wX wY) -revCommuteFLId :: MaybeCommute prim -> (FL (Patch prim) :< Patch prim) C(x y) -> Maybe ((Patch prim :< FL (Patch prim)) C(x y))+revCommuteFLId :: MaybeCommute prim -> (FL (Patch prim) :< Patch prim) wX wY -> Maybe ((Patch prim :< FL (Patch prim)) wX wY) revCommuteFLId _ (NilFL :< p) = return (p :< NilFL) revCommuteFLId commuter ((q :>: qs) :< p) = do p' :< q' <- commuter (q :< p) p'' :< qs' <- revCommuteFLId commuter (qs :< p') return (p'' :< (q' :>: qs')) +-- | elegantMerge attempts to perform the "intuitive" merge of two patches,+-- from a common starting context @wX@. elegantMerge :: PrimPatch prim- => (Patch prim :\/: Patch prim) C(x y)- -> Maybe ((Patch prim :/\: Patch prim) C(x y))+ => (Patch prim :\/: Patch prim) wX wY+ -> Maybe ((Patch prim :/\: Patch prim) wX wY) elegantMerge (p1 :\/: p2) = do p1' :> ip2' <- commute (invert p2 :> p1) p1o :> _ <- commute (p2 :> p1')@@ -278,17 +303,24 @@ -} -actualMerge :: PrimPatch prim => (Patch prim :\/: Patch prim) C(x y) -> Sealed (Patch prim C(y))-+-- |actualMerge attempts to perform a merge; if successful, it returns the+-- "right" branch of the merge+--+-- TODO: why does this code throw away the other branch, only for merge to+-- rebuild it?+actualMerge :: PrimPatch prim => (Patch prim :\/: Patch prim) wX wY -> Sealed (Patch prim wY) actualMerge (p1 :\/: p2) = case elegantMerge (p1:\/:p2) of Just (_ :/\: p1') -> Sealed p1' Nothing -> merger "0.0" p2 p1 -unwind :: Patch prim C(x y) -> Sealed (RL (Patch prim) C(x)) -- Recreates a patch history in reverse.+-- Recreates a patch history in reverse.+unwind :: Patch prim wX wY -> Sealed (RL (Patch prim) wX) unwind (Merger _ unwindings _ _) = Sealed unwindings unwind p = Sealed (p :<: NilRL) -trueUnwind :: PrimPatch prim => Patch prim C(x y) -> Sealed (RL (Patch prim) C(x)) -- Recreates a patch history in reverse.+-- Recreates a patch history in reverse. The patch being unwound is always at+-- the start of the list of patches.+trueUnwind :: PrimPatch prim => Patch prim wX wY -> Sealed (RL (Patch prim) wX) trueUnwind p@(Merger _ _ p1 p2) = case (unwind p1, unwind p2) of (Sealed (_:<:p1s),Sealed (_:<:p2s)) ->@@ -297,7 +329,7 @@ trueUnwind _ = impossible reconcileUnwindings :: PrimPatch prim- => Patch prim C(a b) -> RL (Patch prim) C(x z) -> RL (Patch prim) C(y z) -> FlippedSeal (RL (Patch prim)) C(z)+ => Patch prim wA wB -> RL (Patch prim) wX wZ -> RL (Patch prim) wY wZ -> FlippedSeal (RL (Patch prim)) wZ reconcileUnwindings _ NilRL p2s = FlippedSeal p2s reconcileUnwindings _ p1s NilRL = FlippedSeal p1s reconcileUnwindings p (p1:<:p1s) p2s@(p2:<:tp2s) =@@ -324,7 +356,7 @@ -- it seems to have been this way forever: -- Fri May 23 10:27:04 BST 2003 droundy@abridgegame.org -- * fix bug in unwind and add docs on unwind algorithm.-putBefore :: PrimPatch prim => Patch prim C(y z) -> FL (Patch prim) C(x z) -> Maybe (FL (Patch prim) C(y w))+putBefore :: PrimPatch prim => Patch prim wY wZ -> FL (Patch prim) wX wZ -> Maybe (FL (Patch prim) wY wW) putBefore p1 (p2:>:p2s) = do p1' :> p2' <- commute (unsafeCoerceP p2 :> invert p1) _ <- commute (p2' :> p1)@@ -337,12 +369,12 @@ instance PrimPatch prim => Conflict (Patch prim) where resolveConflicts patch = rcs NilFL (patch :<: NilRL)- where rcs :: FL (Patch prim) C(y w) -> RL (Patch prim) C(x y) -> [[Sealed (FL prim C(w))]]+ where rcs :: FL (Patch prim) wY wW -> RL (Patch prim) wX wY -> [[Sealed (FL prim wW)]] rcs _ NilRL = []- rcs passedby (p@(Merger _ _ _ _):<:ps) =+ rcs passedby (p@(Merger{}):<:ps) = case revCommuteFLId commuteNoMerger (passedby:<p) of Just (p'@(Merger _ _ p1 p2):<_) ->- (map Sealed $ nubBy unsafeCompare $+ map Sealed (nubBy unsafeCompare $ effect (unsafeCoercePStart $ unsafeUnseal (glump09 p1 p2)) : map (unsafeCoercePStart . unsafeUnseal) (unravel p')) : rcs (p :>: passedby) ps Nothing -> rcs (p :>: passedby) ps@@ -351,34 +383,38 @@ rcs (p :>: passedby) ps -- This type seems wrong - the most natural type for the result would seem to be--- [Sealed (FL Prim C(x))], given the type of unwind.--- However downstream code in darcs convert assumes the C(y) type, and I was unable+-- [Sealed (FL Prim wX)], given the type of unwind.+-- However downstream code in darcs convert assumes the wY type, and I was unable -- to figure out whether this could/should reasonably be changed -- Ganesh 13/4/10-publicUnravel :: PrimPatch prim => Patch prim C(x y) -> [Sealed (FL prim C(y))]+publicUnravel :: PrimPatch prim => Patch prim wX wY -> [Sealed (FL prim wY)] publicUnravel = map (mapSeal unsafeCoercePStart) . unravel -unravel :: PrimPatch prim => Patch prim C(x y) -> [Sealed (FL prim C(x))]+unravel :: PrimPatch prim => Patch prim wX wY -> [Sealed (FL prim wX)] unravel p = nub $ map (mapSeal (sortCoalesceFL . concatFL . mapFL_FL effect)) $ getSupers $ map (mapSeal reverseRL) $ unseal (newUr p) $ unwind p -getSupers :: PrimPatch prim => [Sealed (FL (Patch prim) C(x))] -> [Sealed (FL (Patch prim) C(x))]+getSupers :: PrimPatch prim => [Sealed (FL (Patch prim) wX)] -> [Sealed (FL (Patch prim) wX)] getSupers (x:xs) = case filter (not.(x `isSuperpatchOf`)) xs of- xs' -> if or $ map (`isSuperpatchOf` x) xs'+ xs' -> if any (`isSuperpatchOf` x) xs' then getSupers xs' else x : getSupers xs' getSupers [] = [] -isSuperpatchOf :: PrimPatch prim => Sealed (FL (Patch prim) C(x)) -> Sealed (FL (Patch prim) C(x)) -> Bool+isSuperpatchOf :: PrimPatch prim => Sealed (FL (Patch prim) wX) -> Sealed (FL (Patch prim) wX) -> Bool Sealed x `isSuperpatchOf` Sealed y | lengthFL y > lengthFL x = False -- should be just an optimisation Sealed x `isSuperpatchOf` Sealed y = x `iso` y- where iso :: PrimPatch prim => FL (Patch prim) C(x y) -> FL (Patch prim) C(x z) -> Bool+ where iso :: PrimPatch prim => FL (Patch prim) wX wY -> FL (Patch prim) wX wZ -> Bool _ `iso` NilFL = True NilFL `iso` _ = False a `iso` (b:>:bs) = head $ ([as `iso` bs | (ah :>: as) <- simpleHeadPermutationsFL a, IsEq <- [ah =\/= b]] :: [Bool]) ++ [False] -merger :: PrimPatch prim => String -> Patch prim C(x y) -> Patch prim C(x z) -> Sealed (Patch prim C(y))+-- | merger takes two patches, (which have been determined to conflict) and+-- constructs a Merger patch to represent the conflict. @p1@ is considered to+-- be conflicting with @p2@ (@p1@ is the "first" patch in the repo ordering),+-- the resulting Merger is therefore a representation of @p2@.+merger :: PrimPatch prim => String -> Patch prim wX wY -> Patch prim wX wZ -> Sealed (Patch prim wY) merger "0.0" p1 p2 = Sealed $ Merger undoit unwindings p1 p2 where fake_p = Merger NilFL NilRL p1 p2 unwindings = unsafeUnseal (trueUnwind fake_p)@@ -389,25 +425,25 @@ Sealed (_:<:t) -> unsafeCoerceP $ invertRL t _ -> impossible (False,False) -> unsafeCoerceP $ invert p1 :>: NilFL- (True ,False) -> unsafeCoerceP $ NilFL+ (True ,False) -> unsafeCoerceP NilFL (False,True ) -> unsafeCoerceP $ invert p1 :>: mergerUndo p2 merger g _ _ = error $ "Cannot handle mergers other than version 0.0\n"++g ++ "\nPlease use darcs optimize --modernize with an older darcs." -glump09 :: PrimPatch prim => Patch prim C(x y) -> Patch prim C(x z) -> Sealed (FL (Patch prim) C(y))+glump09 :: PrimPatch prim => Patch prim wX wY -> Patch prim wX wZ -> Sealed (FL (Patch prim) wY) glump09 p1 p2 = mapSeal (mapFL_FL fromPrim) $ mangleUnravelled $ unseal unravel $ merger "0.0" p1 p2 instance PrimPatch prim => Effect (Patch prim) where- effect p@(Merger _ _ _ _) = sortCoalesceFL $ effect $ mergerUndo p- effect p@(Regrem _ _ _ _) = invert $ effect $ invert p+ effect p@(Merger{}) = sortCoalesceFL $ effect $ mergerUndo p+ effect p@(Regrem{}) = invert $ effect $ invert p effect (PP p) = p :>: NilFL instance IsHunk prim => IsHunk (Patch prim) where isHunk p = do PP p' <- return p isHunk p' -newUr :: PrimPatch prim => Patch prim C(a b) -> RL (Patch prim) C(x y) -> [Sealed (RL (Patch prim) C(x))]+newUr :: PrimPatch prim => Patch prim wA wB -> RL (Patch prim) wX wY -> [Sealed (RL (Patch prim) wX)] newUr p (Merger _ _ p1 p2 :<: ps) = case filter (\(pp:<:_) -> pp `unsafeCompare` p1) $ headPermutationsRL ps of ((_:<:ps'):_) -> newUr p (unsafeCoercePStart p1:<:ps') ++ newUr p (unsafeCoercePStart p2:<:ps')@@ -432,10 +468,10 @@ instance MyEq prim => MyEq (Patch prim) where unsafeCompare = eqPatches -instance MyEq prim => Eq (Patch prim C(x y)) where+instance MyEq prim => Eq (Patch prim wX wY) where (==) = unsafeCompare -eqPatches :: MyEq prim => Patch prim C(x y) -> Patch prim C(w z) -> Bool+eqPatches :: MyEq prim => Patch prim wX wY -> Patch prim wW wZ -> Bool eqPatches (PP p1) (PP p2) = unsafeCompare p1 p2 eqPatches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b) = eqPatches p1a p2a &&
src/Darcs/Patch/V1/Core.hs view
@@ -1,42 +1,90 @@+{-# LANGUAGE CPP #-} module Darcs.Patch.V1.Core ( Patch(..), isMerger, mergerUndo ) where import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(ListFormatV1) )+import Darcs.Patch.Debug ( PatchDebug(..) )+import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Patch.Prim ( FromPrim(..), PrimOf, PrimPatchBase, PrimPatch )+import Darcs.Patch.Rebase.NameHack ( NameHack )+import Darcs.Patch.Rebase.Recontext ( RecontextRebase ) import Darcs.Patch.Repair ( Check ) -import Darcs.Witnesses.Ordered ( FL(..), RL )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL )+import Darcs.Patch.Witnesses.Show+ ( Show1(..), Show2(..)+ , ShowDict(ShowDictClass)+ , appPrec, showsPrec2+ ) -#include "gadts.h" #include "impossible.h" -data Patch prim C(x y) where- PP :: prim C(x y) -> Patch prim C(x y)- Merger :: FL (Patch prim) C(x y)- -> RL (Patch prim) C(x b)- -> Patch prim C(c b)- -> Patch prim C(c d)- -> Patch prim C(x y)- Regrem :: FL (Patch prim) C(x y)- -> RL (Patch prim) C(x b)- -> Patch prim C(c b)- -> Patch prim C(c a)- -> Patch prim C(y x)+-- This haddock could be put on the individual bits of Merger instead+-- once haddock supports doc comments on GADT constructors+{- |+The format of a merger is @Merger undos unwindings conflicting original@. +@undos@ = the effect of the merger++@unwindings@ = TODO: eh?++@conflicting@ = the patch we conflict with++@original@ = the patch we really are+-}+data Patch prim wX wY where+ PP :: prim wX wY -> Patch prim wX wY+ Merger :: FL (Patch prim) wX wY+ -> RL (Patch prim) wX wB+ -> Patch prim wC wB+ -> Patch prim wC wD+ -> Patch prim wX wY+ Regrem :: FL (Patch prim) wX wY+ -> RL (Patch prim) wX wB+ -> Patch prim wC wB+ -> Patch prim wC wA+ -> Patch prim wY wX++instance Show2 prim => Show (Patch prim wX wY) where+ showsPrec d (PP p) =+ showParen (d > appPrec) $ showString "PP " . showsPrec2 (appPrec + 1) p+ showsPrec d (Merger undos unwindings conflicting original) =+ showParen (d > appPrec) $+ showString "Merger " . showsPrec2 (appPrec + 1) undos .+ showString " " . showsPrec2 (appPrec + 1) unwindings .+ showString " " . showsPrec2 (appPrec + 1) conflicting .+ showString " " . showsPrec2 (appPrec + 1) original+ showsPrec d (Regrem undos unwindings conflicting original) =+ showParen (d > appPrec) $+ showString "Regrem " . showsPrec2 (appPrec + 1) undos .+ showString " " . showsPrec2 (appPrec + 1) unwindings .+ showString " " . showsPrec2 (appPrec + 1) conflicting .+ showString " " . showsPrec2 (appPrec + 1) original++instance Show2 prim => Show1 (Patch prim wX) where+ showDict1 = ShowDictClass++instance Show2 prim => Show2 (Patch prim) where+ showDict2 = ShowDictClass++instance MaybeInternal (Patch prim)+instance NameHack (Patch prim)+instance RecontextRebase (Patch prim)+ instance PrimPatch prim => PrimPatchBase (Patch prim) where type PrimOf (Patch prim) = prim instance FromPrim (Patch prim) where fromPrim = PP -isMerger :: Patch prim C(a b) -> Bool-isMerger (Merger _ _ _ _) = True-isMerger (Regrem _ _ _ _) = True+isMerger :: Patch prim wA wB -> Bool+isMerger (Merger{}) = True+isMerger (Regrem{}) = True isMerger _ = False -mergerUndo :: Patch prim C(x y) -> FL (Patch prim) C(x y)+mergerUndo :: Patch prim wX wY -> FL (Patch prim) wX wY mergerUndo (Merger undo _ _ _) = undo mergerUndo _ = impossible @@ -49,3 +97,5 @@ instance Check (Patch prim) -- no checks++instance PatchDebug prim => PatchDebug (Patch prim)
src/Darcs/Patch/V1/Read.hs view
@@ -10,22 +10,21 @@ import Darcs.Patch.V1.Core ( Patch(..) ) import Darcs.Patch.V1.Commute ( merger ) -import Darcs.Witnesses.Sealed ( Sealed(..), seal, mapSeal )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, mapSeal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Control.Monad ( liftM ) import qualified Data.ByteString.Char8 as BC ( unpack, pack ) import qualified Data.ByteString as B (ByteString ) -#include "gadts.h" instance PrimPatch prim => ReadPatch (Patch prim) where readPatch' = choice [ liftM seal $ skipSpace >> readMerger True , liftM seal $ skipSpace >> readMerger False- , liftM (mapSeal PP) $ readPatch'+ , liftM (mapSeal PP) readPatch' ]-readMerger :: (ParserM m, PrimPatch prim) => Bool -> m (Patch prim C(x y))+readMerger :: (ParserM m, PrimPatch prim) => Bool -> m (Patch prim wX wY) readMerger b = do string s g <- myLex' lexChar '('
src/Darcs/Patch/V1/Show.hs view
@@ -6,27 +6,16 @@ import Darcs.Patch.V1.Core ( Patch(..) ) -import Darcs.Witnesses.Show ( Show1(..), Show2(..), ShowDict(..) )--import Printer ( Doc, renderString,+import Darcs.Util.Printer ( Doc, text, blueText, ($$), (<+>) ) -#include "gadts.h"--instance PrimPatch prim => Show (Patch prim C(x y)) where- show p = renderString (showPatch_ p) ++ "\n"-instance PrimPatch prim => Show1 (Patch prim C(x)) where- showDict1 = ShowDictClass-instance PrimPatch prim => Show2 (Patch prim) where- showDict2 = ShowDictClass--showPatch_ :: PrimPatch prim => Patch prim C(a b) -> Doc+showPatch_ :: PrimPatch prim => Patch prim wA wB -> Doc showPatch_ (PP p) = showPrim OldFormat p showPatch_ (Merger _ _ p1 p2) = showMerger "merger" p1 p2 showPatch_ (Regrem _ _ p1 p2) = showMerger "regrem" p1 p2 -showMerger :: PrimPatch prim => String -> Patch prim C(a b) -> Patch prim C(d e) -> Doc+showMerger :: PrimPatch prim => String -> Patch prim wA wB -> Patch prim wD wE -> Doc showMerger merger_name p1 p2 = blueText merger_name <+> text "0.0" <+> blueText "(" $$ showPatch_ p1
src/Darcs/Patch/V1/Viewing.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE ViewPatterns #-} module Darcs.Patch.V1.Viewing () where import Darcs.Patch.Prim ( PrimPatch )@@ -10,7 +9,6 @@ import Darcs.Patch.V1.Core ( Patch(..) ) import Darcs.Patch.V1.Show ( showPatch_ ) -#include "gadts.h" instance PrimPatch prim => ShowPatchBasic (Patch prim) where showPatch = showPatch_
src/Darcs/Patch/V2.hs view
@@ -1,9 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V2 ( RealPatch, prim2real ) where +import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.RepoPatch ( RepoPatch ) import Darcs.Patch.V2.Real ( RealPatch, prim2real ) +instance PrimPatch prim => Matchable (RealPatch prim) instance PrimPatch prim => RepoPatch (RealPatch prim)
src/Darcs/Patch/V2/Non.hs view
@@ -18,7 +18,6 @@ {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} {-# LANGUAGE CPP, FlexibleContexts, UndecidableInstances #-} -#include "gadts.h" module Darcs.Patch.V2.Non ( Non(..)@@ -40,7 +39,11 @@ , (>>*) ) where +#if MIN_VERSION_base(4,8,0)+import Prelude hiding ( rem, (*>) )+#else import Prelude hiding ( rem )+#endif import Data.List ( delete ) import Control.Monad ( liftM, mzero ) import Darcs.Patch.Commute ( commuteFL )@@ -54,30 +57,32 @@ import Darcs.Patch.Patchy ( Patchy, showPatch, ReadPatch(..), Commute(..), invert ) import Darcs.Patch.ReadMonads ( ParserM, lexChar )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (+>+), mapRL_RL- , (:>)(..), reverseFL, reverseRL )+import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), RL(..), (+>+), mapRL_RL+ , (:>)(..), reverseFL, reverseRL )+import Darcs.Patch.Witnesses.Show+ ( ShowDict(..), Show1(..), Show2(..), appPrec+ , showsPrec2 )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Patch.Read ( peekfor ) import Darcs.Patch.Show ( ShowPatchBasic ) import Darcs.Patch.Viewing () import Darcs.Patch.Permutations ( removeFL, commuteWhatWeCanFL )-import Darcs.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..), appPrec- , showsPrec2 )-import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-import Printer ( Doc, empty, vcat, hiddenPrefix, blueText, ($$) )+import Darcs.Util.Printer ( Doc, empty, vcat, hiddenPrefix, blueText, ($$) ) import qualified Data.ByteString.Char8 as BC ( pack, singleton ) -- |A 'Non' stores a context with a 'Prim' patch. It is a patch whose effect -- isn't visible - a Non-affecting patch.-data Non p C(x) where- Non :: FL p C(x y) -> PrimOf p C(y z) -> Non p C(x)+data Non p wX where+ Non :: FL p wX wY -> PrimOf p wY wZ -> Non p wX -- |unNon converts a Non into a FL of its context followed by the primitive -- patch.-unNon :: FromPrim p => Non p C(x) -> Sealed (FL p C(x))+unNon :: FromPrim p => Non p wX -> Sealed (FL p wX) unNon (Non c x) = Sealed (c +>+ fromPrim x :>: NilFL) -instance (Show2 p, Show2 (PrimOf p)) => Show (Non p C(x)) where+instance (Show2 p, Show2 (PrimOf p)) => Show (Non p wX) where showsPrec d (Non cs p) = showParen (d > appPrec) $ showString "Non " . showsPrec2 (appPrec + 1) cs . showString " " . showsPrec2 (appPrec + 1) p@@ -87,12 +92,12 @@ -- |showNons creates a Doc representing a list of Nons. showNons :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p)- => [Non p C(x)] -> Doc+ => [Non p wX] -> Doc showNons [] = empty showNons xs = blueText "{{" $$ vcat (map showNon xs) $$ blueText "}}" -- |showNon creates a Doc representing a Non.-showNon :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => Non p C(x)+showNon :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => Non p wX -> Doc showNon (Non c p) = hiddenPrefix "|" (showPatch c) $$ hiddenPrefix "|" (blueText ":")@@ -100,7 +105,7 @@ -- |readNons is a parser that attempts to read a list of Nons. readNons :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m)- => m [Non p C(x)]+ => m [Non p wX] readNons = peekfor (BC.pack "{{") rns (return []) where rns = peekfor (BC.pack "}}") (return []) $ do Sealed ps <- readPatch'@@ -110,7 +115,7 @@ -- |readNon is a parser that attempts to read a single Non. readNon :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m)- => m (Non p C(x))+ => m (Non p wX) readNon = do Sealed ps <- readPatch' let doReadPrim = do Sealed p <- readPrim NewFormat return $ Non ps p@@ -118,25 +123,25 @@ -- |Nons are equal if their context patches are equal, and they have an equal -- prim patch.-instance (Commute p, MyEq p, MyEq (PrimOf p)) => Eq (Non p C(x)) where- Non (cx :: FL p C(x y1)) (x :: PrimOf p C(y1 z1))- == Non (cy :: FL p C(x y2)) (y :: PrimOf p C(y2 z2)) =+instance (Commute p, MyEq p, MyEq (PrimOf p)) => Eq (Non p wX) where+ Non (cx :: FL p wX wY1) (x :: PrimOf p wY1 wZ1)+ == Non (cy :: FL p wX wY2) (y :: PrimOf p wY2 wZ2) = case cx =\/= cy of- IsEq -> case x =\/= y :: EqCheck C(z1 z2) of+ IsEq -> case x =\/= y :: EqCheck wZ1 wZ2 of IsEq -> True NotEq -> False NotEq -> False -- |Nonable represents the class of patches that can be turned into a Non. class Nonable p where- non :: p C(x y) -> Non p C(x)+ non :: p wX wY -> Non p wX -- |'commuteOrAddToCtx' @x cy@ tries to commute @x@ past @cy@ and always -- returns some variant @cy'@. If commutation suceeds, the variant is just -- straightforwardly the commuted version. If commutation fails, the variant -- consists of @x@ prepended to the context of @cy@.-commuteOrAddToCtx :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y)- -> Non p C(x)+commuteOrAddToCtx :: (Patchy p, ToFromPrim p) => p wX wY -> Non p wY+ -> Non p wX commuteOrAddToCtx p n | Just n' <- p >* n = n' commuteOrAddToCtx p (Non c x) = Non (p:>:c) x @@ -152,16 +157,16 @@ -- > x1 [c1'' c2'' y''] x2' x3' -- -- and return @[x1 c1'' c2'' y'']@-commuteOrAddToCtxRL :: (Patchy p, ToFromPrim p) => RL p C(x y) -> Non p C(y)- -> Non p C(x)+commuteOrAddToCtxRL :: (Patchy p, ToFromPrim p) => RL p wX wY -> Non p wY+ -> Non p wX commuteOrAddToCtxRL NilRL n = n commuteOrAddToCtxRL (p:<:ps) n = commuteOrAddToCtxRL ps $ commuteOrAddToCtx p n -- |abstract over 'FL'/'RL' class WL l where- toFL :: l p C(x y) -> FL p C(x y)- toRL :: l p C(x y) -> RL p C(x y)- invertWL :: Invert p => l p C(x y) -> l p C(y x)+ toFL :: l p wX wY -> FL p wX wY+ toRL :: l p wX wY -> RL p wX wY+ invertWL :: Invert p => l p wX wY -> l p wY wX instance WL FL where toFL = id@@ -175,8 +180,8 @@ -- |commutePrimsOrAddToCtx takes a WL of prims and attempts to commute them -- past a Non.-commutePrimsOrAddToCtx :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) C(x y)- -> Non p C(y) -> Non p C(x)+commutePrimsOrAddToCtx :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) wX wY+ -> Non p wY -> Non p wX commutePrimsOrAddToCtx q = commuteOrAddToCtxRL (mapRL_RL fromPrim $ toRL q) -- TODO: Figure out what remNons is for; it's is only used in one place - when@@ -194,22 +199,22 @@ -- modify p2, so that it doesn't have any of a1' in its context. -- remNons really only works right if the relevant nons are conflicting...-remNons :: (Nonable p, Effect p, Patchy p, ToFromPrim p, PrimPatchBase p,- MyEq (PrimOf p)) => [Non p C(x)] -> Non p C(x) -> Non p C(x)+remNons :: (Nonable p, Effect p, Patchy p, MyEq p, ToFromPrim p, PrimPatchBase p,+ MyEq (PrimOf p)) => [Non p wX] -> Non p wX -> Non p wX remNons ns n@(Non c x) = case remNonHelper ns c of NilFL :> c' -> Non c' x _ -> n where- remNonHelper :: (Nonable p, Effect p, Patchy p, ToFromPrim p,- PrimPatchBase p, MyEq (PrimOf p)) => [Non p C(x)]- -> FL p C(x y) -> (FL (PrimOf p) :> FL p) C(x y)+ remNonHelper :: (Nonable p, Effect p, Patchy p, MyEq p, ToFromPrim p,+ PrimPatchBase p, MyEq (PrimOf p)) => [Non p wX]+ -> FL p wX wY -> (FL (PrimOf p) :> FL p) wX wY remNonHelper [] x = NilFL :> x remNonHelper _ NilFL = NilFL :> NilFL remNonHelper ns (c:>:cs) | non c `elem` ns = let nsWithoutC = delete (non c) ns in let commuteOrAddInvC = commuteOrAddToCtx $ invert c in- case remNonHelper (map commuteOrAddInvC $ nsWithoutC) cs of+ case remNonHelper (map commuteOrAddInvC nsWithoutC) cs of a :> z -> sortCoalesceFL (effect c +>+ a) :> z | otherwise = case commuteWhatWeCanFL (c :> cs) of b :> c' :> d -> case remNonHelper ns b of@@ -223,27 +228,27 @@ -- -- TODO: understand if there is any case where p is equal to the prim patch of -- the Non, in which case, we return the original Non, is that right?-commuteOrRemFromCtx :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(x)- -> Maybe (Non p C(y))+commuteOrRemFromCtx :: (Patchy p, MyEq p, ToFromPrim p) => p wX wY -> Non p wX+ -> Maybe (Non p wY) commuteOrRemFromCtx p n | n'@(Just _) <- n *> p = n' commuteOrRemFromCtx p (Non pc x) = removeFL p pc >>= \c -> return (Non c x) -- |commuteOrRemFromCtxFL attempts to remove a FL of patches from a Non, -- returning Nothing if any of the individual removes fail.-commuteOrRemFromCtxFL :: (Patchy p, ToFromPrim p) => FL p C(x y) -> Non p C(x)- -> Maybe (Non p C(y))+commuteOrRemFromCtxFL :: (Patchy p, MyEq p, ToFromPrim p) => FL p wX wY -> Non p wX+ -> Maybe (Non p wY) commuteOrRemFromCtxFL NilFL n = Just n commuteOrRemFromCtxFL (p:>:ps) n = do n' <- commuteOrRemFromCtx p n commuteOrRemFromCtxFL ps n' -- |(*>) attemts to modify a Non by commuting it past a given patch.-(*>) :: (Patchy p, ToFromPrim p) => Non p C(x) -> p C(x y)- -> Maybe (Non p C(y))+(*>) :: (Patchy p, ToFromPrim p) => Non p wX -> p wX wY+ -> Maybe (Non p wY) n *> p = invert p >* n -- |(>*) attempts to modify a Non, by commuting a given patch past it.-(>*) :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y)- -> Maybe (Non p C(x))+(>*) :: (Patchy p, ToFromPrim p) => p wX wY -> Non p wY+ -> Maybe (Non p wX) y >* (Non c x) = do c' :> y' <- commuteFL (y :> c) px' :> _ <- commute (y' :> fromPrim x)@@ -251,16 +256,16 @@ return (Non c' x') -- |(*>>) attempts to modify a Non by commuting it past a given WL of patches.-(*>>) :: (WL l, Patchy p, ToFromPrim p, PrimPatchBase p) => Non p C(x)- -> l (PrimOf p) C(x y) -> Maybe (Non p C(y))+(*>>) :: (WL l, Patchy p, ToFromPrim p, PrimPatchBase p) => Non p wX+ -> l (PrimOf p) wX wY -> Maybe (Non p wY) n *>> p = invertWL p >>* n -- |(>>*) attempts to modify a Non by commuting a given WL of patches past it.-(>>*) :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) C(x y) -> Non p C(y)- -> Maybe (Non p C(x))+(>>*) :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) wX wY -> Non p wY+ -> Maybe (Non p wX) ps >>* n = commuteRLPastNon (toRL ps) n where- commuteRLPastNon :: (Patchy p, ToFromPrim p) => RL (PrimOf p) C(x y)- -> Non p C(y) -> Maybe (Non p C(x))+ commuteRLPastNon :: (Patchy p, ToFromPrim p) => RL (PrimOf p) wX wY+ -> Non p wY -> Maybe (Non p wX) commuteRLPastNon NilRL n = Just n commuteRLPastNon (x:<:xs) n = fromPrim x >* n >>= commuteRLPastNon xs
src/Darcs/Patch/V2/Real.hs view
@@ -18,7 +18,6 @@ {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} {-# LANGUAGE CPP #-} -#include "gadts.h" module Darcs.Patch.V2.Real ( RealPatch(..)@@ -29,27 +28,34 @@ , mergeUnravelled ) where +#if MIN_VERSION_base(4,8,0)+import Prelude hiding ( (*>) )+#endif+ import Control.Monad ( mplus, liftM ) import qualified Data.ByteString.Char8 as BC ( ByteString, pack ) import Data.Maybe ( fromMaybe ) import Data.List ( partition, nub ) -import Darcs.ColorPrinter ( errorDoc, assertDoc ) import Darcs.Patch.Commute ( commuteFL, commuteFLorComplain, commuteRL , commuteRLFL ) import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) , IsConflictedPrim(..), ConflictState(..) ) import Darcs.Patch.ConflictMarking ( mangleUnravelled )+import Darcs.Patch.Debug import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..) , FileNameFormat(NewFormat) ) import Darcs.Patch.Invert ( invertFL, invertRL )+import Darcs.Patch.MaybeInternal ( MaybeInternal ) import Darcs.Patch.Merge ( Merge(..) ) import Darcs.Patch.Prim ( FromPrim(..), ToFromPrim(..), showPrim, showPrimFL , readPrim, PrimOf, PrimPatchBase, PrimPatch ) import Darcs.Patch.Read ( bracketedFL ) import Darcs.Patch.ReadMonads ( skipSpace, string, choice )+import Darcs.Patch.Rebase.NameHack ( NameHack )+import Darcs.Patch.Rebase.Recontext ( RecontextRebase ) import Darcs.Patch.Repair ( mapMaybeSnd, RepairToFL(..), Check(..) ) import Darcs.Patch.Patchy ( Patchy, Apply(..), Commute(..), PatchInspect(..) , ReadPatch(..), ShowPatch(..), Invert(..) )@@ -63,17 +69,23 @@ , commuteOrAddToCtx, commuteOrAddToCtxRL , commuteOrRemFromCtx, commuteOrRemFromCtxFL , remNons, (*>), (>*), (*>>), (>>*) )-import Darcs.Utils ( nubsort )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+), (+<+)- , mapFL_FL, reverseFL, (:\/:)(..), (:/\:)(..)- , reverseRL, lengthFL, lengthRL, nullFL )-import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal- , unseal )-import Darcs.Witnesses.Show ( Show2(..), ShowDict(..) )+import Data.List.Ordered ( nubSort )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), RL(..), (:>)(..), (+>+), (+<+)+ , mapFL_FL, reverseFL, (:\/:)(..), (:/\:)(..)+ , reverseRL, lengthFL, lengthRL, nullFL )+import Darcs.Patch.Witnesses.Sealed+ ( FlippedSeal(..), Sealed(Sealed), mapSeal+ , unseal )+import Darcs.Patch.Witnesses.Show+ ( Show1(..), Show2(..), ShowDict(..)+ , showsPrec2, appPrec+ )+import Darcs.Util.Printer.Color ( errorDoc, assertDoc ) -import Printer ( Doc, renderString, blueText, redText, (<+>), ($$) )+import Darcs.Util.Printer ( Doc, blueText, redText, (<+>), ($$) ) #include "impossible.h" @@ -106,30 +118,30 @@ -- Therefore, the effect of a Conflictor is @invert xx@. -- -- @InvConflictor ix xx x@: like @invert (Conflictor ix xx x)@-data RealPatch prim C(x y) where- Duplicate :: Non (RealPatch prim) C(x) -> RealPatch prim C(x x)- Etacilpud :: Non (RealPatch prim) C(x) -> RealPatch prim C(x x)- Normal :: prim C(x y) -> RealPatch prim C(x y)- Conflictor :: [Non (RealPatch prim) C(x)] -> FL prim C(x y)- -> Non (RealPatch prim) C(x) -> RealPatch prim C(y x)- InvConflictor :: [Non (RealPatch prim) C(x)] -> FL prim C(x y)- -> Non (RealPatch prim) C(x) -> RealPatch prim C(x y)+data RealPatch prim wX wY where+ Duplicate :: Non (RealPatch prim) wX -> RealPatch prim wX wX+ Etacilpud :: Non (RealPatch prim) wX -> RealPatch prim wX wX+ Normal :: prim wX wY -> RealPatch prim wX wY+ Conflictor :: [Non (RealPatch prim) wX] -> FL prim wX wY+ -> Non (RealPatch prim) wX -> RealPatch prim wY wX+ InvConflictor :: [Non (RealPatch prim) wX] -> FL prim wX wY+ -> Non (RealPatch prim) wX -> RealPatch prim wX wY instance PrimPatch prim => PrimPatchBase (RealPatch prim) where type PrimOf (RealPatch prim) = prim -- | 'isDuplicate' @p@ is @True@ if @p@ is either a 'Duplicate' or 'Etacilpud' -- patch.-isDuplicate :: RealPatch prim C(s y) -> Bool+isDuplicate :: RealPatch prim wS wY -> Bool isDuplicate (Duplicate _) = True isDuplicate (Etacilpud _) = True isDuplicate _ = False -- | 'isForward' @p@ is @True@ if @p@ is either an 'InvConflictor' or -- 'Etacilpud'.-isForward :: PrimPatch prim => RealPatch prim C(s y) -> Maybe Doc+isForward :: PrimPatch prim => RealPatch prim wS wY -> Maybe Doc isForward p = case p of- p@(InvConflictor _ _ _) -> justRedP "An inverse conflictor" p+ p@(InvConflictor{}) -> justRedP "An inverse conflictor" p p@(Etacilpud _) -> justRedP "An inverse duplicate" p _ -> Nothing where@@ -137,8 +149,8 @@ -- |'mergeUnravelled' is used when converting from Darcs V1 patches (Mergers) -- to Darcs V2 patches (Conflictors).-mergeUnravelled :: PrimPatch prim => [Sealed ((FL prim) C(x))]- -> Maybe (FlippedSeal (RealPatch prim) C(x))+mergeUnravelled :: PrimPatch prim => [Sealed ((FL prim) wX)]+ -> Maybe (FlippedSeal (RealPatch prim) wX) mergeUnravelled [] = Nothing mergeUnravelled [_] = Nothing mergeUnravelled ws =@@ -147,29 +159,29 @@ Just NilRL -> bug "found no patches in mergeUnravelled" Just (z :<: _) -> Just $ FlippedSeal z where- notNullS :: PrimPatch prim => Sealed ((FL prim) C(x)) -> Bool+ notNullS :: PrimPatch prim => Sealed ((FL prim) wX) -> Bool notNullS (Sealed NilFL) = False notNullS _ = True - mergeUnravelled_private :: PrimPatch prim => [Sealed (FL prim C(x))]- -> Maybe (RL (RealPatch prim) C(x x))+ mergeUnravelled_private :: PrimPatch prim => [Sealed (FL prim wX)]+ -> Maybe (RL (RealPatch prim) wX wX) mergeUnravelled_private xs = let nonNullXs = filter notNullS xs in reverseFL `fmap` mergeConflictingNons (map sealed2non nonNullXs) -- | 'sealed2non' @(Sealed xs)@ converts @xs@ to a 'Non'. -- @xs@ must be non-empty since we split this list at the last patch, -- taking @init xs@ as the context of @last xs@.- sealed2non :: Sealed ((FL prim) C(x)) -> Non (RealPatch prim) C(x)+ sealed2non :: Sealed ((FL prim) wX) -> Non (RealPatch prim) wX sealed2non (Sealed xs) = case reverseFL xs of y :<: ys -> Non (mapFL_FL fromPrim $ reverseRL ys) y NilRL -> bug "NilFL encountered in sealed2non" -mergeConflictingNons :: PrimPatch prim => [Non (RealPatch prim) C(x)]- -> Maybe (FL (RealPatch prim) C(x x))+mergeConflictingNons :: PrimPatch prim => [Non (RealPatch prim) wX]+ -> Maybe (FL (RealPatch prim) wX wX) mergeConflictingNons ns = mcn $ map unNon ns- where mcn :: PrimPatch prim => [Sealed (FL (RealPatch prim) C(x))]- -> Maybe (FL (RealPatch prim) C(x x))+ where mcn :: PrimPatch prim => [Sealed (FL (RealPatch prim) wX)]+ -> Maybe (FL (RealPatch prim) wX wX) mcn [] = Just NilFL -- Apparently, the joinEffects call is a safety check "and could be -- removed when we're sure of the code"!@@ -182,18 +194,18 @@ case merge (ps :\/: qs) of qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs) -joinEffects :: forall p C(x y) . (Effect p, Invert (PrimOf p),- Commute (PrimOf p), MyEq (PrimOf p)) => p C(x y)- -> FL (PrimOf p) C(x y)+joinEffects :: forall p wX wY . (Effect p, Invert (PrimOf p),+ Commute (PrimOf p), MyEq (PrimOf p)) => p wX wY+ -> FL (PrimOf p) wX wY joinEffects = joinInverses . effect- where joinInverses :: FL (PrimOf p) C(a b) -> FL (PrimOf p) C(a b)+ where joinInverses :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wB joinInverses NilFL = NilFL joinInverses (p :>: ps) = let ps' = joinInverses ps in fromMaybe (p :>: ps') $ removeFL (invert p) ps' -assertConsistent :: PrimPatch prim => RealPatch prim C(x y)- -> RealPatch prim C(x y)+assertConsistent :: PrimPatch prim => RealPatch prim wX wY+ -> RealPatch prim wX wY assertConsistent x = flip assertDoc x $ do e <- isConsistent x Just (redText "Inconsistent patch:" $$ showPatch x $$ e)@@ -212,15 +224,15 @@ -- The first output is the set of patches from @xxx@ that are depended upon by -- @yyy@.-mergeAfterConflicting :: PrimPatch prim => FL (RealPatch prim) C(x x)- -> FL prim C(x y) -> Maybe ( FL (RealPatch prim) C(x x)- , FL (RealPatch prim) C(x y))+mergeAfterConflicting :: PrimPatch prim => FL (RealPatch prim) wX wX+ -> FL prim wX wY -> Maybe ( FL (RealPatch prim) wX wX+ , FL (RealPatch prim) wX wY) mergeAfterConflicting xxx yyy = mac (reverseFL xxx) yyy NilFL where mac :: PrimPatch prim- => RL (RealPatch prim) C(x y) -> FL prim C(y z)- -> FL (RealPatch prim) C(z a)- -> Maybe (FL (RealPatch prim) C(x x), FL (RealPatch prim) C(x a))+ => RL (RealPatch prim) wX wY -> FL prim wY wZ+ -> FL (RealPatch prim) wZ wA+ -> Maybe (FL (RealPatch prim) wX wX, FL (RealPatch prim) wX wA) mac NilRL xs goneby = case joinEffects goneby of NilFL -> Just (NilFL, mapFL_FL Normal xs) _ -> Nothing@@ -248,8 +260,8 @@ NilFL <- return pa return (reverseRL (p' :<: a) +>+ b', xs') -geteff :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y)- -> ([Non (RealPatch prim) C(x)], FL (RealPatch prim) C(x y))+geteff :: PrimPatch prim => [Non (RealPatch prim) wX] -> FL prim wX wY+ -> ([Non (RealPatch prim) wX], FL (RealPatch prim) wX wY) geteff _ NilFL = ([], NilFL) geteff ix (x :>: xs) | Just ix' <- mapM (commuteOrRemFromCtx (Normal x)) ix = case geteff ix' xs of@@ -272,28 +284,28 @@ redText "and xx" $$ showPatch xx $$ redText "and rix" $$ showPatch rix -xx2nons :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y)- -> [Non (RealPatch prim) C(x)]+xx2nons :: PrimPatch prim => [Non (RealPatch prim) wX] -> FL prim wX wY+ -> [Non (RealPatch prim) wX] xx2nons ix xx = fst $ geteff ix xx -xx2patches :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y)- -> FL (RealPatch prim) C(x y)+xx2patches :: PrimPatch prim => [Non (RealPatch prim) wX] -> FL prim wX wY+ -> FL (RealPatch prim) wX wY xx2patches ix xx = snd $ geteff ix xx -- | If @xs@ consists only of 'Normal' patches, 'allNormal' @xs@ returns -- @Just pxs@ those patches (so @lengthFL pxs == lengthFL xs@). -- Otherwise, it returns 'Nothing'.-allNormal :: FL (RealPatch prim) C(x y) -> Maybe (FL prim C(x y))+allNormal :: FL (RealPatch prim) wX wY -> Maybe (FL prim wX wY) allNormal (Normal x :>: xs) = (x :>: ) `fmap` allNormal xs allNormal NilFL = Just NilFL allNormal _ = Nothing -- | This is used for unit-testing and for internal sanity checks-isConsistent :: PrimPatch prim => RealPatch prim C(x y) -> Maybe Doc+isConsistent :: PrimPatch prim => RealPatch prim wX wY -> Maybe Doc isConsistent (Normal _) = Nothing isConsistent (Duplicate _) = Nothing isConsistent (Etacilpud _) = Nothing-isConsistent c@(InvConflictor _ _ _) = isConsistent (invert c)+isConsistent c@(InvConflictor{}) = isConsistent (invert c) isConsistent (Conflictor im mm m@(Non deps _)) | not $ everyoneConflicts im = Just $ redText "Someone doesn't conflict in im in isConsistent"@@ -315,27 +327,31 @@ showNons imnc where (nmm, rmm) = geteff im mm -everyoneConflicts :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> Bool+everyoneConflicts :: PrimPatch prim => [Non (RealPatch prim) wX] -> Bool everyoneConflicts [] = True everyoneConflicts (x : xs) = case allConflictsWith x xs of ([], _) -> False (_, xs') -> everyoneConflicts xs' -prim2real :: prim C(x y) -> RealPatch prim C(x y)+prim2real :: prim wX wY -> RealPatch prim wX wY prim2real = Normal +instance MaybeInternal (RealPatch prim)+instance NameHack (RealPatch prim)+instance RecontextRebase (RealPatch prim) instance PrimPatch prim => Patchy (RealPatch prim)+instance PatchDebug prim => PatchDebug (RealPatch prim) -mergeWith :: PrimPatch prim => Non (RealPatch prim) C(x)- -> [Non (RealPatch prim) C(x)] -> Sealed (FL prim C(x))+mergeWith :: PrimPatch prim => Non (RealPatch prim) wX+ -> [Non (RealPatch prim) wX] -> Sealed (FL prim wX) mergeWith p [] = effect `mapSeal` unNon p mergeWith p xs = mergeall . map unNon . (p :) . unconflicting_of $ nonDependsOrConflictsP xs where nonDependsOrConflictsP = filter (\x -> not ((p `dependsUpon` x) || (p `conflictsWith` x)))- mergeall :: PrimPatch prim => [Sealed (FL (RealPatch prim) C(x))]- -> Sealed (FL prim C(x))+ mergeall :: PrimPatch prim => [Sealed (FL (RealPatch prim) wX)]+ -> Sealed (FL prim wX) mergeall [Sealed x] = Sealed $ effect x mergeall [] = Sealed NilFL mergeall (Sealed x : Sealed y : rest) =@@ -350,7 +366,7 @@ conflictedEffect (Duplicate (Non _ x)) = [IsC Duplicated x] conflictedEffect (Etacilpud _) = impossible conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x]- conflictedEffect (InvConflictor _ _ _) = impossible+ conflictedEffect (InvConflictor{}) = impossible conflictedEffect (Normal x) = [IsC Okay x] resolveConflicts (Conflictor ix xx x) = [mangledUnravelled : unravelled] where@@ -362,7 +378,7 @@ -- containing a Non, in the case where we have a Normal patch at the -- end of the list (using the rest of the RL as context), and an empty -- list otherwise.- nonxx_ :: RL (RealPatch prim) C(x y) -> [Non (RealPatch prim) C(x)]+ nonxx_ :: RL (RealPatch prim) wX wY -> [Non (RealPatch prim) wX] nonxx_ (Normal q :<: qs) = [Non (reverseRL qs) q] nonxx_ _ = [] isCons = unseal (not . nullFL)@@ -413,7 +429,7 @@ return (Conflictor iy' (invert iyy') y' :> Normal x') -- Handle via the previous case, using the inverting commuter.- commuteNoConflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c+ commuteNoConflicts c@(InvConflictor{} :> Normal _) = invertCommuteNC c -- Commuting a Conflictor past a Normal patch is the dual operation to -- commuting a Normal patch past a Conflictor.@@ -423,7 +439,7 @@ return (Normal x' :> Conflictor iy' (invertRL iyy') y') -- Handle via the previous case, using the inverting commuter.- commuteNoConflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c+ commuteNoConflicts c@(Normal _ :> InvConflictor{}) = invertCommuteNC c -- Commuting two Conflictors, c1 and c2, first commutes the Conflictors' -- effects, then commutes the effect of c1 and c2 and the other's@@ -438,7 +454,7 @@ return (Conflictor iy' yy' y' :> Conflictor ix' xx' x') -- Handle via the previous case, using the inverting commuter.- commuteNoConflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) =+ commuteNoConflicts c@(InvConflictor{} :> InvConflictor{}) = invertCommuteNC c commuteNoConflicts (InvConflictor ix xx x :> Conflictor iy yy y) = do@@ -495,26 +511,26 @@ minus xs (y:ys) = do xs' <- remove1 y xs xs' `minus` ys -invertNon :: PrimPatch prim => Non (RealPatch prim) C(x)- -> Non (RealPatch prim) C(x)+invertNon :: PrimPatch prim => Non (RealPatch prim) wX+ -> Non (RealPatch prim) wX invertNon (Non c x) | Just rc' <- removeRL nix (reverseFL c) = Non (reverseRL rc') (invert x) | otherwise = commuteOrAddToCtxRL (Normal x :<: reverseFL c) $ non nix where nix = Normal $ invert x -nonTouches :: PatchInspect prim => Non (RealPatch prim) C(x) -> [FilePath]+nonTouches :: PatchInspect prim => Non (RealPatch prim) wX -> [FilePath] nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL) nonHunkMatches :: PatchInspect prim => (BC.ByteString -> Bool)- -> Non (RealPatch prim) C(x) -> Bool+ -> Non (RealPatch prim) wX -> Bool nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x -toNons :: forall p C(x y) . (Conflict p, Patchy p, PatchListFormat p,- ToFromPrim p, Nonable p, ShowPatchBasic (PrimOf p)) => FL p C(x y)- -> [Non p C(x)]+toNons :: forall p wX wY . (Conflict p, Patchy p, PatchListFormat p,+ ToFromPrim p, Nonable p, ShowPatchBasic (PrimOf p), ShowPatchBasic p)+ => FL p wX wY -> [Non p wX] toNons xs = map lastNon $ initsFL xs- where lastNon :: Sealed ((p :> FL p) C(x)) -> Non p C(x)+ where lastNon :: Sealed ((p :> FL p) wX) -> Non p wX lastNon (Sealed xxx) = case lastNon_aux xxx of deps :> p :> _ ->@@ -528,25 +544,25 @@ redText "ds are" $$ showPatch ds $$ redText "pp is" $$ showPatch pp - reverseFoo :: (p :> FL p) C(x z) -> (RL p :> p) C(x z)+ reverseFoo :: (p :> FL p) wX wZ -> (RL p :> p) wX wZ reverseFoo (p :> ps) = rf NilRL p ps where- rf :: RL p C(a b) -> p C(b c) -> FL p C(c d)- -> (RL p :> p) C(a d)+ rf :: RL p wA wB -> p wB wC -> FL p wC wD+ -> (RL p :> p) wA wD rf rs l NilFL = rs :> l rf rs x (y :>: ys) = rf (x :<: rs) y ys - lastNon_aux :: (p :> FL p) C(x z) -> (RL p :> p :> RL p) C(x z)+ lastNon_aux :: (p :> FL p) wX wZ -> (RL p :> p :> RL p) wX wZ lastNon_aux = commuteWhatWeCanRL . reverseFoo -initsFL :: Patchy p => FL p C(x y) -> [Sealed ((p :> FL p) C(x))]+initsFL :: Patchy p => FL p wX wY -> [Sealed ((p :> FL p) wX)] initsFL NilFL = [] initsFL (x :>: xs) = Sealed (x :> NilFL) : map (\(Sealed (y :> xs')) -> Sealed (x :> y :>: xs')) (initsFL xs) -filterConflictsFL :: PrimPatch prim => Non (RealPatch prim) C(x)- -> FL prim C(x y) -> (FL prim :> FL prim) C(x y)+filterConflictsFL :: PrimPatch prim => Non (RealPatch prim) wX+ -> FL prim wX wY -> (FL prim :> FL prim) wX wY filterConflictsFL _ NilFL = NilFL :> NilFL filterConflictsFL n (p :>: ps) | Just n' <- commuteOrRemFromCtx (fromPrim p) n =@@ -584,7 +600,7 @@ -- Handle using the inverting commuter, and the previous case. N.b. this -- is innefficient, since we'll have to also try commuteNoConflicts again -- (which we know will fail, since we got here).- commute c@(InvConflictor _ _ _ :> Normal _) = invertCommute c+ commute c@(InvConflictor{} :> Normal _) = invertCommute c commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2) | Just a2_minus_p1 <- remove1 p1' a2@@ -623,13 +639,13 @@ -- Handle using the inverting commuter, and the previous case. This is also -- innefficient, since we'll have to also try commuteNoConflicts again -- (which we know will fail, since we got here).- commute c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommute c+ commute c@(InvConflictor{} :> InvConflictor{}) = invertCommute c commute _ = Nothing instance PrimPatch prim => Merge (RealPatch prim) where- merge (InvConflictor _ _ _ :\/: _) = impossible- merge (_ :\/: InvConflictor _ _ _) = impossible+ merge (InvConflictor{} :\/: _) = impossible+ merge (_ :\/: InvConflictor{}) = impossible merge (Etacilpud _ :\/: _) = impossible merge (_ :\/: Etacilpud _) = impossible @@ -679,7 +695,7 @@ (x' : nyy) = reverse $ xx2nons iy yyx -- Handle using the swap merge and the previous case.- merge m@(Conflictor _ _ _ :\/: Normal _) = swapMerge m+ merge m@(Conflictor{} :\/: Normal _) = swapMerge m -- mH see also cH merge (Conflictor ix xx x :\/: Conflictor iy yy y) =@@ -712,9 +728,9 @@ listTouchedFiles (Etacilpud p) = nonTouches p listTouchedFiles (Normal p) = listTouchedFiles p listTouchedFiles (Conflictor x c p) =- nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p+ nubSort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p listTouchedFiles (InvConflictor x c p) =- nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p+ nubSort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p hunkMatches f (Duplicate p) = nonHunkMatches f p hunkMatches f (Etacilpud p) = nonHunkMatches f p@@ -724,9 +740,9 @@ hunkMatches f (InvConflictor x c p) = any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p -allConflictsWith :: PrimPatch prim => Non (RealPatch prim) C(x)- -> [Non (RealPatch prim) C(x)]- -> ([Non (RealPatch prim) C(x)], [Non (RealPatch prim) C(x)])+allConflictsWith :: PrimPatch prim => Non (RealPatch prim) wX+ -> [Non (RealPatch prim) wX]+ -> ([Non (RealPatch prim) wX], [Non (RealPatch prim) wX]) allConflictsWith x ys = acw $ partition (conflictsWith x) ys where acw ([], nc) = ([], nc)@@ -734,8 +750,8 @@ (c1, nc1) -> case acw (cs, nc1) of (xs', nc') -> (c : c1 ++ xs', nc') -conflictsWith :: PrimPatch prim => Non (RealPatch prim) C(x)- -> Non (RealPatch prim) C(x) -> Bool+conflictsWith :: PrimPatch prim => Non (RealPatch prim) wX+ -> Non (RealPatch prim) wX -> Bool conflictsWith x y | x `dependsUpon` y || y `dependsUpon` x = False conflictsWith x (Non cy y) = case commuteOrRemFromCtxFL cy x of@@ -746,8 +762,8 @@ Left _ -> True Nothing -> True -dependsUpon :: PrimPatch prim => Non (RealPatch prim) C(x)- -> Non (RealPatch prim) C(x) -> Bool+dependsUpon :: PrimPatch prim => Non (RealPatch prim) wX+ -> Non (RealPatch prim) wX -> Bool dependsUpon (Non xs _) (Non ys y) = case removeSubsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of Just _ -> True@@ -759,24 +775,24 @@ (x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys) | otherwise = x : (xs +++ xys) -swapMerge :: PrimPatch prim => (RealPatch prim :\/: RealPatch prim) C(x y)- -> (RealPatch prim :/\: RealPatch prim) C(x y)+swapMerge :: PrimPatch prim => (RealPatch prim :\/: RealPatch prim) wX wY+ -> (RealPatch prim :/\: RealPatch prim) wX wY swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x' -invertCommute :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y)- -> Maybe ((RealPatch prim :> RealPatch prim) C(x y))+invertCommute :: PrimPatch prim => (RealPatch prim :> RealPatch prim) wX wY+ -> Maybe ((RealPatch prim :> RealPatch prim) wX wY) invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x) return (invert iy' :> invert ix') -invertCommuteNC :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y)- -> Maybe ((RealPatch prim :> RealPatch prim) C(x y))+invertCommuteNC :: PrimPatch prim => (RealPatch prim :> RealPatch prim) wX wY+ -> Maybe ((RealPatch prim :> RealPatch prim) wX wY) invertCommuteNC (x :> y) = do ix' :> iy' <- commuteNoConflicts (invert y :> invert x) return (invert iy' :> invert ix') -- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted out -- of both @xs@ and @ys@ along with the remnants of both lists-pullCommon :: Patchy p => FL p C(o x) -> FL p C(o y) -> Common p C(o x y)+pullCommon :: (Patchy p, MyEq p) => FL p wO wX -> FL p wO wY -> Common p wO wX wY pullCommon NilFL ys = Common NilFL NilFL ys pullCommon xs NilFL = Common NilFL xs NilFL pullCommon (x :>: xs) xys | Just ys <- removeFL x xys =@@ -789,12 +805,12 @@ -- | 'Common' @cs xs ys@ represents two sequences of patches that have @cs@ in -- common, in other words @cs +>+ xs@ and @cs +>+ ys@-data Common p C(o x y) where- Common :: FL p C(o i) -> FL p C(i x) -> FL p C(i y) -> Common p C(o x y)+data Common p wO wX wY where+ Common :: FL p wO wI -> FL p wI wX -> FL p wI wY -> Common p wO wX wY -- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted -- out of both @xs@ and @ys@ along with the remnants of both lists-pullCommonRL :: Patchy p => RL p C(x o) -> RL p C(y o) -> CommonRL p C(x y o)+pullCommonRL :: (Patchy p, MyEq p) => RL p wX wO -> RL p wY wO -> CommonRL p wX wY wO pullCommonRL NilRL ys = CommonRL NilRL ys NilRL pullCommonRL xs NilRL = CommonRL xs NilRL NilRL pullCommonRL (x :<: xs) xys | Just ys <- removeRL x xys =@@ -808,8 +824,8 @@ -- | 'CommonRL' @xs ys cs@' represents two sequences of patches that have @cs@ -- in common, in other words @xs +<+ cs@ and @ys +<+ cs@-data CommonRL p C(x y f) where- CommonRL :: RL p C(x i) -> RL p C(y i) -> RL p C(i f) -> CommonRL p C(x y f)+data CommonRL p wX wY wF where+ CommonRL :: RL p wX wI -> RL p wY wI -> RL p wI wF -> CommonRL p wX wY wF instance PrimPatch prim => Apply (RealPatch prim) where type ApplyState (RealPatch prim) = ApplyState prim@@ -884,10 +900,32 @@ return $ Sealed $ Normal p ] -instance PrimPatch prim => Show (RealPatch prim C(x y)) where- show p = renderString $ showPatch p+instance Show2 prim => Show (RealPatch prim wX wY) where+ showsPrec d (Normal prim) =+ showParen (d > appPrec) $ showString "Darcs.Patch.V2.Real.Normal " . showsPrec2 (appPrec + 1) prim -instance PrimPatch prim => Show2 (RealPatch prim) where+ showsPrec d (Duplicate x) =+ showParen (d > appPrec) $ showString "Darcs.Patch.V2.Real.Duplicate " . showsPrec (appPrec + 1) x++ showsPrec d (Etacilpud x) =+ showParen (d > appPrec) $ showString "Darcs.Patch.V2.Etacilpud " . showsPrec (appPrec + 1) x++ showsPrec d (Conflictor ix xx x) =+ showParen (d > appPrec) $+ showString "Darcs.Patch.V2.Real.Conflictor " . showsPrec (appPrec + 1) ix .+ showString " " . showsPrec (appPrec + 1) xx .+ showString " " . showsPrec (appPrec + 1) x++ showsPrec d (InvConflictor ix xx x) =+ showParen (d > appPrec) $+ showString "Darcs.Patch.V2.Real.InvConflictor " . showsPrec (appPrec + 1) ix .+ showString " " . showsPrec (appPrec + 1) xx .+ showString " " . showsPrec (appPrec + 1) x++instance Show2 prim => Show1 (RealPatch prim wX) where+ showDict1 = ShowDictClass++instance Show2 prim => Show2 (RealPatch prim) where showDict2 = ShowDictClass instance PrimPatch prim => Nonable (RealPatch prim) where
src/Darcs/Patch/Viewing.hs view
@@ -15,139 +15,157 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-imports #-} {-# LANGUAGE CPP #-} module Darcs.Patch.Viewing- ( showContextHunk, showContextSeries- )- where+ ( showContextHunk+ , showContextSeries+ ) where -import Prelude hiding ( pi, readFile ) import Control.Applicative( (<$>) )+import qualified Data.ByteString as BS ( null )+import Prelude hiding ( pi, readFile )+import Storage.Hashed.Monad ( virtualTreeMonad )+import Storage.Hashed.Tree ( Tree ) -import Storage.Hashed.Monad( TreeIO, fileExists, readFile, tree, virtualTreeMonad )-import Storage.Hashed.Tree( Tree )-import Storage.Hashed.AnchoredPath( floatPath )-import ByteStringUtils (linesPS )-import qualified Data.ByteString as BS (null, concat)-import qualified Data.ByteString.Lazy as BL (toChunks)-import Darcs.Patch.FileName ( fn2fp )-import Printer ( Doc, empty, vcat,- text, blueText, Color(Cyan,Magenta), lineColor,- ($$), (<+>),- prefix,- userchunkPS,- )-import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.ApplyMonad ( ApplyMonadTrans, getApplyState,+ ApplyMonad(..), toTree ) import Darcs.Patch.FileHunk ( IsHunk(..), FileHunk(..), showFileHunk )+import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..),+ FileNameFormat(..) ) import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), formatFileName )-import Darcs.Patch.Apply ( Apply(..), applyToState )-import Darcs.Patch.ApplyMonad ( ApplyMonadTrans, runApplyMonad, getApplyState- , ApplyMonadOver, ApplyMonad(..), toTree )-#include "gadts.h"-import Darcs.Witnesses.Ordered ( RL(..), FL(..),- mapFL, mapFL_FL, reverseRL, concatFL )+import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), mapFL, mapFL_FL,+ reverseRL, concatFL )+import Darcs.Util.ByteString ( linesPS )+import Darcs.Util.Printer ( Doc, empty, vcat, text, blueText, Color(Cyan, Magenta),+ lineColor, ($$), (<+>), prefix, userchunkPS ) -showContextSeries :: forall p m x y. (Apply p, ShowPatch p, IsHunk p,- ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p))- => FL p C(x y) -> m Doc-showContextSeries patches = scs Nothing patches- where scs :: forall m' ww xx yy.- (ApplyMonadTrans m' (ApplyState p), ApplyMonad m' (ApplyState p), ApplyMonadBase m ~ ApplyMonadBase m')- => Maybe (FileHunk C(ww xx)) -> FL p C(xx yy) -> m' Doc- scs pold (p:>:ps) = do- (_, s') <- nestedApply (apply p) =<< getApplyState- case isHunk p of- Nothing -> do a <- showContextPatch p- b <- nestedApply (scs Nothing ps) s'- return $ a $$ fst b- Just fh ->- case ps of- NilFL -> fst <$> liftApply (cool pold fh Nothing) s'- (p2:>:_) -> do a <- fst <$> liftApply (cool pold fh (isHunk p2)) s'- b <- nestedApply (scs (Just fh) ps) s'- return $ a $$ fst b- scs _ NilFL = return empty- cool :: Maybe (FileHunk C(a b))- -> FileHunk C(b c)- -> Maybe (FileHunk C(c d))- -> (ApplyState p) (ApplyMonadBase m)- -> (ApplyMonadBase m) Doc- cool pold fh ps s = fst <$> virtualTreeMonad (coolContextHunk pold fh ps) (toTree s)+showContextSeries :: forall p m wX wY . (Apply p, ShowPatch p, IsHunk p,+ ApplyMonadTrans m (ApplyState p),+ ApplyMonad m (ApplyState p))+ => FL p wX wY -> m Doc+showContextSeries = scs Nothing+ where+ scs :: forall m' wWw wXx wYy . (ApplyMonadTrans m' (ApplyState p),+ ApplyMonad m' (ApplyState p),+ ApplyMonadBase m ~ ApplyMonadBase m')+ => Maybe (FileHunk wWw wXx) -> FL p wXx wYy -> m' Doc+ scs pold (p :>: ps) = do+ (_, s') <- nestedApply (apply p) =<< getApplyState+ case isHunk p of+ Nothing -> do+ a <- showContextPatch p+ b <- nestedApply (scs Nothing ps) s'+ return $ a $$ fst b+ Just fh -> case ps of+ NilFL -> fst <$> liftApply (cool pold fh Nothing) s'+ (p2 :>: _) -> do+ a <- fst <$> liftApply (cool pold fh (isHunk p2)) s'+ b <- nestedApply (scs (Just fh) ps) s'+ return $ a $$ fst b+ scs _ NilFL = return empty -showContextHunk :: (ApplyMonad m Tree) => FileHunk C(x y) -> m Doc+ cool :: Maybe (FileHunk wA wB) -> FileHunk wB wC -> Maybe (FileHunk wC wD)+ -> (ApplyState p) (ApplyMonadBase m) -> (ApplyMonadBase m) Doc+ cool pold fh ps s =+ fst <$> virtualTreeMonad (coolContextHunk pold fh ps) (toTree s)++showContextHunk :: (ApplyMonad m Tree) => FileHunk wX wY -> m Doc showContextHunk h = coolContextHunk Nothing h Nothing coolContextHunk :: (ApplyMonad m Tree, ApplyMonadTrans m Tree)- => Maybe (FileHunk C(a b)) -> FileHunk C(b c) -> Maybe (FileHunk C(c d)) -> m Doc+ => Maybe (FileHunk wA wB) -> FileHunk wB wC+ -> Maybe (FileHunk wC wD) -> m Doc coolContextHunk prev fh@(FileHunk f l o n) next = do- have <- mDoesFileExist f- content <- if have then Just `fmap` mReadFilePS f else return Nothing- case linesPS `fmap` content of- Nothing -> return $ showFileHunk OldFormat fh -- This is a weird error...- Just ls ->- let numpre = case prev of- Just (FileHunk f' lprev _ nprev)- | f' == f &&- l - (lprev + length nprev + 3) < 3 &&- lprev < l ->- max 0 $ l - (lprev + length nprev + 3)- _ -> if l >= 4 then 3 else l - 1- pre = take numpre $ drop (l - numpre - 1) ls- numpost = case next of- Just (FileHunk f' lnext _ _)- | f' == f && lnext < l+length n+4 &&- lnext > l ->- lnext - (l+length n)- _ -> 3- cleanedls = case reverse ls of- (x:xs) | BS.null x -> reverse xs- _ -> ls- post = take numpost $ drop (max 0 $ l+length o-1) cleanedls- in return $ blueText "hunk" <+> formatFileName OldFormat f <+> text (show l)- $$ prefix " " (vcat $ map userchunkPS pre)- $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS o))- $$ lineColor Cyan (prefix "+" (vcat $ map userchunkPS n))- $$ prefix " " (vcat $ map userchunkPS post)+ have <- mDoesFileExist f+ content <- if have then Just `fmap` mReadFilePS f else return Nothing+ case linesPS `fmap` content of+ -- This is a weird error...+ Nothing -> return $ showFileHunk OldFormat fh+ Just ls ->+ let pre = take numpre $ drop (l - numpre - 1) ls+ cleanedls = case reverse ls of+ (x : xs)+ | BS.null x -> reverse xs+ _ -> ls+ post = take numpost $ drop (max 0 $ l+length o-1) cleanedls in+ return $+ blueText "hunk" <+> formatFileName OldFormat f+ <+> text (show l)+ $$ prefix " " (vcat $ map userchunkPS pre)+ $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS o))+ $$ lineColor Cyan (prefix "+" (vcat $ map userchunkPS n))+ $$ prefix " " (vcat $ map userchunkPS post)+ where+ numpre = case prev of+ Just (FileHunk f' lprev _ nprev)+ | f' == f && l - (lprev + length nprev + 3) < 3 && lprev < l+ -> max 0 $ l - (lprev + length nprev + 3)+ _ -> if l >= 4 then 3 else l - 1 + numpost = case next of+ Just (FileHunk f' lnext _ _)+ | f' == f && lnext < l + length n + 4 && lnext > l+ -> lnext - (l + length n)+ _ -> 3+ instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (FL p) where showPatch = showPatchInternal patchListFormat- where showPatchInternal :: ListFormat p -> FL p C(x y) -> Doc- showPatchInternal ListFormatV1 (p :>: NilFL) = showPatch p- showPatchInternal ListFormatV1 NilFL = blueText "{" $$ blueText "}"- showPatchInternal ListFormatV1 ps = blueText "{" $$ vcat (mapFL showPatch ps) $$ blueText "}"- showPatchInternal ListFormatV2 ps = vcat (mapFL showPatch ps)- showPatchInternal ListFormatDefault ps = vcat (mapFL showPatch ps)+ where+ showPatchInternal :: ListFormat p -> FL p wX wY -> Doc+ showPatchInternal ListFormatV1 (p :>: NilFL) = showPatch p+ showPatchInternal ListFormatV1 NilFL = blueText "{" $$ blueText "}"+ showPatchInternal ListFormatV1 ps = blueText "{"+ $$ vcat (mapFL showPatch ps)+ $$ blueText "}"+ showPatchInternal ListFormatV2 ps = vcat (mapFL showPatch ps)+ showPatchInternal ListFormatDefault ps = vcat (mapFL showPatch ps) -instance (Apply p, IsHunk p, PatchListFormat p, ShowPatch p) => ShowPatch (FL p) where+instance (Apply p, IsHunk p, PatchListFormat p, ShowPatch p)+ => ShowPatch (FL p) where showContextPatch = showContextPatchInternal patchListFormat- where showContextPatchInternal :: (ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState (FL p)))- => ListFormat p -> FL p C(x y) -> m Doc- showContextPatchInternal ListFormatV1 (p :>: NilFL) = showContextPatch p- showContextPatchInternal ListFormatV1 NilFL = return $ blueText "{" $$ blueText "}"- showContextPatchInternal ListFormatV1 ps = do x <- showContextSeries ps- return $ blueText "{" $$ x $$ blueText "}"- showContextPatchInternal ListFormatV2 ps = showContextSeries ps- showContextPatchInternal ListFormatDefault ps = showContextSeries ps+ where+ showContextPatchInternal :: (ApplyMonadTrans m (ApplyState p),+ ApplyMonad m (ApplyState (FL p)))+ => ListFormat p -> FL p wX wY -> m Doc+ showContextPatchInternal ListFormatV1 (p :>: NilFL) =+ showContextPatch p+ showContextPatchInternal ListFormatV1 NilFL =+ return $ blueText "{" $$ blueText "}"+ showContextPatchInternal ListFormatV1 ps = do+ x <- showContextSeries ps+ return $ blueText "{" $$ x $$ blueText "}"+ showContextPatchInternal ListFormatV2 ps = showContextSeries ps+ showContextPatchInternal ListFormatDefault ps = showContextSeries ps description = vcat . mapFL description+ summary = summaryFL+ summaryFL = summaryFL . concatFL+ thing x = thing (helperx x) ++ "s"- where helperx :: FL a C(x y) -> a C(x y)- helperx _ = undefined+ where+ helperx :: FL a wX wY -> a wX wY+ helperx _ = undefined+ things = thing instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RL p) where showPatch = showPatch . reverseRL -instance (Apply p, IsHunk p, PatchListFormat p, ShowPatch p) => ShowPatch (RL p) where+instance (Apply p, IsHunk p, PatchListFormat p, ShowPatch p)+ => ShowPatch (RL p) where showContextPatch = showContextPatch . reverseRL+ description = description . reverseRL+ summary = summary . reverseRL+ summaryFL = summaryFL . mapFL_FL reverseRL- thing = thing . reverseRL- things = things . reverseRL + thing = thing . reverseRL + things = things . reverseRL
+ src/Darcs/Patch/Witnesses/Eq.hs view
@@ -0,0 +1,55 @@+module Darcs.Patch.Witnesses.Eq+ ( EqCheck(..)+ , MyEq(..)+ , isIsEq+ ) where++import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )++-- |'EqCheck' is used to pass around evidence (or lack thereof) of+-- two witness types being equal.+data EqCheck wA wB where+ IsEq :: EqCheck wA wA+ NotEq :: EqCheck wA wB++instance Eq (EqCheck wA wB) where+ IsEq == IsEq = True+ NotEq == NotEq = True+ _ == _ = False++instance Show (EqCheck wA wB) where+ show IsEq = "IsEq"+ show NotEq = "NotEq"++-- |An witness aware equality class.+-- A minimal definition defines any one of 'unsafeCompare', '=\/=' and '=/\='.+class MyEq p where+ -- |It is unsafe to define a class instance via this method, because+ -- if it returns True then the default implementations of '=\/=' and '=/\='+ -- will coerce the equality of two witnesses.+ --+ -- Calling this method is safe, although '=\/=' or '=/\=' would be better+ -- choices as it is not usually meaningul to compare two patches that+ -- don't share either a starting or an ending context+ unsafeCompare :: p wA wB -> p wC wD -> Bool+ unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b)++ -- |Compare two things with the same starting witness. If the things+ -- compare equal, evidence of the ending witnesses being equal will+ -- be returned.+ (=\/=) :: p wA wB -> p wA wC -> EqCheck wB wC+ a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq+ | otherwise = NotEq++ -- |Compare two things with the same ending witness. If the things+ -- compare equal, evidence of the starting witnesses being equal will+ -- be returned.+ (=/\=) :: p wA wC -> p wB wC -> EqCheck wA wB+ a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq+ | otherwise = NotEq++infix 4 =\/=, =/\=++isIsEq :: EqCheck wA wB -> Bool+isIsEq IsEq = True+isIsEq NotEq = False
+ src/Darcs/Patch/Witnesses/Ordered.hs view
@@ -0,0 +1,456 @@+-- Copyright (C) 2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.Patch.Witnesses.Ordered+ ( + -- * Directed Types+ -- $DirectedTypes+ (:>)(..)+ , (:<)(..)+ , FL(..)+ , RL(..)+ -- * Merge Types+ -- $MergeTypes+ , (:\/:)(..)+ , (:/\:)(..)+ , (:||:)(..)+ , Fork(..)+ -- * Functions+ , lengthFL+ , mapFL+ , mapFL_FL+ , spanFL+ , foldlFL+ , allFL+ , anyFL+ , filterFL+ , splitAtFL+ , splitAtRL+ , bunchFL+ , foldlRL+ , lengthRL+ , isShorterThanRL+ , mapRL+ , mapRL_RL+ , zipWithFL+ , filterOutFLFL+ , filterOutRLRL+ , filterRL+ , reverseFL+ , reverseRL+ , (+>+)+ , (+<+)+ , nullFL+ , concatFL+ , concatRL+ , consRLSealed+ , nullRL+ , toFL+ , dropWhileFL+ , dropWhileRL+ , spanFL_M+ , mapFL_FL_M+ , eqFL+ , eqFLRev+ , eqFLUnsafe+ ) where++#include "impossible.h"+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.Witnesses.Sealed+ ( FlippedSeal(..)+ , flipSeal+ , Sealed(..)+ , FreeLeft+ , unFreeLeft+ , Sealed2(..)+ , seal+ )+import Darcs.Patch.Witnesses.Eq ( MyEq(..), EqCheck(..) )++-- * Directed Types++-- $DirectedTypes+-- Darcs patches have a notion of transforming between contexts. This+-- naturally leads us to container types that are \"directed\" and +-- transform from one context to another.+-- +-- For example, the swap of names of files x and y could be represented +-- with the following sequence of patches:+-- +-- @ Move x z ':>' Move y x ':>' Move z y @+-- +-- or using forward lists, like+-- +-- @ Move x z ':>:' Move y x ':>:' Move z y ':>:' NilFl @++-- | Directed Forward Pairs+data (a1 :> a2) wX wY = forall wZ . (a1 wX wZ) :> (a2 wZ wY)+infixr 1 :>++-- | Directed Reverse Pairs+data (a1 :< a2) wX wY = forall wZ . (a1 wZ wY) :< (a2 wX wZ)+infix 1 :<++-- | Forward lists+data FL a wX wZ where+ (:>:) :: a wX wY -> FL a wY wZ -> FL a wX wZ+ NilFL :: FL a wX wX++-- | Reverse lists+data RL a wX wZ where+ (:<:) :: a wY wZ -> RL a wX wY -> RL a wX wZ+ NilRL :: RL a wX wX++instance Show2 a => Show (FL a wX wZ) where+ showsPrec _ NilFL = showString "NilFL"+ showsPrec d (x :>: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x .+ showString " :>: " . showsPrec (prec + 1) xs+ where prec = 5++instance Show2 a => Show1 (FL a wX) where+ showDict1 = ShowDictClass++instance Show2 a => Show2 (FL a) where+ showDict2 = ShowDictClass++instance Show2 a => Show (RL a wX wZ) where+ showsPrec _ NilRL = showString "NilRL"+ showsPrec d (x :<: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x .+ showString " :<: " . showsPrec (prec + 1) xs+ where prec = 5++instance Show2 a => Show1 (RL a wX) where+ showDict1 = ShowDictClass++instance Show2 a => Show2 (RL a) where+ showDict2 = ShowDictClass++instance (Show2 a, Show2 b) => Show1 ((a :> b) wX) where+ showDict1 = ShowDictClass++-- * Merge Types++-- $MergeTypes+-- When we have two patches which commute and share the same pre-context we can+-- merge the patches. Whenever patches, or sequences of patches, share a+-- pre-context we say they are Forking Pairs (':\/:'). The same way, when+-- patches or sequences of patches, share a post-context we say they are+-- Joining Pairs (':/\:').+-- +-- The following diagram shows the symmetry of merge types:+-- +-- @ wZ+-- ':/\:'+-- a3 / \ a4 +-- / \ +-- wX wY +-- \ / +-- a1 \ / a2 +-- ':\/:' +-- wZ+-- @++-- +-- (non-haddock version)+-- wZ+-- :/\:+-- a3 / \ a4+-- / \+-- wX wY+-- \ /+-- a1 \ / a2+-- :\/:+-- wZ+-- ++infix 1 :/\:, :\/:, :||:+-- | Forking Pairs (Implicit starting context)+data (a1 :\/: a2) wX wY = forall wZ . (a1 wZ wX) :\/: (a2 wZ wY)++-- | Joining Pairs+data (a3 :/\: a4) wX wY = forall wZ . (a3 wX wZ) :/\: (a4 wY wZ)++-- | Forking Pair (Explicit starting context)+-- +-- @ wX wY +-- \ / +-- \ /+-- \ / +-- wU+-- |+-- |+-- |+-- wA+-- @++-- +-- (non-haddock version)+-- +-- wX wY+-- \ /+-- \ /+-- \ /+-- wU+-- |+-- |+-- |+-- wA+-- ++data Fork common left right wA wX wY =+ forall wU. Fork (common wA wU) (left wU wX) (right wU wY)++-- | Parallel Pairs+data (a1 :||: a2) wX wY = (a1 wX wY) :||: (a2 wX wY)++instance (Show2 a, Show2 b) => Show ( (a :> b) wX wY ) where+ showsPrec d (x :> y) = showOp2 1 ":>" d x y++instance (MyEq a, MyEq b) => MyEq (a :> b) where+ (a1 :> b1) =\/= (a2 :> b2) | IsEq <- a1 =\/= a2 = b1 =\/= b2+ | otherwise = NotEq++instance (MyEq a, MyEq b) => Eq ((a :> b) wX wY) where+ (==) = unsafeCompare++instance (MyEq a, MyEq b) => MyEq (a :< b) where+ (a1 :< b1) =\/= (a2 :< b2) | IsEq <- b1 =\/= b2 = a1 =\/= a2+ | otherwise = NotEq++instance (MyEq a, MyEq b) => Eq ((a :< b) wX wY) where+ (==) = unsafeCompare++instance (Show2 a, Show2 b) => Show2 (a :> b) where+ showDict2 = ShowDictClass++instance (Show2 a, Show2 b) => Show ( (a :\/: b) wX wY ) where+ showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y++instance (Show2 a, Show2 b) => Show2 (a :\/: b) where+ showDict2 = ShowDictClass++instance (Show2 a, Show2 b) => Show ( (a :/\: b) wX wY ) where+ showsPrec d (x :/\: y) = showOp2 1 ":/\\:" d x y++instance (Show2 a, Show2 b) => Show2 ( (a :/\: b) ) where+ showDict2 = ShowDictClass++-- * Functions++infixr 5 :>:, :<:, +>+, +<+++nullFL :: FL a wX wZ -> Bool+nullFL NilFL = True+nullFL _ = False++nullRL :: RL a wX wZ -> Bool+nullRL NilRL = True+nullRL _ = False++-- | @filterOutFLFL p xs@ deletes any @x@ in @xs@ for which @p x == IsEq@+-- (indicating that @x@ has no effect as far as we are concerned, and can be+-- safely removed from the chain)+filterOutFLFL :: (forall wX wY . p wX wY -> EqCheck wX wY) -> FL p wW wZ -> FL p wW wZ+filterOutFLFL _ NilFL = NilFL+filterOutFLFL f (x:>:xs) | IsEq <- f x = filterOutFLFL f xs+ | otherwise = x :>: filterOutFLFL f xs++filterOutRLRL :: (forall wX wY . p wX wY -> EqCheck wX wY) -> RL p wW wZ -> RL p wW wZ+filterOutRLRL _ NilRL = NilRL+filterOutRLRL f (x:<:xs) | IsEq <- f x = filterOutRLRL f xs+ | otherwise = x :<: filterOutRLRL f xs++filterRL :: (forall wX wY . p wX wY -> Bool) -> RL p wA wB -> [Sealed2 p]+filterRL _ NilRL = []+filterRL f (x :<: xs) | f x = Sealed2 x : (filterRL f xs)+ | otherwise = filterRL f xs++(+>+) :: FL a wX wY -> FL a wY wZ -> FL a wX wZ+NilFL +>+ ys = ys+(x:>:xs) +>+ ys = x :>: xs +>+ ys++(+<+) :: RL a wY wZ -> RL a wX wY -> RL a wX wZ+NilRL +<+ ys = ys+(x:<:xs) +<+ ys = x :<: xs +<+ ys++reverseFL :: FL a wX wZ -> RL a wX wZ+reverseFL xs = r NilRL xs+ where r :: RL a wL wM -> FL a wM wO -> RL a wL wO+ r ls NilFL = ls+ r ls (a:>:as) = r (a:<:ls) as++reverseRL :: RL a wX wZ -> FL a wX wZ+reverseRL xs = r NilFL xs -- r (xs :> NilFL)+ where r :: FL a wM wO -> RL a wL wM -> FL a wL wO+ r ls NilRL = ls+ r ls (a:<:as) = r (a:>:ls) as++concatFL :: FL (FL a) wX wZ -> FL a wX wZ+concatFL NilFL = NilFL+concatFL (a:>:as) = a +>+ concatFL as++concatRL :: RL (RL a) wX wZ -> RL a wX wZ+concatRL NilRL = NilRL+concatRL (a:<:as) = a +<+ concatRL as++spanFL :: (forall wW wY . a wW wY -> Bool) -> FL a wX wZ -> (FL a :> FL a) wX wZ+spanFL f (x:>:xs) | f x = case spanFL f xs of+ ys :> zs -> (x:>:ys) :> zs+spanFL _ xs = NilFL :> xs++spanFL_M :: forall a m wX wZ. Monad m =>+ (forall wW wY . a wW wY -> m Bool) -> FL a wX wZ+ -> m ((FL a :> FL a) wX wZ)+spanFL_M f (x:>:xs) =+ do+ continue <- f x+ if continue+ then do (ys :> zs) <- spanFL_M f xs+ return $ (x :>: ys) :> zs+ else return $ NilFL :> (x :>: xs)++spanFL_M _ (NilFL) = return $ NilFL :> NilFL++splitAtFL :: Int -> FL a wX wZ -> (FL a :> FL a) wX wZ+splitAtFL 0 xs = NilFL :> xs+splitAtFL _ NilFL = NilFL :> NilFL+splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of+ (xs':>xs'') -> (x:>:xs' :> xs'')++splitAtRL :: Int -> RL a wX wZ -> (RL a :< RL a) wX wZ+splitAtRL 0 xs = NilRL :< xs+splitAtRL _ NilRL = NilRL :< NilRL+splitAtRL n (x:<:xs) = case splitAtRL (n-1) xs of+ (xs':<xs'') -> (x:<:xs' :< xs'')++-- 'bunchFL n' groups patches into batches of n, except that it always puts+-- the first patch in its own group, this being a recognition that the+-- first patch is often *very* large.++bunchFL :: Int -> FL a wX wY -> FL (FL a) wX wY+bunchFL _ NilFL = NilFL+bunchFL n (x:>:xs) = (x :>: NilFL) :>: bFL xs+ where bFL :: FL a wX wY -> FL (FL a) wX wY+ bFL NilFL = NilFL+ bFL bs = case splitAtFL n bs of+ a :> b -> a :>: bFL b+++allFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> Bool+allFL f xs = and $ mapFL f xs++anyFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> Bool+anyFL f xs = or $ mapFL f xs++foldlFL :: (forall wW wY . a -> b wW wY -> a) -> a -> FL b wX wZ -> a+foldlFL _ x NilFL = x+foldlFL f x (y:>:ys) = foldlFL f (f x y) ys++foldlRL :: (forall wW wY . a -> b wW wY -> a) -> a -> RL b wX wZ -> a+foldlRL _ x NilRL = x+foldlRL f x (y:<:ys) = foldlRL f (f x y) ys++mapFL_FL :: (forall wW wY . a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ+mapFL_FL _ NilFL = NilFL+mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as++mapFL_FL_M :: Monad m => (forall wW wY . a wW wY -> m (b wW wY)) -> FL a wX wZ -> m (FL b wX wZ)+mapFL_FL_M _ NilFL = return NilFL+mapFL_FL_M f (a:>:as) = do b <- f a+ bs <- mapFL_FL_M f as+ return (b:>:bs)++zipWithFL :: (forall wX wY . a -> p wX wY -> q wX wY)+ -> [a] -> FL p wW wZ -> FL q wW wZ+zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys+zipWithFL _ _ NilFL = NilFL+zipWithFL _ [] (_:>:_) = bug "zipWithFL called with too short a list"++mapRL_RL :: (forall wW wY . a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ+mapRL_RL _ NilRL = NilRL+mapRL_RL f (a:<:as) = f a :<: mapRL_RL f as++mapFL :: (forall wW wZ . a wW wZ -> b) -> FL a wX wY -> [b]+mapFL _ NilFL = []+mapFL f (a :>: b) = f a : mapFL f b++filterFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> [Sealed2 a]+filterFL _ NilFL = []+filterFL f (a :>: b) = if f a+ then (Sealed2 a):(filterFL f b)+ else filterFL f b++mapRL :: (forall wW wZ . a wW wZ -> b) -> RL a wX wY -> [b]+mapRL _ NilRL = []+mapRL f (a :<: b) = f a : mapRL f b++lengthFL :: FL a wX wZ -> Int+lengthFL xs = l xs 0+ where l :: FL a wX wZ -> Int -> Int+ l NilFL n = n+ l (_:>:as) n = l as $! n+1++lengthRL :: RL a wX wZ -> Int+lengthRL xs = l xs 0+ where l :: RL a wX wZ -> Int -> Int+ l NilRL n = n+ l (_:<:as) n = l as $! n+1++isShorterThanRL :: RL a wX wY -> Int -> Bool+isShorterThanRL _ n | n <= 0 = False+isShorterThanRL NilRL _ = True+isShorterThanRL (_:<:xs) n = isShorterThanRL xs (n-1)++consRLSealed :: a wY wZ -> FlippedSeal (RL a) wY -> FlippedSeal (RL a) wZ+consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as++toFL :: [FreeLeft a] -> Sealed (FL a wX)+toFL [] = Sealed NilFL+toFL (x:xs) = case unFreeLeft x of Sealed y -> case toFL xs of Sealed ys -> Sealed (y :>: ys)++dropWhileFL :: (forall wX wY . a wX wY -> Bool) -> FL a wR wV -> FlippedSeal (FL a) wV+dropWhileFL _ NilFL = flipSeal NilFL+dropWhileFL p xs@(x:>:xs')+ | p x = dropWhileFL p xs'+ | otherwise = flipSeal xs++dropWhileRL :: (forall wX wY . a wX wY -> Bool) -> RL a wR wV -> Sealed (RL a wR)+dropWhileRL _ NilRL = seal NilRL+dropWhileRL p xs@(x:<:xs')+ | p x = dropWhileRL p xs'+ | otherwise = seal xs++-- |Check that two 'FL's are equal element by element.+-- This differs from the 'MyEq' instance for 'FL' which+-- uses commutation.+eqFL :: MyEq a => FL a wX wY -> FL a wX wZ -> EqCheck wY wZ+eqFL NilFL NilFL = IsEq+eqFL (x:>:xs) (y:>:ys) | IsEq <- x =\/= y, IsEq <- eqFL xs ys = IsEq+eqFL _ _ = NotEq++eqFLRev :: MyEq a => FL a wX wZ -> FL a wY wZ -> EqCheck wX wY+eqFLRev NilFL NilFL = IsEq+eqFLRev (x:>:xs) (y:>:ys) | IsEq <- eqFLRev xs ys, IsEq <- x =/\= y = IsEq+eqFLRev _ _ = NotEq++eqFLUnsafe :: MyEq a => FL a wX wY -> FL a wZ wW -> Bool+eqFLUnsafe NilFL NilFL = True+eqFLUnsafe (x:>:xs) (y:>:ys) = unsafeCompare x y && eqFLUnsafe xs ys+eqFLUnsafe _ _ = False
+ src/Darcs/Patch/Witnesses/Sealed.hs view
@@ -0,0 +1,175 @@+-- Copyright (C) 2007 David Roundy, 2009 Ganesh Sittampalam+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, FlexibleInstances #-}+{-# OPTIONS_HADDOCK ignore-exports #-}++module Darcs.Patch.Witnesses.Sealed+ ( Sealed(..)+ , seal+ , unseal+ , mapSeal+ , unsafeUnseal+ , unsafeUnsealFlipped+ , unsafeUnseal2+ , Sealed2(..)+ , seal2+ , unseal2+ , mapSeal2+ , FlippedSeal(..)+ , flipSeal+ , unsealFlipped+ , mapFlipped+ , unsealM+ , liftSM+ , Gap(..)+ , FreeLeft+ , unFreeLeft+ , FreeRight+ , unFreeRight+ ) where++import Darcs.Patch.Witnesses.Eq ( MyEq, EqCheck(..) )+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.Witnesses.Eq ( (=\/=) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP1, unsafeCoerceP )++-- |A 'Sealed' type is a way of hide an existentially quantified type parameter,+-- in this case wX, inside the type. Note that the only thing we can currently+-- recover about the existentially quantified type wX is that it exists.+data Sealed a where+ Sealed :: a wX -> Sealed a++seal :: a wX -> Sealed a+seal = Sealed++instance MyEq a => Eq (Sealed (a wX)) where+ Sealed x == Sealed y | IsEq <- x =\/= y = True+ | otherwise = False++-- |The same as 'Sealed' but for two parameters (wX and wY).+data Sealed2 a where+ Sealed2 :: !(a wX wY) -> Sealed2 a++seal2 :: a wX wY -> Sealed2 a+seal2 = Sealed2++data FlippedSeal a wY where+ FlippedSeal :: !(a wX wY) -> FlippedSeal a wY++flipSeal :: a wX wY -> FlippedSeal a wY+flipSeal = FlippedSeal++unsafeUnseal :: Sealed a -> a wX+unsafeUnseal (Sealed a) = unsafeCoerceP1 a++unsafeUnsealFlipped :: FlippedSeal a wY -> a wX wY+unsafeUnsealFlipped (FlippedSeal a) = unsafeCoerceP a++unsafeUnseal2 :: Sealed2 a -> a wX wY+unsafeUnseal2 (Sealed2 a) = unsafeCoerceP a++unseal :: (forall wX . a wX -> b) -> Sealed a -> b+unseal f x = f (unsafeUnseal x)++-- laziness property:+-- unseal (const True) undefined == True++unsealM :: Monad m => m (Sealed a) -> (forall wX . a wX -> m b) -> m b+unsealM m1 m2 = do sx <- m1+ unseal m2 sx++liftSM :: Monad m => (forall wX . a wX -> b) -> m (Sealed a) -> m b+liftSM f m = do sx <- m+ return (unseal f sx)++mapSeal :: (forall wX . a wX -> b wX) -> Sealed a -> Sealed b+mapSeal f = unseal (seal . f)++mapFlipped :: (forall wX . a wX wY -> b wX wZ) -> FlippedSeal a wY -> FlippedSeal b wZ+mapFlipped f (FlippedSeal x) = FlippedSeal (f x)++unseal2 :: (forall wX wY . a wX wY -> b) -> Sealed2 a -> b+unseal2 f a = f (unsafeUnseal2 a)++mapSeal2 :: (forall wX wY . a wX wY -> b wX wY) -> Sealed2 a -> Sealed2 b+mapSeal2 f = unseal2 (seal2 . f)++unsealFlipped :: (forall wX wY . a wX wY -> b) -> FlippedSeal a wZ -> b+unsealFlipped f (FlippedSeal a) = f a++instance Show1 a => Show (Sealed a) where+ showsPrec d (Sealed x) = showParen (d > appPrec) $ showString "Sealed " . showsPrec1 (appPrec + 1) x+instance Show2 a => Show (Sealed2 a) where+ showsPrec d (Sealed2 x) = showParen (d > appPrec) $ showString "Sealed2 " . showsPrec2 (appPrec + 1) x++-- |'Poly' is similar to 'Sealed', but the type argument is+-- universally quantified instead of being existentially quantified.+newtype Poly a = Poly { unPoly :: forall wX . a wX }++-- |'Stepped' is a type level composition operator.+-- For example, @ 'Stepped' ('Sealed' p) @ is equivalent to +-- @ \\x -> 'Sealed' (p x) @+newtype Stepped (f :: (* -> *) -> *) a wX = Stepped { unStepped :: f (a wX) }++-- |'FreeLeft' p is @ \forall x . \exists y . p x y @+-- In other words the caller is free to specify the left witness,+-- and then the right witness is an existential.+-- Note that the order of the type constructors is important for ensuring+-- that @ y @ is dependent on the @ x @ that is supplied.+-- This is why 'Stepped' is needed, rather than writing the more obvious+-- 'Sealed' ('Poly' p) which would notionally have the same quantification+-- of the type witnesses.+newtype FreeLeft p = FLInternal (Poly (Stepped Sealed p))++-- |'FreeLeft' p is @ \forall y . \exists x . p x y @+-- In other words the caller is free to specify the right witness,+-- and then the left witness is an existential.+-- Note that the order of the type constructors is important for ensuring+-- that @ x @ is dependent on the @ y @ that is supplied.+newtype FreeRight p = FRInternal (Poly (FlippedSeal p))++-- |Unwrap a 'FreeLeft' value+unFreeLeft :: FreeLeft p -> Sealed (p wX)+unFreeLeft (FLInternal x) = unStepped (unPoly x)++-- |Unwrap a 'FreeRight' value+unFreeRight :: FreeRight p -> FlippedSeal p wX+unFreeRight (FRInternal x) = unPoly x++-- |'Gap' abstracts over 'FreeLeft' and 'FreeRight' for code constructing these values+class Gap w where+ -- |An empty 'Gap', e.g. 'NilFL' or 'NilRL'+ emptyGap :: (forall wX . p wX wX) -> w p+ -- |A 'Gap' constructed from a completely polymorphic value, for example the constructors+ -- for primitive patches+ freeGap :: (forall wX wY . p wX wY) -> w p++ -- |Compose two 'Gap' values together in series, e.g. 'joinGap (+>+)' or 'joinGap (:>:)'+ joinGap :: (forall wX wY wZ . p wX wY -> q wY wZ -> r wX wZ) -> w p -> w q -> w r++instance Gap FreeLeft where+ emptyGap e = FLInternal (Poly (Stepped (Sealed e)))+ freeGap e = FLInternal (Poly (Stepped (Sealed e)))+ joinGap op (FLInternal p) (FLInternal q)+ = FLInternal (Poly (case unPoly p of Stepped (Sealed p') -> case unPoly q of Stepped (Sealed q') -> Stepped (Sealed (p' `op` q'))))++instance Gap FreeRight where+ emptyGap e = FRInternal (Poly (FlippedSeal e))+ freeGap e = FRInternal (Poly (FlippedSeal e))+ joinGap op (FRInternal p) (FRInternal q)+ = FRInternal (Poly (case unPoly q of FlippedSeal q' -> case unPoly p of FlippedSeal p' -> FlippedSeal (p' `op` q')))
+ src/Darcs/Patch/Witnesses/Show.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE CPP #-}++module Darcs.Patch.Witnesses.Show+ ( ShowDict(..)+ , showD+ , showListD+ , showsPrecD+ , Show1(..)+ , Show2(..)+ , show1+ , showsPrec1+ , show2+ , showsPrec2+ , showOp2+ , appPrec+ ) where++import Darcs.Util.Show ( appPrec )++data ShowDict a where+ ShowDictClass :: Show a => ShowDict a+ ShowDictRecord :: (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> ShowDict a++showsPrecD :: ShowDict a -> Int -> a -> ShowS+showsPrecD ShowDictClass = showsPrec+showsPrecD (ShowDictRecord showsPrecR _ _) = showsPrecR++showD :: ShowDict a -> a -> String+showD ShowDictClass = show+showD (ShowDictRecord _ showR _) = showR++showListD :: ShowDict a -> [a] -> ShowS+showListD ShowDictClass = showList+showListD (ShowDictRecord _ _ showListR) = showListR++class Show1 a where+ showDict1 :: ShowDict (a wX)++showsPrec1 :: Show1 a => Int -> a wX -> ShowS+showsPrec1 = showsPrecD showDict1++show1 :: Show1 a => a wX -> String+show1 = showD showDict1++class Show2 a where+ showDict2 :: ShowDict (a wX wY)++showsPrec2 :: Show2 a => Int -> a wX wY -> ShowS+showsPrec2 = showsPrecD showDict2++show2 :: Show2 a => a wX wY -> String+show2 = showD showDict2++showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a wW wX -> b wY wZ -> String -> String+showOp2 prec opstr d x y = showParen (d > prec) $ showsPrec2 (prec + 1) x .+ showString opstr . showsPrec2 (prec + 1) y
+ src/Darcs/Patch/Witnesses/Unsafe.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE MagicHash #-}+module Darcs.Patch.Witnesses.Unsafe+ ( unsafeCoerceP+ , unsafeCoercePStart+ , unsafeCoercePEnd+ , unsafeCoerceP2+ , unsafeCoerceP1+ ) where++import GHC.Base (unsafeCoerce#)++unsafeCoerceP :: a wX wY -> a wB wC+unsafeCoerceP = unsafeCoerce#++unsafeCoercePStart :: a wX1 wY -> a wX2 wY+unsafeCoercePStart = unsafeCoerce#++unsafeCoercePEnd :: a wX wY1 -> a wX wY2+unsafeCoercePEnd = unsafeCoerce#++unsafeCoerceP2 :: t wW wX wY wZ -> t wA wB wC wD+unsafeCoerceP2 = unsafeCoerce#++unsafeCoerceP1 :: a wX -> a wY+unsafeCoerceP1 = unsafeCoerce#
+ src/Darcs/Patch/Witnesses/WZipper.hs view
@@ -0,0 +1,99 @@+-- Copyright (C) 2009 Florent Becker+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.Patch.Witnesses.WZipper+ ( FZipper(..)+ , focus+ , leftmost+ , left+ , rightmost+ , right+ , jokers+ , clowns+ , flToZipper+ , lengthFZ+ , nullFZ+ , toEnd+ , toStart+ )+where+import Darcs.Patch.Witnesses.Ordered+ ( FL(..)+ , RL(..)+ , nullFL+ , nullRL+ , lengthFL+ , lengthRL+ , reverseFL+ , reverseRL+ , (+<+)+ , (+>+)+ )+import Darcs.Patch.Witnesses.Sealed(Sealed2(..), Sealed(..), FlippedSeal(..))++-- forward zipper+data FZipper a wX wZ where+ FZipper :: RL a wX wY -> FL a wY wZ -> FZipper a wX wZ++-- Constructors+flToZipper :: FL a wX wY -> FZipper a wX wY+flToZipper = FZipper NilRL++--destructors+nullFZ :: FZipper a wX wY -> Bool+nullFZ (FZipper l r) = nullRL l && nullFL r++lengthFZ :: FZipper a wX wY -> Int+lengthFZ (FZipper l r) = lengthRL l + lengthFL r++focus :: FZipper a wX wY -> Maybe (Sealed2 a)+focus (FZipper _ (x :>: _)) = Just $ Sealed2 x+focus _ = Nothing++-- | \"Clowns to the left of me, jokers to the right. Here I am, stuck+-- in the middle of you\"+-- <http://en.wikipedia.org/wiki/Stuck_in_the_Middle>+clowns :: FZipper a wX wY -> Sealed ((RL a) wX)+clowns (FZipper l _) = Sealed l++-- | See 'clowns'+jokers :: FZipper a wX wY -> FlippedSeal (FL a) wY+jokers (FZipper _ r) = FlippedSeal r++rightmost :: FZipper p wX wY -> Bool+rightmost (FZipper _ NilFL) = True+rightmost _ = False++right :: FZipper p wX wY -> FZipper p wX wY+right (FZipper l (b:>:r)) = FZipper (b :<: l) r+right x@(FZipper _ NilFL) = x++leftmost :: FZipper p wX wY -> Bool+leftmost (FZipper NilRL _) = True+leftmost _ = False++left :: FZipper p wX wY -> FZipper p wX wY+left (FZipper (b :<: l) r) = FZipper l (b :>: r)+left x@(FZipper NilRL _) = x++toEnd :: FZipper p wX wY -> FZipper p wX wY+toEnd (FZipper l r) = FZipper (reverseFL r +<+ l) NilFL++toStart :: FZipper p wX wY -> FZipper p wX wY+toStart (FZipper l r) = FZipper NilRL $ reverseRL l +>+ r
− src/Darcs/PrintPatch.hs
@@ -1,54 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.PrintPatch ( printPatch, contextualPrintPatch,- printPatchPager, printFriendly ) where--import Darcs.Patch ( Patchy, showContextPatch, showPatch )-import Darcs.Patch.Apply ( ApplyState )-import Storage.Hashed.Tree( Tree )-import Storage.Hashed.Monad( virtualTreeIO )-import Darcs.Arguments ( DarcsFlag, showFriendly )-import Darcs.Flags ( isUnified )-import Printer ( putDocLnWith )-import Darcs.ColorPrinter ( fancyPrinters )-import Darcs.External ( viewDocWith )---- | @'printFriendly' opts patch@ prints @patch@ in accordance with the--- flags in opts, ie, whether @--verbose@ or @--summary@ were passed at--- the command-line.-printFriendly :: (Patchy p, ApplyState p ~ Tree) => (Maybe (Tree IO)) -> [DarcsFlag] -> p C(x y) -> IO ()-printFriendly (Just pristine) opts p- | isUnified opts = virtualTreeIO (showContextPatch p) pristine >>= putDocLnWith fancyPrinters . fst-printFriendly _ opts p = putDocLnWith fancyPrinters $ showFriendly opts p---- | 'printPatch' prints a patch on standard output.-printPatch :: Patchy p => p C(x y) -> IO ()-printPatch p = putDocLnWith fancyPrinters $ showPatch p---- | 'printPatchPager' runs '$PAGER' and shows a patch in it.-printPatchPager :: Patchy p => p C(x y) -> IO ()-printPatchPager p = viewDocWith fancyPrinters $ showPatch p---- | 'contextualPrintPatch' prints a patch, together with its context,--- on standard output.-contextualPrintPatch :: (Patchy p, ApplyState p ~ Tree) => Tree IO -> p C(x y) -> IO ()-contextualPrintPatch s p = virtualTreeIO (showContextPatch p) s >>= putDocLnWith fancyPrinters . fst
− src/Darcs/ProgressPatches.hs
@@ -1,65 +0,0 @@-{-# LANGUAGE CPP, GADTs #-}--#include "gadts.h"-module Darcs.ProgressPatches (progressRL, progressFL, progressRLShowTags)-where-import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthRL, lengthFL )-import Darcs.Patch.PatchInfoAnd (PatchInfoAnd,info)-import System.IO.Unsafe ( unsafePerformIO )-import Progress (minlist, beginTedious,- endTedious, progress, progressKeepLatest,- tediousSize, finishedOne)-import Darcs.Patch.Info (justName, isTag)----- | Evaluate an 'FL' list and report progress.-progressFL :: String -> FL a C(x y) -> FL a C(x y)-progressFL _ NilFL = NilFL-progressFL k (x:>:xs) = if l < minlist then x:>:xs- else startit x :>: pl xs- where l = lengthFL (x:>:xs)- startit y = unsafePerformIO $ do beginTedious k- tediousSize k l- return y- pl :: FL a C(x y) -> FL a C(x y)- pl NilFL = NilFL- pl (y:>:NilFL) = unsafePerformIO $ do endTedious k- return (y:>:NilFL)- pl (y:>:ys) = progress k y :>: pl ys---- | Evaluate an 'RL' list and report progress.-progressRL :: String -> RL a C(x y) -> RL a C(x y)-progressRL _ NilRL = NilRL-progressRL k (x:<:xs) = if l < minlist then x:<:xs- else startit x :<: pl xs- where l = lengthRL (x:<:xs)- startit y = unsafePerformIO $ do beginTedious k- tediousSize k l- return y- pl :: RL a C(x y) -> RL a C(x y)- pl NilRL = NilRL- pl (y:<:NilRL) = unsafePerformIO $ do endTedious k- return (y:<:NilRL)- pl (y:<:ys) = progress k y :<: pl ys---- | Evaluate an 'RL' list and report progress. In addition to printing--- the number of patches we got, show the name of the last tag we got.-progressRLShowTags :: String -> RL (PatchInfoAnd p) C(x y)- -> RL (PatchInfoAnd p) C(x y)-progressRLShowTags _ NilRL = NilRL-progressRLShowTags k (x:<:xs) = if l < minlist then x:<:xs- else startit x :<: pl xs- where l = lengthRL (x:<:xs)- startit y = unsafePerformIO $ do beginTedious k- tediousSize k l- return y- pl :: RL (PatchInfoAnd p) C(x y) -> RL (PatchInfoAnd p) C(x y)- pl NilRL = NilRL- pl (y:<:NilRL) = unsafePerformIO $ do endTedious k- return (y:<:NilRL)- pl (y:<:ys) =- if isTag iy- then finishedOne k ("back to "++ justName iy) y :<: pl ys- else progressKeepLatest k y :<: pl ys- where- iy = info y
− src/Darcs/RemoteApply.hs
@@ -1,60 +0,0 @@--- | This module is used by the push and put commands to apply the a bundle to a--- remote repository. By remote I do not necessarily mean a repository on another--- machine, it is just not the repository we're located in.-module Darcs.RemoteApply ( remoteApply, applyAs ) where--import System.Exit ( ExitCode )--import Darcs.Flags ( DarcsFlag( ApplyAs, Debug ), remoteDarcs )-import Darcs.Utils ( breakCommand )-import Darcs.URL ( isHttpUrl, isSshUrl, splitSshUrl, SshFilePath(..) )-import Darcs.External ( darcsProgram, pipeDoc, pipeDocSSH, maybeURLCmd )-import qualified Darcs.Ssh as Ssh ( remoteDarcs )-import Printer ( Doc )--remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode-remoteApply opts repodir bundle- = case applyAs opts of- Nothing -> if isSshUrl repodir- then applyViaSsh opts (splitSshUrl repodir) bundle- else if isHttpUrl repodir- then applyViaUrl opts repodir bundle- else applyViaLocal opts repodir bundle- Just un -> if isSshUrl repodir- then applyViaSshAndSudo opts (splitSshUrl repodir) un bundle- else applyViaSudo un repodir bundle--applyAs :: [DarcsFlag] -> Maybe String-applyAs (ApplyAs user:_) = Just user-applyAs (_:fs) = applyAs fs-applyAs [] = Nothing-applyViaSudo :: String -> String -> Doc -> IO ExitCode-applyViaSudo user repo bundle =- darcsProgram >>= \darcs ->- pipeDoc "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle-applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode-applyViaLocal opts repo bundle =- darcsProgram >>= \darcs ->- pipeDoc darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle--applyViaUrl :: [DarcsFlag] -> String -> Doc -> IO ExitCode-applyViaUrl opts repo bundle =- do maybeapply <- maybeURLCmd "APPLY" repo- case maybeapply of- Nothing -> applyViaLocal opts repo bundle- Just apply ->- do let (cmd, args) = breakCommand apply- pipeDoc cmd (args ++ [repo]) bundle--applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode-applyViaSsh opts repo bundle =- pipeDocSSH repo [Ssh.remoteDarcs (remoteDarcs opts) ++" apply --all "++unwords (applyopts opts)++- " --repodir '"++(sshRepo repo)++"'"] bundle--applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO ExitCode-applyViaSshAndSudo opts repo username bundle =- pipeDocSSH repo ["sudo -u "++username++" "++Ssh.remoteDarcs (remoteDarcs opts)++- " apply --all --repodir '"++(sshRepo repo)++"'"] bundle--applyopts :: [DarcsFlag] -> [String]-applyopts opts = if Debug `elem` opts then ["--debug"] else []
− src/Darcs/RepoPath.hs
@@ -1,264 +0,0 @@-{-# LANGUAGE CPP #-}---- Copyright (C) 2007 Eric Kow------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- | Various abstractions for dealing with paths.-module Darcs.RepoPath (- -- * AbsolutePath- AbsolutePath,- makeAbsolute,- ioAbsolute,- rootDirectory,- -- * AbsolutePathOrStd- AbsolutePathOrStd,- makeAbsoluteOrStd,- ioAbsoluteOrStd,- useAbsoluteOrStd,- stdOut,- -- * AbsoluteOrRemotePath- AbsoluteOrRemotePath,- ioAbsoluteOrRemote,- isRemote,- -- * SubPath- SubPath,- makeSubPathOf,- simpleSubPath,- -- * Miscellaneous- sp2fn,- FilePathOrURL(..),- FilePathLike(toFilePath),- getCurrentDirectory,- setCurrentDirectory-) where--import Control.Applicative ( (<$>) )-import Data.List ( isPrefixOf, isSuffixOf )-import Control.Exception ( tryJust, bracket )-import System.IO.Error ( isDoesNotExistError )--import Darcs.URL ( isAbsolute, isRelative, isSshNopath )-import qualified Workaround ( getCurrentDirectory )-import qualified System.Directory ( setCurrentDirectory )-import System.Directory ( doesDirectoryExist )-import qualified System.FilePath.Posix as FilePath ( normalise )-import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory )-import qualified Darcs.Patch.FileName as PatchFileName ( FileName, fp2fn, fn2fp )-import System.Posix.Files ( isDirectory, getSymbolicLinkStatus )-#include "impossible.h"--class FilePathOrURL a where- toPath :: a -> String--class FilePathOrURL a => FilePathLike a where- toFilePath :: a -> FilePath---- | Paths which are relative to the local darcs repository and normalized.--- Note: These are understood not to have the dot in front.-newtype SubPath = SubPath FilePath deriving (Eq, Ord)--newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord)---- | This is for situations where a string (e.g. a command line argument)--- may take the value \"-\" to mean stdin or stdout (which one depends on--- context) instead of a normal file path.-data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (Eq, Ord)-data AbsoluteOrRemotePath = AbsP AbsolutePath | RmtP String deriving (Eq, Ord)--instance FilePathOrURL AbsolutePath where- toPath (AbsolutePath x) = x-instance FilePathOrURL SubPath where- toPath (SubPath x) = x-instance CharLike c => FilePathOrURL [c] where- toPath = toFilePath--instance FilePathOrURL AbsoluteOrRemotePath where- toPath (AbsP a) = toPath a- toPath (RmtP r) = r--instance FilePathOrURL PatchFileName.FileName where- toPath = PatchFileName.fn2fp-instance FilePathLike PatchFileName.FileName where- toFilePath = PatchFileName.fn2fp--instance FilePathLike AbsolutePath where- toFilePath (AbsolutePath x) = x-instance FilePathLike SubPath where- toFilePath (SubPath x) = x--class CharLike c where- toChar :: c -> Char- fromChar :: Char -> c-instance CharLike Char where- toChar = id- fromChar = id--instance CharLike c => FilePathLike [c] where- toFilePath = map toChar---- | Make the second path relative to the first, if possible-makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath-makeSubPathOf (AbsolutePath p1) (AbsolutePath p2) =- -- The slash prevents "foobar" from being treated as relative to "foo"- if p1 == p2 || (p1 ++ "/") `isPrefixOf` p2- then Just $ SubPath $ drop (length p1 + 1) p2- else Nothing--simpleSubPath :: FilePath -> Maybe SubPath-simpleSubPath x | null x = bug "simpleSubPath called with empty path"- | isRelative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x- | otherwise = Nothing---- | Ensure directory exists and is not a symbolic link.-doesDirectoryReallyExist :: FilePath -> IO Bool-doesDirectoryReallyExist f = do- x <- tryJust (\x -> if isDoesNotExistError x then Just () else Nothing) $- isDirectory <$> getSymbolicLinkStatus f- return $ case x of- Left () -> False- Right y -> y---- | Interpret a possibly relative path wrt the current working directory.-ioAbsolute :: FilePath -> IO AbsolutePath-ioAbsolute dir =- do isdir <- doesDirectoryReallyExist dir- here <- getCurrentDirectory- if isdir- then bracket (setCurrentDirectory dir)- (const $ setCurrentDirectory $ toFilePath here)- (const getCurrentDirectory)- else let super_dir = case NativeFilePath.takeDirectory dir of- "" -> "."- d -> d- file = NativeFilePath.takeFileName dir- in do abs_dir <- if dir == super_dir- then return $ AbsolutePath dir- else ioAbsolute super_dir- return $ makeAbsolute abs_dir file---- | Take an absolute path and a string representing a (possibly relative)--- path and combine them into an absolute path. If the second argument is--- already absolute, then the first argument gets ignored. This function also--- takes care that the result is converted to Posix convention and--- normalized. Also, parent directories (\"..\") at the front of the string--- argument get canceled out against trailing directory parts of the--- absolute path argument.------ Regarding the last point, someone more familiar with how these functions--- are used should verify that this is indeed necessary or at least useful.-makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath-makeAbsolute a dir = if not (null dir) && isAbsolute dir- then AbsolutePath (normSlashes dir')- else ma a dir'- where- dir' = FilePath.normalise $ pathToPosix dir- -- Why do we care to reduce ".." here?- -- Why not do this throughout the whole path, i.e. "x/y/../z" -> "x/z" ?- ma here ('.':'.':'/':r) = ma (takeDirectory here) r- ma here ".." = takeDirectory here- ma here "." = here- ma here "" = here- ma here r = here /- ('/':r)--(/-) :: AbsolutePath -> String -> AbsolutePath-x /- ('/':r) = x /- r-(AbsolutePath "/") /- r = AbsolutePath ('/':simpleClean r)-(AbsolutePath x) /- r = AbsolutePath (x++'/':simpleClean r)---- | Convert to posix, remove trailing slashes, and (under Posix)--- reduce multiple leading slashes to one.-simpleClean :: String -> String-simpleClean = normSlashes . reverse . dropWhile (=='/') . reverse . pathToPosix---- | The root directory as an absolute path.-rootDirectory :: AbsolutePath-rootDirectory = AbsolutePath "/"--makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd-makeAbsoluteOrStd _ "-" = APStd-makeAbsoluteOrStd a p = AP $ makeAbsolute a p--stdOut :: AbsolutePathOrStd-stdOut = APStd--ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd-ioAbsoluteOrStd "-" = return APStd-ioAbsoluteOrStd p = AP `fmap` ioAbsolute p---- | Execute either the first or the second argument action, depending on--- whether the given path is an 'AbsolutePath' or stdin/stdout.-useAbsoluteOrStd :: (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a-useAbsoluteOrStd _ f APStd = f-useAbsoluteOrStd f _ (AP x) = f x--ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath-ioAbsoluteOrRemote p = do- isdir <- doesDirectoryExist p- if not isdir- then return $ RmtP $- case () of _ | isSshNopath p -> p++"."- | "/" `isSuffixOf` p -> init p- | otherwise -> p- else AbsP `fmap` ioAbsolute p--isRemote :: AbsoluteOrRemotePath -> Bool-isRemote (RmtP _) = True-isRemote _ = False--takeDirectory :: AbsolutePath -> AbsolutePath-takeDirectory (AbsolutePath x) =- case reverse $ drop 1 $ dropWhile (/='/') $ reverse x of- "" -> AbsolutePath "/"- x' -> AbsolutePath x'--instance Show AbsolutePath where- show = show . toFilePath-instance Show SubPath where- show = show . toFilePath-instance Show AbsolutePathOrStd where- show (AP a) = show a- show APStd = "standard input/output"-instance Show AbsoluteOrRemotePath where- show (AbsP a) = show a- show (RmtP r) = show r---- | Normalize the path separator to Posix style (slash, not backslash).--- This only affects Windows systems.-pathToPosix :: FilePath -> FilePath-pathToPosix = map convert where-#ifdef WIN32- convert '\\' = '/'-#endif- convert c = c---- | Reduce multiple leading slashes to one. This only affects Posix systems.-normSlashes :: FilePath -> FilePath-#ifndef WIN32--- multiple slashes in front are ignored under Posix-normSlashes ('/':p) = '/' : dropWhile (== '/') p-#endif-normSlashes p = p--getCurrentDirectory :: IO AbsolutePath-getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory--setCurrentDirectory :: FilePathLike p => p -> IO ()-setCurrentDirectory = System.Directory.setCurrentDirectory . toFilePath--{-# INLINE sp2fn #-}-sp2fn :: SubPath -> PatchFileName.FileName-sp2fn = PatchFileName.fp2fn . toFilePath
src/Darcs/Repository.hs view
@@ -18,141 +18,307 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-} -#include "gadts.h" module Darcs.Repository- ( Repository, HashedDir(..), Cache(..), CacheLoc(..), WritableOrNot(..)- , RepoJob(..), maybeIdentifyRepository, identifyRepositoryFor- , withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory- , withGutsOf, makePatchLazy, writePatchSet, findRepository, amInRepository- , amNotInRepository, amInHashedRepository, replacePristine- , withRecorded, readRepo, prefsUrl, readRepoUsingSpecificInventory- , addToPending, tentativelyAddPatch, tentativelyRemovePatches- , tentativelyAddToPending, tentativelyReplacePatches, readTentativeRepo- , tentativelyMergePatches, considerMergeToWorking, revertRepositoryChanges- , finalizeRepositoryChanges, createRepository, copyRepository- , patchSetToRepository, unrevertUrl, applyToWorking- , patchSetToPatches, createPristineDirectoryTree- , createPartialsPristineDirectoryTree, optimizeInventory, cleanRepository- , PatchSet, SealedPatchSet, PatchInfoAnd- , setScriptsExecutable, setScriptsExecutablePatches- , checkUnrelatedRepos, testTentative, testRecorded- , extractOptions, modifyCache, reportBadSources+ ( Repository+ , HashedDir(..)+ , Cache(..)+ , CacheLoc(..)+ , WritableOrNot(..)+ , RepoJob(..)+ , maybeIdentifyRepository+ , identifyRepositoryFor+ , withRecorded+ , withRepoLock+ , withRepoLockCanFail+ , withRepository+ , withRepositoryDirectory+ , writePatchSet+ , findRepository+ , amInRepository+ , amNotInRepository+ , amInHashedRepository+ , replacePristine+ , readRepo+ , prefsUrl+ , repoPatchType+ , readRepoUsingSpecificInventory+ , addToPending+ , addPendingDiffToPending+ , tentativelyAddPatch+ , tentativelyRemovePatches+ , tentativelyAddToPending+ , tentativelyReplacePatches+ , readTentativeRepo+ , withManualRebaseUpdate+ , tentativelyMergePatches+ , considerMergeToWorking+ , revertRepositoryChanges+ , finalizeRepositoryChanges+ , createRepository+ , cloneRepository+ , patchSetToRepository+ , unrevertUrl+ , applyToWorking+ , patchSetToPatches+ , createPristineDirectoryTree+ , createPartialsPristineDirectoryTree+ , reorderInventory+ , cleanRepository+ , PatchSet+ , SealedPatchSet+ , PatchInfoAnd+ , setScriptsExecutable+ , setScriptsExecutablePatches+ , checkUnrelatedRepos+ , testTentative+ , modifyCache+ , reportBadSources -- * Recorded and unrecorded and pending.- , readRecorded, readUnrecorded, unrecordedChanges, readPending+ , readRecorded+ , readUnrecorded+ , unrecordedChanges+ , unrecordedChangesWithPatches+ , filterOutConflicts+ , readPending , readRecordedAndPending -- * Index.- , readIndex, invalidateIndex+ , readIndex+ , invalidateIndex+ -- * Used as command arguments+ , listFiles+ , listRegisteredFiles+ , listUnregisteredFiles ) where -import Prelude hiding ( catch )+import Prelude hiding ( catch, pi ) -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 System.Exit ( exitSuccess )+import Data.List ( (\\), isPrefixOf ) import Data.Maybe( catMaybes, isJust, listToMaybe ) -import Darcs.Repository.State( readRecorded, readUnrecorded, readWorking, unrecordedChanges- , readPending, readIndex, invalidateIndex- , readRecordedAndPending )+import Darcs.Repository.State+ ( readRecorded+ , readUnrecorded+ , readWorking+ , unrecordedChanges+ , unrecordedChangesWithPatches+ , readPendingAndWorking+ , readPending+ , readIndex+ , invalidateIndex+ , readRecordedAndPending+ , restrictDarcsdir+ , restrictBoring+ , applyTreeFilter+ , filterOutConflicts+ ) import Darcs.Repository.Internal- (Repository(..), RepoType(..), RepoJob(..),- maybeIdentifyRepository, identifyRepositoryFor, identifyDarcsRepository,- IdentifyRepo(..),- findRepository, amInRepository, amNotInRepository, amInHashedRepository,- makePatchLazy,- withRecorded,- readRepo, readTentativeRepo, readRepoUsingSpecificInventory,- prefsUrl,- withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf,- tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,- tentativelyReplacePatches,- revertRepositoryChanges, finalizeRepositoryChanges,- unrevertUrl,- applyToWorking, patchSetToPatches,- createPristineDirectoryTree, createPartialsPristineDirectoryTree,- optimizeInventory, cleanRepository,- setScriptsExecutable, setScriptsExecutablePatches,- testTentative, testRecorded,- makeNewPending, seekRepo+ (Repository(..)+ , maybeIdentifyRepository+ , identifyRepositoryFor+ , identifyRepository+ , IdentifyRepo(..)+ , findRepository+ , amInRepository+ , amNotInRepository+ , amInHashedRepository+ , readRepo+ , readTentativeRepo+ , readRepoUsingSpecificInventory+ , prefsUrl+ , withRecorded+ , tentativelyAddPatch+ , tentativelyRemovePatches+ , tentativelyReplacePatches+ , tentativelyAddToPending+ , revertRepositoryChanges+ , finalizeRepositoryChanges+ , unrevertUrl+ , applyToWorking+ , patchSetToPatches+ , createPristineDirectoryTree+ , createPartialsPristineDirectoryTree+ , reorderInventory+ , cleanRepository+ , setScriptsExecutable+ , setScriptsExecutablePatches+ , makeNewPending+ , seekRepo )-import Darcs.Repository.Merge( tentativelyMergePatches, considerMergeToWorking )-import Darcs.Repository.Cache ( unionRemoteCaches, fetchFileUsingCache,- speculateFileUsingCache, HashedDir(..), Cache(..),- CacheLoc(..), WritableOrNot(..), hashedDir ,- CacheType(Directory), reportBadSources )-import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2RL, newset2FL, progressPatchSet )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import URL ( maxPipelineLength )+import Darcs.Repository.Job+ ( RepoJob(..)+ , withRepoLock+ , withRepoLockCanFail+ , withRepository+ , withRepositoryDirectory+ )+import Darcs.Repository.Rebase ( withManualRebaseUpdate )+import Darcs.Repository.Test+ ( testTentative ) -import Control.Exception ( finally )+import Darcs.Repository.Merge( tentativelyMergePatches+ , considerMergeToWorking+ )+import Darcs.Repository.Cache ( unionRemoteCaches+ , fetchFileUsingCache+ , speculateFileUsingCache+ , HashedDir(..)+ , Cache(..)+ , CacheLoc(..)+ , WritableOrNot(..)+ , hashedDir+ , bucketFolder+ , CacheType(Directory)+ , reportBadSources+ )++import Darcs.Patch ( RepoPatch+ , apply+ , invert+ , effect+ , PrimOf+ )+import Darcs.Patch.Set ( Origin+ , PatchSet(..)+ , SealedPatchSet+ , newset2RL+ , newset2FL+ , progressPatchSet+ )+import Darcs.Patch.Match ( MatchFlag(..), havePatchsetMatch )+import Darcs.Patch.Commute( commuteFL )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL )+import Control.Exception ( catch, Exception, throwIO, finally, IOException ) import Control.Concurrent ( forkIO )-import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar )-import Control.Monad ( unless, when )-import System.Directory ( createDirectory, createDirectoryIfMissing, renameFile,- doesFileExist, removeFile, getDirectoryContents,- getCurrentDirectory, setCurrentDirectory )+import Control.Concurrent.MVar ( MVar+ , newMVar+ , putMVar+ , takeMVar+ )+import Control.Monad ( unless, when, void )+import Control.Applicative( (<$>) )+import System.Directory ( createDirectory+ , createDirectoryIfMissing+ , renameFile+ , doesFileExist+ , removeFile+ , getDirectoryContents+ , getCurrentDirectory+ , setCurrentDirectory+ ) import System.IO ( stderr ) import System.IO.Error ( isAlreadyExistsError ) import System.Posix.Files ( createLink ) import qualified Darcs.Repository.HashedRepo as HashedRepo -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash )-import Darcs.Repository.ApplyPatches ( applyPatches )-import Darcs.Repository.HashedRepo ( applyToTentativePristine, pris2inv, revertTentativeChanges,- copySources )-import Darcs.Repository.InternalTypes ( extractOptions, modifyCache )-import Darcs.Patch ( RepoPatch, PrimOf )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash, hopefully )+import Darcs.Repository.ApplyPatches ( applyPatches, runDefault )+import Darcs.Repository.HashedRepo ( applyToTentativePristine+ , pris2inv+ , inv2pris+ , revertTentativeChanges+ , copySources+ )+import Darcs.Repository.InternalTypes ( modifyCache ) import Darcs.Patch.Apply( ApplyState )--import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapRL- , lengthRL, (+>+), (:\/:)(..) )-import Darcs.Repository.Format ( RepoProperty ( HashedInventory ), RepoFormat,- createRepoFormat, formatHas, writeRepoFormat,- readfromAndWritetoProblem)-import Darcs.Repository.Prefs ( writeDefaultPrefs )-import Darcs.Patch.Depends ( areUnrelatedRepos, findUncommon )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), FreeLeft, unFreeLeft )+import Darcs.Patch.Witnesses.Ordered+ ((:>)(..), reverseRL, reverseFL, lengthFL, mapFL_FL, FL(..),+ RL(..), bunchFL, mapFL, mapRL, lengthRL, (+>+), (:\/:)(..))+import Darcs.Repository.Format ( RepoProperty ( HashedInventory, Darcs2 )+ , RepoFormat+ , createRepoFormat+ , formatHas+ , writeRepoFormat+ , readProblem+ )+import Darcs.Repository.Prefs ( writeDefaultPrefs, addRepoSource, deleteSources )+import Darcs.Repository.Match ( getOnePatchset )+import Darcs.Patch.Depends ( areUnrelatedRepos, findUncommon, findCommonWithThem+ , countUsThem )+import Darcs.Patch.Type ( PatchType(..) ) -import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn )-import Darcs.External ( copyFileOrUrl, Cachable(..), fetchFileLazyPS )-import Progress ( debugMessage, tediousSize, beginTedious, endTedious )-import Darcs.ProgressPatches (progressRLShowTags, progressFL)-import Darcs.Lock ( writeBinFile, writeDocBinFile, withTemp )-import Darcs.Witnesses.Sealed ( Sealed(..) )+import Darcs.Util.Exception ( catchall )+import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.English ( englishNum, Noun(..) )+import Darcs.Repository.External+ ( copyFileOrUrl+ , Cachable(..)+ , fetchFileLazyPS+ , gzFetchFilePS+ )+import Darcs.Util.Progress ( debugMessage+ , tediousSize+ , beginTedious+ , endTedious+ )+import Darcs.Patch.Progress+ ( progressRLShowTags+ , progressFL+ )+import Darcs.Repository.Lock+ ( writeBinFile+ , writeDocBinFile+ , withTemp+ )+import Darcs.Repository.Flags+ ( UpdateWorking(..)+ , UseCache(..)+ , UseIndex(..)+ , ScanKnown(..)+ , RemoteDarcs (..)+ , Reorder (..)+ , Compression (..)+ , CloneKind (..)+ , Verbosity (..)+ , DryRun (..)+ , UMask (..)+ , AllowConflicts (..)+ , ExternalMerge (..)+ , WantGuiPause (..)+ , SetScriptsExecutable (..)+ , RemoteRepos (..)+ , SetDefault (..)+ , DiffAlgorithm (..)+ , WithWorkingDir (..)+ , ForgetParent (..)+ , WithPatchIndex (..)+ ) -import Darcs.Flags ( DarcsFlag( Verbose, Quiet, Lazy, Complete,- AllowUnrelatedRepos, NoUpdateWorking)- , compression, UseIndex(..), ScanKnown(..), remoteDarcs- , usePacks )-import Darcs.Global ( darcsdir )-import Darcs.URL ( isFile )-import Darcs.SignalHandler ( catchInterrupt )-import Printer ( Doc, text, hPutDocLn, putDocLn )+import Darcs.Util.Download ( maxPipelineLength )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.URL ( isValidLocalPath )+import Darcs.Util.SignalHandler ( catchInterrupt )+import Darcs.Util.Printer ( Doc, text, hPutDocLn, putDocLn, errorDoc, RenderMode(..) ) -import Storage.Hashed.Tree( Tree, emptyTree )+import Storage.Hashed.Plain( readPlainTree )+import Storage.Hashed.Tree( Tree, emptyTree, expand, list ) import Storage.Hashed.Hash( encodeBase16 )+import Darcs.Util.Path( anchorPath ) import Storage.Hashed.Darcs( writeDarcsHashed, darcsAddMissingHashes )-import ByteStringUtils( gzReadFilePS )+import Darcs.Util.ByteString( gzReadFilePS ) -import System.FilePath( (</>), takeFileName, splitPath, joinPath- , takeDirectory )+import System.FilePath( (</>)+ , takeFileName+ , splitPath+ , joinPath+ , takeDirectory+ ) import qualified Codec.Archive.Tar as Tar import Codec.Compression.GZip ( compress, decompress ) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL-+import Darcs.Repository.PatchIndex (createOrUpdatePatchIndexDisk, doesPatchIndexExist, createPIWithInterrupt) #include "impossible.h" -createRepository :: [DarcsFlag] -> IO ()-createRepository opts = do++-- @createRepository useFormat1 useNoWorkingDir patchIndex@+createRepository :: Bool -> WithWorkingDir -> WithPatchIndex -> IO ()+createRepository useFormat1 withWorkingDir createPatchIndex = do createDirectory darcsdir `catch` (\e-> if isAlreadyExistsError e then fail "Tree has already been initialized!"@@ -161,138 +327,297 @@ x <- seekRepo when (isJust x) $ do setCurrentDirectory cwd- putStrLn $ "WARNING: creating a nested repository."- let rf = createRepoFormat opts+ putStrLn "WARNING: creating a nested repository." createDirectory $ darcsdir ++ "/pristine.hashed" createDirectory $ darcsdir ++ "/patches"+ createDirectory $ darcsdir ++ "/inventories" createDirectory $ darcsdir ++ "/prefs" writeDefaultPrefs- writeRepoFormat rf (darcsdir++"/format")+ let repoFormat = createRepoFormat useFormat1 withWorkingDir+ writeRepoFormat repoFormat (darcsdir++"/format") writeBinFile (darcsdir++"/hashed_inventory") "" writePristine "." emptyTree+ withRepository NoUseCache $ RepoJob $ \repo -> case createPatchIndex of+ NoPatchIndex -> return () -- default+ YesPatchIndex -> createOrUpdatePatchIndexDisk repo -data RepoSort = Hashed | Old+repoPatchType :: Repository p wR wU wT -> PatchType p+repoPatchType _ = PatchType -repoSort :: RepoFormat -> RepoSort-repoSort f- | formatHas HashedInventory f = Hashed- | otherwise = Old+cloneRepository ::+ String -- origin repository path+ -> String -- new repository name (for relative path)+ -> Verbosity -> UseCache+ -> CloneKind+ -> UMask -> RemoteDarcs+ -> SetScriptsExecutable+ -> RemoteRepos -> SetDefault+ -> [MatchFlag]+ -> RepoFormat+ -> WithWorkingDir+ -> WithPatchIndex -- use patch index+ -> Bool -- use packs+ -> Bool -- --to-match given+ -> ForgetParent+ -> IO ()+cloneRepository repodir mysimplename v uc cloneKind um rdarcs sse remoteRepos+ setDefault matchFlags rfsource withWorkingDir usePatchIndex usePacks toMatch forget = do+ createDirectory mysimplename+ setCurrentDirectory mysimplename+ createRepository (not $ formatHas Darcs2 rfsource)+ withWorkingDir+ (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex)+ debugMessage "Finished initializing new directory."+ addRepoSource repodir NoDryRun remoteRepos setDefault -copyInventory :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-copyInventory fromRepo@(Repo fromDir opts fromFormat (DarcsRepository _ fromCache)) = do- toRepo@(Repo toDir opts' toFormat (DarcsRepository toPristine toCache)) <-- identifyDarcsRepository opts "."- let (_ :: Repository p C(r u t)) = toRepo --The witnesses are wrong, but cannot escape- case readfromAndWritetoProblem fromFormat toFormat of- Just e -> fail $ "Incompatibility with repository " ++ fromDir ++ ":\n" ++ e- Nothing -> return ()+ if toMatch && cloneKind /= LazyClone+ then withRepository uc $ RepoJob $ \repository -> do+ debugMessage "Using economical clone --to-match handling"+ fromrepo <- identifyRepositoryFor repository uc repodir+ Sealed patches_to_get <- getOnePatchset fromrepo matchFlags+ patchSetToRepository fromrepo patches_to_get uc rdarcs+ debugMessage "Finished converting selected patch set to new repository"+ else copyRepoAndGoToChosenVersion repodir v uc cloneKind um rdarcs sse+ matchFlags withWorkingDir usePacks forget++-- assumes that the target repo of the get is the current directory,+-- and that an inventory in the right format has already been created.+copyRepoAndGoToChosenVersion ::+ String -- repository directory+ -> Verbosity -> UseCache+ -> CloneKind+ -> UMask -> RemoteDarcs+ -> SetScriptsExecutable+ -> [MatchFlag]+ -> WithWorkingDir -> Bool+ -> ForgetParent+ -> IO ()+copyRepoAndGoToChosenVersion repodir v uc gk um rdarcs sse matchFlags withWorkingDir usePacks forget =+ withRepository uc $ RepoJob $ \repository -> do+ debugMessage "Identifying and copying repository..."+ fromRepo@(Repo fromDir rffrom _ _) <- identifyRepositoryFor repository uc repodir+ case readProblem rffrom of+ Just e -> fail $ "Incompatibility with repository " ++ fromDir ++ ":\n" ++ e+ Nothing -> return ()+ debugMessage "Copying prefs"+ copyFileOrUrl rdarcs (fromDir ++ "/" ++ darcsdir ++ "/prefs/prefs")+ (darcsdir ++ "/prefs/prefs") (MaxAge 600) `catchall` return ()+ if formatHas HashedInventory rffrom+ then do+ -- copying basic repository (hashed_inventory and pristine)+ if usePacks && (not . isValidLocalPath) fromDir+ then copyBasicRepoPacked fromRepo v uc um rdarcs withWorkingDir+ else copyBasicRepoNotPacked fromRepo v uc um rdarcs withWorkingDir+ when (gk /= LazyClone) $ do+ when (gk /= CompleteClone) $+ putInfo v $ text "Copying patches, to get lazy repository hit ctrl-C..."+ -- copying complete repository (inventories and patches)+ if usePacks && (not . isValidLocalPath) fromDir+ then copyCompleteRepoPacked fromRepo v uc um gk+ else copyCompleteRepoNotPacked fromRepo v uc um gk+ else+ -- old-fashioned repositories are cloned diferently since+ -- we need to copy all patches first and then build pristine+ copyRepoOldFashioned fromRepo v uc um withWorkingDir+ when (sse == YesSetScriptsExecutable) setScriptsExecutable+ when (havePatchsetMatch matchFlags) $ do+ putStrLn "Going to specified version..."+ -- read again repository on disk to get caches and sources right+ withRepoLock NoDryRun uc YesUpdateWorking um $ RepoJob $ \repository' -> do+ patches <- readRepo repository'+ Sealed context <- getOnePatchset repository' matchFlags+ when (snd (countUsThem patches context) > 0) $+ errorDoc $ text "Missing patches from context!" -- FIXME : - (+ _ :> us' <- return $ findCommonWithThem patches context+ let ps = mapFL_FL hopefully us'+ putInfo v $ text $ "Unapplying " ++ show (lengthFL ps) ++ " " +++ englishNum (lengthFL ps) (Noun "patch") ""+ invalidateIndex repository'+ _ <- tentativelyRemovePatches repository' GzipCompression YesUpdateWorking us'+ tentativelyAddToPending repository' YesUpdateWorking $ invert $ effect us'+ finalizeRepositoryChanges repository' YesUpdateWorking GzipCompression+ runDefault (apply (invert $ effect ps)) `catch` \(e :: IOException) ->+ fail ("Couldn't undo patch in working dir.\n" ++ show e)+ when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches (invert $ effect ps)+ when (forget == YesForgetParent) deleteSources++putInfo :: Verbosity -> Doc -> IO ()+putInfo Quiet _ = return ()+putInfo _ d = hPutDocLn Encode stderr d++putVerbose :: Verbosity -> Doc -> IO ()+putVerbose Verbose d = putDocLn d+putVerbose _ _ = return ()++copyBasicRepoNotPacked :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> Verbosity -> UseCache+ -> UMask -> RemoteDarcs+ -> WithWorkingDir+ -> IO ()+copyBasicRepoNotPacked (Repo fromDir _ _ fromCache) verb useCache umask rdarcs withWorkingDir = do+ toRepo@(Repo toDir toFormat toPristine toCache) <- identifyRepository useCache "."+ let (_dummy :: Repository p wR wU wT) = toRepo --The witnesses are wrong, but cannot escape toCache2 <- unionRemoteCaches toCache fromCache fromDir- let toRepo2 :: Repository p C(r u t)- toRepo2 = Repo toDir opts' toFormat $ DarcsRepository toPristine toCache2- copyHashedHashed = HashedRepo.copyRepo toRepo2 (remoteDarcs opts) fromDir- case repoSort fromFormat of- Hashed -> copyHashedHashed- Old -> withCurrentDirectory toDir $ do- HashedRepo.revertTentativeChanges- patches <- readRepo fromRepo- let k = "Copying patch"- beginTedious k- tediousSize k (lengthRL $ newset2RL patches)- let patches' = progressPatchSet k patches- HashedRepo.writeTentativeInventory toCache (compression opts) patches'- endTedious k- HashedRepo.finalizeTentativeChanges toRepo $ compression opts+ let toRepo2 :: Repository p wR wU wT+ toRepo2 = Repo toDir toFormat toPristine toCache2+ HashedRepo.copyHashedInventory toRepo2 rdarcs fromDir+ HashedRepo.copySources toRepo2 fromDir+ debugMessage "Grabbing lock in new repository to copy basic repo..."+ withRepoLock NoDryRun useCache YesUpdateWorking umask+ $ RepoJob $ \torepository -> do+ putVerbose verb $ text "Writing pristine and working directory contents..."+ createPristineDirectoryTree torepository "." withWorkingDir -copyRepository :: forall p C(r u t). (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)- => Repository p C(r u t) -> Bool -> IO ()-copyRepository fromRepo@(Repo fromDir opts _ _) withWorkingDir = do- debugMessage "Copying prefs"- copyFileOrUrl (remoteDarcs opts) (fromDir ++ "/" ++ darcsdir ++ "/prefs/prefs")- (darcsdir ++ "/prefs/prefs") (MaxAge 600) `catchall` return ()- -- try packs for remote repositories- if (not . isFile) fromDir && usePacks opts- then copyPackedRepository fromRepo withWorkingDir- else copyNotPackedRepository fromRepo withWorkingDir -putInfo :: [DarcsFlag] -> Doc -> IO ()-putInfo opts = unless (Quiet `elem` opts) . hPutDocLn stderr+copyCompleteRepoNotPacked :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> Verbosity -> UseCache+ -> UMask -> CloneKind+ -> IO ()+copyCompleteRepoNotPacked _ verb useCache umask cloneKind = do+ debugMessage "Grabbing lock in new repository to copy complete repo..."+ withRepoLock NoDryRun useCache YesUpdateWorking umask+ $ RepoJob $ \torepository@(Repo todir _ _ _) -> do+ let cleanup = putInfo verb $ text "Using lazy repository."+ allowCtrlC cloneKind cleanup $ do+ fetchPatchesIfNecessary torepository+ pi <- doesPatchIndexExist todir+ when pi $ createPIWithInterrupt torepository -copyNotPackedRepository :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) ->- Bool -> IO ()-copyNotPackedRepository fromrepository@(Repo _ opts rffrom _) withWorkingDir = do- copyInventory fromrepository- debugMessage "Grabbing lock in new repository..."- withRepoLock opts $ RepoJob $ \torepository ->- if formatHas HashedInventory rffrom- then do- when withWorkingDir $ do- debugMessage "Writing working directory contents..."- createPristineDirectoryTree torepository "."- fetchPatchesIfNecessary opts torepository `catchInterrupt`- (putInfo opts $ text "Using lazy repository.")- else do local_patches <- readRepo torepository- replacePristine torepository emptyTree- let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches- sequence_ $ mapFL applyToTentativePristine $ bunchFL 100 patchesToApply- finalizeRepositoryChanges torepository- when withWorkingDir $ do- debugMessage "Writing working directory contents..."- createPristineDirectoryTree torepository "."+packsDir :: String+packsDir = "/" ++ darcsdir ++ "/packs/" -copyPackedRepository ::- forall p C(r u t). (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)- => Repository p C(r u t) -> Bool -> IO ()-copyPackedRepository r withWorkingDir =- -- fallback to no-packs get in case of error- copyPackedRepository2 r withWorkingDir `catchall` copyNotPackedRepository r withWorkingDir+copyBasicRepoPacked ::+ forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> Verbosity -> UseCache+ -> UMask -> RemoteDarcs+ -> WithWorkingDir+ -> IO ()+copyBasicRepoPacked r@(Repo fromDir _ _ _) verb useCache umask rdarcs withWorkingDir =+ do let hashURL = fromDir ++ packsDir ++ "pristine"+ mPackHash <- (Just <$> gzFetchFilePS hashURL Uncachable) `catchall` (return Nothing)+ let hiURL = fromDir ++ "/" ++ darcsdir ++ "/hashed_inventory"+ i <- gzFetchFilePS hiURL Uncachable+ let currentHash = BS.pack $ inv2pris i+ let copyNormally = copyBasicRepoNotPacked r verb useCache umask rdarcs withWorkingDir+ case mPackHash of+ Just packHash | packHash == currentHash+ -> ( copyBasicRepoPacked2 r verb useCache withWorkingDir+ `catchall` do putStrLn "Problem while copying basic pack, copying normally."+ copyNormally)+ _ -> do putVerbose verb $ text "Remote repo has no basic pack or outdated basic pack, copying normally."+ copyNormally -copyPackedRepository2 ::- forall p C(r u t). (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)- => Repository p C(r u t) -> Bool -> IO ()-copyPackedRepository2 fromRepo@(Repo fromDir opts _ (DarcsRepository _ fromCache)) withWorkingDir = do- b <- fetchFileLazyPS (fromDir ++ "/" ++ darcsdir ++ "/packs/basic.tar.gz") Uncachable- when (Verbose `elem` opts) $ putDocLn $ text "Getting packed repository."- Repo toDir _ toFormat (DarcsRepository toPristine toCache) <-- identifyRepositoryFor fromRepo "."+copyBasicRepoPacked2 ::+ forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> Verbosity -> UseCache+ -> WithWorkingDir -> IO ()+copyBasicRepoPacked2 fromRepo@(Repo fromDir _ _ fromCache) verb useCache withWorkingDir = do+ b <- fetchFileLazyPS (fromDir ++ packsDir ++ "basic.tar.gz") Uncachable+ putVerbose verb $ text "Cloning packed basic repository."+ Repo toDir toFormat toPristine toCache <-+ identifyRepositoryFor fromRepo useCache "." toCache2 <- unionRemoteCaches toCache fromCache fromDir- let toRepo :: Repository p C(r u r) -- In empty repo, t(entative) = r(ecorded)- toRepo = Repo toDir opts toFormat $ DarcsRepository toPristine toCache2- fromPacksDir = fromDir ++ "/" ++ darcsdir ++ "/packs/"- createDirectoryIfMissing False $ darcsdir </> "inventories"+ let toRepo :: Repository p wR wU wR -- In empty repo, t(entative) = r(ecorded)+ toRepo = Repo toDir toFormat toPristine toCache2 copySources toRepo fromDir- Repo _ _ _ (DarcsRepository _ toCache3) <-- identifyRepositoryFor toRepo "."+ Repo _ _ _ toCache3 <-+ identifyRepositoryFor toRepo useCache "." -- unpack inventory & pristine cache- let isLazy = Lazy `elem` opts cleanDir "pristine.hashed" removeFile $ darcsdir </> "hashed_inventory" unpackBasic toCache3 . Tar.read $ decompress b- when withWorkingDir $- createPristineDirectoryTree toRepo "."+ createPristineDirectoryTree toRepo "." withWorkingDir+ putVerbose verb $ text "Basic repository unpacked. Will now see if there are new patches." -- pull new patches us <- readRepo toRepo them <- readRepo fromRepo us' :\/: them' <- return $ findUncommon us them revertTentativeChanges- Sealed pw <- tentativelyMergePatches toRepo "get" opts us' them'+ Sealed pw <- tentativelyMergePatches toRepo "clone" NoAllowConflicts YesUpdateWorking NoExternalMerge NoWantGuiPause GzipCompression verb NoReorder ( UseIndex, ScanKnown, MyersDiff ) us' them' invalidateIndex toRepo- withGutsOf toRepo $ do- finalizeRepositoryChanges toRepo- when withWorkingDir $- applyToWorking toRepo opts pw >> return ()- return ()+ finalizeRepositoryChanges toRepo YesUpdateWorking GzipCompression+ when (withWorkingDir == WithWorkingDir) $ void $ applyToWorking toRepo verb pw+ where+ cleanDir d = mapM_ (\x -> removeFile $ darcsdir </> d </> x) .+ filter (\x -> head x /= '.') =<< getDirectoryContents (darcsdir </> d)++copyCompleteRepoPacked ::+ forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> Verbosity -> UseCache+ -> UMask+ -> CloneKind+ -> IO ()+copyCompleteRepoPacked r verb useCache umask cloneKind =+ ( copyCompleteRepoPacked2 r verb useCache cloneKind+ `catchall` do putVerbose verb $ text "Problem while copying patches pack, copying normally."+ copyCompleteRepoNotPacked r verb useCache umask cloneKind )++copyCompleteRepoPacked2 ::+ forall p wR wU wT. (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> Verbosity -> UseCache+ -> CloneKind+ -> IO ()+copyCompleteRepoPacked2 fromRepo@(Repo fromDir _ _ fromCache) verb useCache cloneKind = do+ Repo toDir toFormat toPristine toCache <- identifyRepositoryFor fromRepo useCache "."+ toCache2 <- unionRemoteCaches toCache fromCache fromDir+ let toRepo :: Repository p wR wU wR -- In empty repo, t(entative) = r(ecorded)+ toRepo = Repo toDir toFormat toPristine toCache2+ Repo _ _ _ toCache3 <- identifyRepositoryFor toRepo useCache "."+ us <- readRepo toRepo -- get old patches- unless isLazy $ (do+ let cleanup = putInfo verb $ text "Using lazy repository."+ allowCtrlC cloneKind cleanup $ do cleanDir "patches"- putInfo opts $ text "Copying patches, to get lazy repository hit ctrl-C..."+ putVerbose verb $ text "Using patches pack." unpackPatches toCache3 (mapFL hashedPatchFileName $ newset2FL us) .- Tar.read . decompress =<< fetchFileLazyPS (fromPacksDir ++- "patches.tar.gz") Uncachable- ) `catchInterrupt` (putInfo opts $ text "Using lazy repository.")+ Tar.read . decompress =<< fetchFileLazyPS (fromDir ++ packsDir ++ "patches.tar.gz") Uncachable+ pi <- doesPatchIndexExist toDir+ when pi $ createPIWithInterrupt toRepo where cleanDir d = mapM_ (\x -> removeFile $ darcsdir </> d </> x) . filter (\x -> head x /= '.') =<< getDirectoryContents (darcsdir </> d) +allowCtrlC :: CloneKind -> IO () -> IO () -> IO ()+allowCtrlC CompleteClone _ action = action+allowCtrlC _ cleanup action = action `catchInterrupt` cleanup++copyRepoOldFashioned :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> Verbosity -> UseCache+ -> UMask+ -> WithWorkingDir+ -> IO ()+copyRepoOldFashioned fromrepository verb useCache umask withWorkingDir = do+ toRepo@(Repo _ _ _ toCache) <- identifyRepository useCache "."+ let (_dummy :: Repository p wR wU wT) = toRepo --The witnesses are wrong, but cannot escape+ -- copy all patches from remote+ HashedRepo.revertTentativeChanges+ patches <- readRepo fromrepository+ let k = "Copying patch"+ beginTedious k+ tediousSize k (lengthRL $ newset2RL patches)+ let patches' = progressPatchSet k patches+ HashedRepo.writeTentativeInventory toCache GzipCompression patches'+ endTedious k+ HashedRepo.finalizeTentativeChanges toRepo GzipCompression+ -- apply all patches into current hashed repository+ debugMessage "Grabbing lock in new repository..."+ withRepoLock NoDryRun useCache YesUpdateWorking umask+ $ RepoJob $ \torepository -> do+ local_patches <- readRepo torepository+ replacePristine torepository emptyTree+ let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches+ sequence_ $ mapFL applyToTentativePristine $ bunchFL 100 patchesToApply+ finalizeRepositoryChanges torepository YesUpdateWorking GzipCompression+ putVerbose verb $ text "Writing pristine and working directory contents..."+ createPristineDirectoryTree torepository "." withWorkingDir+ withControlMVar :: (MVar () -> IO ()) -> IO () withControlMVar f = do mv <- newMVar ()@@ -302,42 +627,26 @@ forkWithControlMVar :: MVar () -> IO () -> IO () forkWithControlMVar mv f = do takeMVar mv- _ <- forkIO $ flip finally (putMVar mv ()) f+ _ <- forkIO $ finally f (putMVar mv ()) return () removeMetaFiles :: IO () 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@@ -362,14 +671,16 @@ BL.writeFile x' y renameFile x' z writeFile' (Just ca) z y = do- let x' = joinPath . tail $ splitPath z -- drop darcsdir- ex <- doesFileExist $ ca </> x'+ let fileFullPath = case splitPath z of+ _:hDir:hFile:_ -> joinPath [ca, hDir, bucketFolder hFile, hFile]+ _ -> fail "Unexpected file path"+ ex <- doesFileExist fileFullPath if ex- then createLink' (ca </> x') z- else withTemp $ \x'' -> do- BL.writeFile x'' y- createLink' x'' $ ca </> x'- renameFile x'' z+ then createLink' fileFullPath z+ else withTemp $ \x'' -> do+ BL.writeFile x'' y+ createLink' x'' fileFullPath+ renameFile x'' z createLink' z y = do createDirectoryIfMissing True $ takeDirectory y createLink z y `catchall` return ()@@ -380,7 +691,6 @@ when ex . forkWithControlMVar mv $ fetchFilesUsingCache ca HashedPristineDir . lines =<< readFile (darcsdir </> "meta-filelist-pristine")- return () patchesMetaHandler :: Cache -> [String] -> MVar () -> IO () patchesMetaHandler ca ps mv = do@@ -389,18 +699,17 @@ forkWithControlMVar mv $ fetchFilesUsingCache ca HashedPristineDir . lines =<< readFile (darcsdir </> "meta-filelist-inventories") forkWithControlMVar mv $ fetchFilesUsingCache ca HashedPatchesDir ps- return () cacheDir :: Cache -> Maybe String cacheDir (Ca cs) = listToMaybe . catMaybes .flip map cs $ \x -> case x of Cache Directory Writable x' -> Just x' _ -> Nothing -hashedPatchFileName :: PatchInfoAnd p C(a b) -> String+hashedPatchFileName :: PatchInfoAnd p wA wB -> String hashedPatchFileName x = case extractHash x of Left _ -> fail "unexpected unhashed patch" Right h -> h- + -- | fetchFilesUsingCache is similar to mapM fetchFileUsingCache, exepts -- it stops execution if file it's going to fetch already exists. fetchFilesUsingCache :: Cache -> HashedDir -> [FilePath] -> IO ()@@ -413,88 +722,110 @@ else do debugMessage $ "Cache thread: GET " ++ (darcsdir </> hashedDir d </> f)--- Warning: A do-notation statement discarded a result of type (String, BS.ByteString). _ <- fetchFileUsingCache c d f fetchFilesUsingCache c d fs -- | writePatchSet is like patchSetToRepository, except that it doesn't -- touch the working directory or pristine cache.-writePatchSet :: (RepoPatch p, ApplyState p ~ Tree) => PatchSet p C(Origin x) -> [DarcsFlag] -> IO (Repository p C(r u t))-writePatchSet patchset opts = do- maybeRepo <- maybeIdentifyRepository opts "."- let repo@(Repo _ _ _ (DarcsRepository _ c)) =+writePatchSet :: (RepoPatch p, ApplyState p ~ Tree)+ => PatchSet p Origin wX+ -> UseCache+ -> IO (Repository p wR wU wT)+writePatchSet patchset useCache = do+ maybeRepo <- maybeIdentifyRepository useCache "."+ let repo@(Repo _ _ _ c) = case maybeRepo of GoodRepository r -> r BadRepository e -> bug ("Current directory is a bad repository in writePatchSet: " ++ e) NonRepository e -> bug ("Current directory not a repository in writePatchSet: " ++ e) debugMessage "Writing inventory"- HashedRepo.writeTentativeInventory c (compression opts) patchset- HashedRepo.finalizeTentativeChanges repo (compression opts)+ HashedRepo.writeTentativeInventory c GzipCompression patchset+ HashedRepo.finalizeTentativeChanges repo GzipCompression return repo --- | patchSetToRepository takes a patch set, and writes a new repository in the current directory--- that contains all the patches in the patch set. This function is used when 'darcs get'ing a--- repository with the --to-match flag and the new repository is not in hashed format.--- This function does not (yet) work for hashed repositories. If the passed @DarcsFlag@s tell--- darcs to create a hashed repository, this function will call @error@.+-- | patchSetToRepository takes a patch set, and writes a new repository+-- in the current directory that contains all the patches in the patch+-- set. This function is used when 'darcs get'ing a repository with+-- the --to-match flag. patchSetToRepository :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r1 u1 r1) -> PatchSet p C(Origin x)- -> [DarcsFlag] -> IO (Repository p C(r u t))-patchSetToRepository (Repo fromrepo _ rf _) patchset opts = do+ => Repository p wR1 wU1 wR1+ -> PatchSet p Origin wX+ -> UseCache -> RemoteDarcs+ -> IO ()+patchSetToRepository (Repo fromrepo rf _ _) patchset useCache remoteDarcs = do when (formatHas HashedInventory rf) $ -- set up sources and all that- do writeFile "_darcs/tentative_pristine" "" -- this is hokey- repox <- writePatchSet patchset opts- HashedRepo.copyRepo repox (remoteDarcs opts) fromrepo- repo <- writePatchSet patchset opts- readRepo repo >>= (applyPatches . newset2FL)+ do writeFile (darcsdir </> "tentative_pristine") "" -- this is hokey+ repox <- writePatchSet patchset useCache+ HashedRepo.copyHashedInventory repox remoteDarcs fromrepo+ HashedRepo.copySources repox fromrepo+ repo <- writePatchSet patchset useCache+ readRepo repo >>= (runDefault . applyPatches . newset2FL) debugMessage "Writing the pristine" pristineFromWorking repo- return repo -checkUnrelatedRepos :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> PatchSet p C(start y)+checkUnrelatedRepos :: RepoPatch p+ => Bool+ -> PatchSet p wStart wX+ -> PatchSet p wStart wY -> IO ()-checkUnrelatedRepos opts _ _ | AllowUnrelatedRepos `elem` opts = return ()-checkUnrelatedRepos _ us them =- if areUnrelatedRepos us them- then do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?"+checkUnrelatedRepos allowUnrelatedRepos us them =+ when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $+ do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?" unless confirmed $ do putStrLn "Cancelled."- exitWith ExitSuccess- else return ()+ exitSuccess --- | Unless a flag has been given in the first argument that tells darcs not to do so (--lazy,--- or --partial), this function fetches all patches that the given repository has--- with fetchFileUsingCache. This is used as a helper in copyRepository.-fetchPatchesIfNecessary :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository p C(r u t) -> IO ()-fetchPatchesIfNecessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) =- unless (Lazy `elem` opts) $- do unless (Complete `elem` opts) $- putInfo opts $ text "Copying patches, to get lazy repository hit ctrl-C..."- r <- readRepo torepository- pipelineLength <- maxPipelineLength- let patches = newset2RL r- ppatches = progressRLShowTags "Copying patches" patches- (first, other) = splitAt (pipelineLength - 1) $ tail $ hashes patches- speculate | pipelineLength > 1 = [] : first : map (:[]) other- | otherwise = []- mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat [])- where hashes :: FORALL(x y) RL (PatchInfoAnd p) C(x y) -> [String]- hashes = catMaybes . mapRL ((either (const Nothing) Just) . extractHash)+-- | This function fetches all patches that the given repository has+-- with fetchFileUsingCache, unless --lazy is passed.+fetchPatchesIfNecessary :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> IO ()+fetchPatchesIfNecessary torepository@(Repo _ _ _ c) =+ do r <- readRepo torepository+ pipelineLength <- maxPipelineLength+ let patches = newset2RL r+ ppatches = progressRLShowTags "Copying patches" patches+ (first, other) = splitAt (pipelineLength - 1) $ tail $ hashes patches+ speculate | pipelineLength > 1 = [] : first : map (:[]) other+ | otherwise = []+ mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat [])+ where hashes :: forall wX wY . RL (PatchInfoAnd p) wX wY -> [String]+ hashes = catMaybes . mapRL (either (const Nothing) Just . extractHash) fetchAndSpeculate :: (String, [String]) -> IO () fetchAndSpeculate (f, ss) = do--- Warning: A do-notation statement discarded a result of type (String, BS.ByteString). _ <- fetchFileUsingCache c HashedPatchesDir f mapM_ (speculateFileUsingCache c HashedPatchesDir) ss +-- | Add an FL of patches started from the pending state to the pending patch.+-- TODO: add witnesses for pending so we can make the types precise: currently+-- the passed patch can be applied in any context, not just after pending.+addPendingDiffToPending :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> UpdateWorking+ -> FreeLeft (FL (PrimOf p)) -> IO ()+addPendingDiffToPending _ NoUpdateWorking _ = return ()+addPendingDiffToPending repo@(Repo{}) uw@YesUpdateWorking newP = do+ (toPend :> _) <-+ readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing+ invalidateIndex repo+ case unFreeLeft newP of+ (Sealed p) -> makeNewPending repo uw $ toPend +>+ p++-- | Add a FL of patches starting from the working state to the pending patch,+-- including as much extra context as is necessary (context meaning+-- dependencies), by commuting the patches to be added past as much of the+-- changes between pending and working as is possible, and including anything+-- that doesn't commute, and the patch itself in the new pending patch. addToPending :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> FL (PrimOf p) C(u y) -> IO ()-addToPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()-addToPending repo@(Repo{}) p =- do pend <- unrecordedChanges (UseIndex, ScanKnown) repo Nothing- invalidateIndex repo- makeNewPending repo (pend +>+ p)+ => Repository p wR wU wT -> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()+addToPending _ NoUpdateWorking _ = return ()+addToPending repo@(Repo{}) uw@YesUpdateWorking p = do+ (toPend :> toUnrec) <- readPendingAndWorking (UseIndex, ScanKnown, MyersDiff) repo Nothing+ invalidateIndex repo+ case genCommuteWhatWeCanRL commuteFL (reverseFL toUnrec :> p) of+ (toP' :> p' :> _excessUnrec) ->+ makeNewPending repo uw $ toPend +>+ reverseRL toP' +>+ p' -- | Replace the existing pristine with a new one (loaded up in a Tree object).-replacePristine :: Repository p C(r u t) -> Tree IO -> IO ()+replacePristine :: Repository p wR wU wT -> Tree IO -> IO () replacePristine (Repo r _ _ _) = writePristine r writePristine :: FilePath -> Tree IO -> IO ()@@ -505,7 +836,33 @@ root <- writeDarcsHashed tree' $ darcsdir </> "pristine.hashed" writeDocBinFile t $ pris2inv (BS.unpack $ encodeBase16 root) i -pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO ()+pristineFromWorking :: RepoPatch p => Repository p wR wU wT -> IO () pristineFromWorking repo@(Repo dir _ _ _) = withCurrentDirectory dir $ readWorking >>= replacePristine repo +-- | Get a list of all files and directories in the working copy, including+-- boring files if necessary+listFiles :: Bool -> IO [String]+listFiles takeBoring =+ do+ nonboring <- considered emptyTree+ working <- expand =<< applyTreeFilter nonboring <$> readPlainTree "."+ return $ map (anchorPath "" . fst) $ list working+ where+ considered = if takeBoring+ then const (return restrictDarcsdir)+ else restrictBoring++-- | 'listUnregisteredFiles' returns the list of all non-boring unregistered+-- files in the repository.+listUnregisteredFiles :: Bool -> IO [String]+listUnregisteredFiles includeBoring =+ do unregd <- listFiles includeBoring+ regd <- listRegisteredFiles+ return $ unregd \\ regd -- (inefficient)++-- | 'listRegisteredFiles' returns the list of all registered files in the repository.+listRegisteredFiles :: IO [String]+listRegisteredFiles =+ do recorded <- expand =<< withRepository YesUseCache (RepoJob readRecordedAndPending)+ return $ map (anchorPath "" . fst) $ list recorded
src/Darcs/Repository/ApplyPatches.hs view
@@ -15,25 +15,161 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} -#include "gadts.h"+module Darcs.Repository.ApplyPatches+ ( applyPatches+ , runTolerantly+ , runSilently+ , DefaultIO, runDefault+ ) where -module Darcs.Repository.ApplyPatches ( applyPatches ) where+import Prelude hiding ( catch )+import Control.Exception ( catch, SomeException, IOException )+import Data.Char ( toLower )+import Data.List ( isSuffixOf )+import System.IO ( stderr )+import System.IO.Error ( isDoesNotExistError, isPermissionError )+import Control.Monad ( unless, mplus )+import Control.Applicative (Applicative)+import System.Directory ( createDirectory,+ removeDirectory, removeFile,+ renameFile, renameDirectory,+ doesDirectoryExist, doesFileExist+ ) -import Darcs.Patch.ApplyMonad( ApplyMonad )-import Darcs.MonadProgress ( MonadProgress, ProgressAction(..), runProgressActions)-import Darcs.Patch ( Patchy, apply )-import Darcs.IO () -- for ApplyMonad IO-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )-import Darcs.Patch.Info ( humanFriendly )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Witnesses.Ordered ( FL(..), mapFL )-import Printer ( text, ($$) )+import Darcs.Patch.ApplyMonad( ApplyMonad(..) )+import Darcs.Patch.ApplyPatches ( applyPatches )+import Darcs.Patch.MonadProgress ( MonadProgress(..), ProgressAction(..) )+import Darcs.Repository.Prefs( changePrefval )+import Darcs.Repository.Lock ( writeAtomicFilePS ) -applyPatches :: (MonadProgress m, ApplyMonad m (ApplyState p), Patchy p) => FL (PatchInfoAnd p) C(x y) -> m ()-applyPatches ps = runProgressActions "Applying patch" (mapFL doApply ps)- where doApply hp =- ProgressAction { paAction = apply (hopefully hp)- , paMessage = humanFriendly (info hp)- , paOnError = text "Unapplicable patch:" $$ humanFriendly (info hp) }+import Darcs.Util.Exception ( prettyException )+import Darcs.Util.Progress ( beginTedious, endTedious, tediousSize, finishedOneIO )+import Darcs.Util.Printer ( hPutDocLn, RenderMode(..) )+import Darcs.Util.Printer.Color ( showDoc )+import Darcs.Repository.External ( backupByCopying, backupByRenaming )+import Darcs.Util.Path ( FileName, fn2fp )+import qualified Data.ByteString as B (empty, null, readFile)++import Storage.Hashed.Tree( Tree )++newtype DefaultIO a = DefaultIO { runDefaultIO :: IO a }+ deriving (Functor, Applicative, Monad)++instance MonadProgress DefaultIO where+ runProgressActions _ [] = return ()+ runProgressActions what items = DefaultIO $ do+ do beginTedious what+ tediousSize what (length items)+ mapM_ go items+ endTedious what+ where go item =+ do finishedOneIO what (showDoc Encode $ paMessage item)+ runDefaultIO (paAction item) `catch` \e ->+ do hPutDocLn Encode stderr $ paOnError item+ ioError e++instance ApplyMonad DefaultIO Tree where+ type ApplyMonadBase DefaultIO = IO+ mDoesDirectoryExist = DefaultIO . doesDirectoryExist . fn2fp+ mChangePref a b c = DefaultIO $ changePrefval a b c+ mModifyFilePS f j = DefaultIO $ B.readFile (fn2fp f) >>= runDefaultIO . j >>= writeAtomicFilePS (fn2fp f)+ mCreateDirectory = DefaultIO . createDirectory . fn2fp+ mCreateFile f = DefaultIO $+ do exf <- doesFileExist (fn2fp f)+ if exf then fail $ "File '"++fn2fp f++"' already exists!"+ else do exd <- doesDirectoryExist $ fn2fp f+ if exd then fail $ "File '"++fn2fp f++"' already exists!"+ else writeAtomicFilePS (fn2fp f) B.empty+ mRemoveFile f = DefaultIO $+ do let fp = fn2fp f+ x <- B.readFile fp+ unless (B.null x) $+ fail $ "Cannot remove non-empty file "++fp+ removeFile fp+ mRemoveDirectory = DefaultIO . removeDirectory . fn2fp+ mRename a b = DefaultIO $+ catch+ (renameDirectory x y `mplus` renameFile x y)+ -- We need to catch does not exist errors, since older+ -- versions of darcs allowed users to rename nonexistent+ -- files. :(+ (\e -> unless (isDoesNotExistError e) $ ioError e)+ where x = fn2fp a+ y = fn2fp b++class (Functor m, Monad m) => TolerantMonad m where+ warning :: IO () -> m ()+ runIO :: m a -> IO a+ runTM :: IO a -> m a++newtype TolerantIO a = TIO { runTIO :: IO a }+ deriving (Functor, Applicative, Monad)++instance TolerantMonad TolerantIO where+ warning io = TIO $ io `catch` \e -> putStrLn $ "Warning: " ++ prettyException e+ runIO (TIO io) = io+ runTM = TIO++newtype SilentIO a = SIO { runSIO :: IO a }+ deriving (Functor, Applicative, Monad)++instance TolerantMonad SilentIO where+ warning io = SIO $ io `catch` \(_ :: SomeException) -> return ()+ runIO (SIO io) = io+ runTM = SIO++newtype TolerantWrapper m a = TolerantWrapper { runTolerantWrapper :: m a }+ deriving (Functor, Applicative, Monad, TolerantMonad)++-- | Apply patches, emitting warnings if there are any IO errors+runTolerantly :: TolerantWrapper TolerantIO a -> IO a+runTolerantly = runTIO . runTolerantWrapper++-- | Apply patches, ignoring all errors+runSilently :: TolerantWrapper SilentIO a -> IO a+runSilently = runSIO . runTolerantWrapper++-- | The default mode of applying patches: fail if the directory is not+-- as we expect+runDefault :: DefaultIO a -> IO a+runDefault = runDefaultIO++instance TolerantMonad m => ApplyMonad (TolerantWrapper m) Tree where+ type ApplyMonadBase (TolerantWrapper m) = IO+ mDoesDirectoryExist d = runTM $ runDefaultIO $ mDoesDirectoryExist d+ mReadFilePS f = runTM $ runDefaultIO $ mReadFilePS f+ mChangePref a b c = warning $ runDefaultIO $ mChangePref a b c+ mModifyFilePS f j = warning $ runDefaultIO $ mModifyFilePS f (DefaultIO . runIO . j)+ mCreateFile f = warning $ backup f >> runDefaultIO (mCreateFile f)+ mCreateDirectory d = warning $ backup d >> runDefaultIO (mCreateDirectory d)+ mRemoveFile f = warning $ runDefaultIO (mRemoveFile f)+ mRemoveDirectory d = warning $ catch+ (runDefaultIO (mRemoveDirectory d))+ (\(e :: IOException) ->+ if "(Directory not empty)" `isSuffixOf` show e+ then ioError $ userError $+ "Not deleting " ++ fn2fp d ++ " because it is not empty."+ else ioError $ userError $+ "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)+ mRename a b = warning $ catch+ (let do_backup = if map toLower x == map toLower y+ then backupByCopying (fn2fp b) -- avoid making the original vanish+ else backupByRenaming (fn2fp b)+ in do_backup >> runDefaultIO (mRename a b))+ (\e -> case () of+ _ | isPermissionError e -> ioError $ userError $+ couldNotRename ++ "."+ | isDoesNotExistError e -> ioError $ userError $+ couldNotRename ++ " because " ++ x ++ " does not exist."+ | otherwise -> ioError e+ )+ where+ x = fn2fp a+ y = fn2fp b+ couldNotRename = "Could not rename " ++ x ++ " to " ++ y++backup :: FileName -> IO ()+backup f = backupByRenaming (fn2fp f)
src/Darcs/Repository/Cache.hs view
@@ -1,82 +1,112 @@ {-# LANGUAGE CPP #-} -#include "gadts.h"--module Darcs.Repository.Cache (- cacheHash, okayHash, takeHash,- Cache(..), CacheType(..), CacheLoc(..), WritableOrNot(..),- HashedDir(..), hashedDir,- unionCaches, unionRemoteCaches, cleanCaches, cleanCachesWithHint,- fetchFileUsingCache, speculateFileUsingCache, speculateFilesUsingCache,- writeFileUsingCache,- peekInCache,- repo2cache,- writable, isthisrepo, hashedFilePath, allHashedDirs, compareByLocality,- reportBadSources- ) where+module Darcs.Repository.Cache+ ( cacheHash+ , okayHash+ , takeHash+ , Cache(..)+ , CacheType(..)+ , CacheLoc(..)+ , WritableOrNot(..)+ , HashedDir(..)+ , hashedDir+ , bucketFolder+ , unionCaches+ , unionRemoteCaches+ , cleanCaches+ , cleanCachesWithHint+ , fetchFileUsingCache+ , speculateFileUsingCache+ , speculateFilesUsingCache+ , writeFileUsingCache+ , peekInCache+ , repo2cache+ , writable+ , isThisRepo+ , hashedFilePath+ , allHashedDirs+ , compareByLocality+ , reportBadSources+ ) where import Control.Monad ( liftM, when, guard, unless, filterM, forM_, mplus )+import qualified Data.ByteString as B (length, drop, ByteString )+import qualified Data.ByteString.Char8 as BC (unpack) import Data.List ( nub, intercalate )-import Data.Maybe ( catMaybes, listToMaybe, isJust, fromMaybe )-import System.Directory ( removeFile, doesFileExist, doesDirectoryExist,- getDirectoryContents, getPermissions )+import Data.Maybe ( catMaybes, listToMaybe, fromMaybe )+import System.FilePath.Posix ( (</>), joinPath, dropFileName )+import System.Directory ( createDirectoryIfMissing, removeFile, doesFileExist,+ doesDirectoryExist, getDirectoryContents,+ getPermissions ) import qualified System.Directory as SD ( writable )-import System.Posix.Files ( linkCount, getSymbolicLinkStatus ) import System.IO ( hPutStrLn, stderr )--import Crypt.SHA256 ( sha256sum )--import ByteStringUtils ( gzWriteFilePS, linesPS )-import qualified Data.ByteString as B (length, drop, ByteString )-import qualified Data.ByteString.Char8 as BC (unpack)+import System.Posix.Files ( createLink, linkCount, getSymbolicLinkStatus ) -import SHA1 ( sha1PS )-import System.Posix.Files ( createLink )-import System.FilePath.Posix ( (</>) )-import System.Directory ( createDirectoryIfMissing )+import Darcs.Util.ByteString ( gzWriteFilePS, linesPS )+import Darcs.Util.Global ( darcsdir, addBadSource, isBadSource, addReachableSource,+ isReachableSource, getBadSourcesList )+import Darcs.Repository.External ( gzFetchFilePS, fetchFilePS,+ speculateFileOrUrl, copyFileOrUrl,+ Cachable( Cachable ) )+import Darcs.Repository.Flags ( Compression(..), RemoteDarcs(..) )+import Darcs.Repository.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS,+ withTemp )+import Darcs.Util.SignalHandler ( catchNonSignal )+import Darcs.Util.URL ( isValidLocalPath, isHttpUrl, isSshUrl )+import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Crypt.SHA1 ( sha1PS )+import Darcs.Util.Crypt.SHA256 ( sha256sum )+import Darcs.Util.English ( englishNum, Noun(..), Pronoun(..) )+import Darcs.Util.Exception ( catchall )+import Darcs.Util.Progress ( progressList, debugMessage, debugFail )+import qualified Darcs.Util.Download as Download ( ConnectionError(..) ) -import Darcs.External ( gzFetchFilePS, fetchFilePS, speculateFileOrUrl, copyFileOrUrl,- Cachable( Cachable ) )-import Darcs.Flags ( Compression( .. ), RemoteDarcs(..) )-import Darcs.Global ( darcsdir, addBadSource, isBadSource,- addReachableSource, isReachableSource,- getBadSourcesList )-import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS, withTemp )-import Progress ( progressList, debugMessage, debugFail )-import English ( englishNum, Noun(..), Pronoun(..) )-import Darcs.URL ( isFile, isHttpUrl, isSshUrl )-import Darcs.Utils ( withCurrentDirectory, catchall )-import Darcs.SignalHandler ( catchNonSignal )-import qualified URL ( ConnectionError(..) )+data HashedDir = HashedPristineDir+ | HashedPatchesDir+ | HashedInventoriesDir -data HashedDir = HashedPristineDir | HashedPatchesDir | HashedInventoriesDir hashedDir :: HashedDir -> String hashedDir HashedPristineDir = "pristine.hashed" hashedDir HashedPatchesDir = "patches" hashedDir HashedInventoriesDir = "inventories" allHashedDirs :: [HashedDir]-allHashedDirs = [HashedPristineDir, HashedPatchesDir, HashedInventoriesDir]+allHashedDirs = [ HashedPristineDir+ , HashedPatchesDir+ , HashedInventoriesDir+ ] -data WritableOrNot = Writable | NotWritable deriving ( Show )-data CacheType = Repo | Directory deriving ( Eq, Show )-data CacheLoc = Cache { cacheType:: !CacheType, cacheWritable:: !WritableOrNot, cacheSource:: !String }-newtype Cache = Ca [CacheLoc] -- abstract type for hiding cache+data WritableOrNot = Writable+ | NotWritable+ deriving ( Eq, Show ) +data CacheType = Repo+ | Directory+ deriving ( Eq, Show )++data CacheLoc = Cache+ { cacheType :: !CacheType+ , cacheWritable :: !WritableOrNot+ , cacheSource :: !String+ }++-- | Cache is an abstract type for hiding the underlying cache locations+newtype Cache = Ca [CacheLoc]+ instance Eq CacheLoc where- (Cache Repo _ a) == (Cache Repo _ b) = a == b- (Cache Directory _ a) == (Cache Directory _ b) = a == b- _ == _ = False+ (Cache aTy _ aSrc) == (Cache bTy _ bSrc) = aTy == bTy && aSrc == bSrc+ instance Show CacheLoc where show (Cache Repo Writable a) = "thisrepo:" ++ a show (Cache Repo NotWritable a) = "repo:" ++ a show (Cache Directory Writable a) = "cache:" ++ a show (Cache Directory NotWritable a) = "readonly:" ++ a+ instance Show Cache where show (Ca cs) = unlines $ map show cs unionCaches :: Cache -> Cache -> Cache-unionCaches (Ca a) (Ca b) = Ca (nub (a++b))+unionCaches (Ca a) (Ca b) = Ca (nub (a ++ b)) -- | unionRemoteCaches merges caches. It tries to do better than just blindly -- copying remote cache entries:@@ -91,301 +121,391 @@ -- as writable cache, if it exists but is not writable it is added as -- read-only cache. ----- This approach should save us from bogus cache entries. One case it does not--- work very well is when you fetch from partial repository over network.+-- This approach should save us from bogus cache entries. One case it does+-- not work very well is when you fetch from partial repository over network. -- Hopefully this is not a common case.-unionRemoteCaches :: Cache -> Cache -> String -> IO (Cache)+unionRemoteCaches :: Cache -> Cache -> String -> IO Cache unionRemoteCaches local (Ca remote) repourl- | isFile repourl = do f <- filtered- return $ local `unionCaches` Ca f+ | isValidLocalPath repourl = do+ f <- filtered+ return $ local `unionCaches` Ca f | otherwise = return local- where filtered = mapM (\x -> fn x `catchall` return Nothing) remote >>=- return . catMaybes- fn :: CacheLoc -> IO (Maybe CacheLoc)- fn (Cache Repo Writable _) = return Nothing- fn c@(Cache t _ url)- | isFile url = do- ex <- doesDirectoryExist url- if ex then do p <- getPermissions url- return $ Just $- if writable c && SD.writable p- then c else Cache t NotWritable url- else return Nothing- | otherwise = return $ Just c+ where+ filtered = catMaybes `fmap`+ mapM (\x -> mbGetRemoteCacheLoc x `catchall` return Nothing) remote+ mbGetRemoteCacheLoc :: CacheLoc -> IO (Maybe CacheLoc)+ mbGetRemoteCacheLoc (Cache Repo Writable _) = return Nothing+ mbGetRemoteCacheLoc c@(Cache t _ url)+ | isValidLocalPath url = do+ ex <- doesDirectoryExist url+ if ex+ then do+ p <- getPermissions url+ return $ Just $ if writable c && SD.writable p+ then c+ else Cache t NotWritable url+ else return Nothing+ | otherwise = return $ Just c -- | Compares two caches, a remote cache is greater than a local one. -- The order of the comparison is given by: local < http < ssh compareByLocality :: CacheLoc -> CacheLoc -> Ordering-compareByLocality (Cache _ _ x) (Cache _ _ y)- | isLocal x && isRemote y = LT- | isRemote x && isLocal y = GT- | isHttpUrl x && isSshUrl y = LT- | isSshUrl x && isHttpUrl y = GT- | otherwise = EQ- where- isRemote r= isHttpUrl r || isSshUrl r- isLocal = isFile+compareByLocality (Cache _ w x) (Cache _ z y)+ | isValidLocalPath x && isRemote y = LT+ | isRemote x && isValidLocalPath y = GT+ | isHttpUrl x && isSshUrl y = LT+ | isSshUrl x && isHttpUrl y = GT+ | isValidLocalPath x && isWritable w+ && isValidLocalPath y && isNotWritable z = LT+ | otherwise = EQ+ where+ isRemote r = isHttpUrl r || isSshUrl r+ isWritable = (==) Writable+ isNotWritable = (==) NotWritable repo2cache :: String -> Cache repo2cache r = Ca [Cache Repo NotWritable r] -- | 'cacheHash' computes the cache hash (i.e. filename) of a packed string. cacheHash :: B.ByteString -> String-cacheHash ps = case show (B.length ps) of- x | l > 10 -> sha256sum ps- | otherwise -> replicate (10-l) '0' ++ x ++'-':sha256sum ps- where l = length x+cacheHash ps = if sizeStrLen > 10+ then shaOfPs+ else replicate (10 - sizeStrLen) '0' ++ sizeStr+ ++ '-' : shaOfPs+ where+ sizeStr = show $ B.length ps+ sizeStrLen = length sizeStr+ shaOfPs = sha256sum ps okayHash :: String -> Bool-okayHash s = length s == 40 || length s == 64 || length s == 75+okayHash s = length s `elem` [40, 64, 75] takeHash :: B.ByteString -> Maybe (String, B.ByteString)-takeHash ps = do h <- listToMaybe $ linesPS ps- let v = BC.unpack h- guard $ okayHash v- Just (v, B.drop (B.length h) ps)+takeHash ps = do+ h <- listToMaybe $ linesPS ps+ let v = BC.unpack h+ guard $ okayHash v+ return (v, B.drop (B.length h) ps) checkHash :: String -> B.ByteString -> Bool-checkHash h s | length h == 40 = sha1PS s == h- | length h == 64 = sha256sum s == h- | length h == 75 = B.length s == read (take 10 h) && sha256sum s == drop 11 h- | otherwise = False+checkHash h s+ | length h == 40 = (show $ sha1PS s) == h+ | length h == 64 = sha256sum s == h+ | length h == 75 =+ B.length s == read (take 10 h) && sha256sum s == drop 11 h+ | otherwise = False --- |@fetchFileUsingCache cache dir hash@ receives a list of caches--- @cache@, the directory for which that file belongs @dir@ and the--- @hash@ of the file to fetch. It tries to fetch the file from one--- of the sources, trying them in order one by one. If the file--- cannot be fetched from any of the sources, this operation fails.-fetchFileUsingCache :: Cache -> HashedDir -> String -> IO (String, B.ByteString)+-- |@fetchFileUsingCache cache dir hash@ receives a list of caches @cache@, the+-- directory for which that file belongs @dir@ and the @hash@ of the file to+-- fetch. It tries to fetch the file from one of the sources, trying them in+-- order one by one. If the file cannot be fetched from any of the sources,+-- this operation fails.+fetchFileUsingCache :: Cache -> HashedDir -> String+ -> IO (String, B.ByteString) fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere writable :: CacheLoc -> Bool writable (Cache _ NotWritable _) = False writable (Cache _ Writable _) = True -isthisrepo :: CacheLoc -> Bool-isthisrepo (Cache Repo Writable _) = True-isthisrepo _ = False+isThisRepo :: CacheLoc -> Bool+isThisRepo (Cache Repo Writable _) = True+isThisRepo _ = False --- | @hashedFilePath cachelocation subdir hash@ returns the physical filename of--- hash @hash@ in the @subdir@ section of @cachelocation@.+bucketFolder :: String -> String+bucketFolder f = take 2 (cleanHash f)+ where+ cleanHash fileName = case dropWhile (/= '-') fileName of+ [] -> fileName+ s -> drop 1 s++-- | @hashedFilePath cachelocation subdir hash@ returns the physical filename+-- of hash @hash@ in the @subdir@ section of @cachelocation@. hashedFilePath :: CacheLoc -> HashedDir -> String -> String-hashedFilePath (Cache Directory _ d) s f = d ++ "/" ++ (hashedDir s) ++ "/" ++ f+hashedFilePath (Cache Directory _ d) s f =+ joinPath [d, hashedDir s, bucketFolder f, f] hashedFilePath (Cache Repo _ r) s f =- r ++ "/"++darcsdir++"/" ++ (hashedDir s) ++ "/" ++ f+ joinPath [r, darcsdir, hashedDir s, f] --- | @peekInCache cache subdir hash@ tells whether @cache@ and--- contains an object with hash @hash@ in a writable position.--- Florent: why do we want it to be in a writable position?+-- | @hashedFilePathReadOnly cachelocation subdir hash@ returns the physical filename+-- of hash @hash@ in the @subdir@ section of @cachelocation@.+-- If directory, assume it is non-bucketed cache (old cache location).+hashedFilePathReadOnly :: CacheLoc -> HashedDir -> String -> String+hashedFilePathReadOnly (Cache Directory _ d) s f =+ d ++ "/" ++ hashedDir s ++ "/" ++ f+hashedFilePathReadOnly (Cache Repo _ r) s f =+ r ++ "/" ++ darcsdir ++ "/" ++ hashedDir s ++ "/" ++ f++-- | @peekInCache cache subdir hash@ tells whether @cache@ and contains an+-- object with hash @hash@ in a writable position. Florent: why do we want it+-- to be in a writable position? peekInCache :: Cache -> HashedDir -> String -> IO Bool peekInCache (Ca cache) subdir f = cacheHasIt cache `catchall` return False- where cacheHasIt [] = return False- cacheHasIt (c:cs) | not $ writable c = cacheHasIt cs- | otherwise = do ex <- doesFileExist $ fn c- if ex then return True- else cacheHasIt cs- fn c = hashedFilePath c subdir f+ where+ cacheHasIt [] = return False+ cacheHasIt (c : cs)+ | not $ writable c = cacheHasIt cs+ | otherwise = do+ ex <- doesFileExist $ hashedFilePath c subdir f+ if ex then return True else cacheHasIt cs --- | @speculateFileUsingCache cache subdirectory name@ takes note that--- the file @name@ is likely to be useful soon: pipelined downloads--- will add it to the (low-priority) queue, for the rest it is a noop.+-- | @speculateFileUsingCache cache subdirectory name@ takes note that the file+-- @name@ is likely to be useful soon: pipelined downloads will add it to the+-- (low-priority) queue, for the rest it is a noop. speculateFileUsingCache :: Cache -> HashedDir -> String -> IO ()-speculateFileUsingCache c sd h = do debugMessage $ "Speculating on "++h- copyFileUsingCache OnlySpeculate c sd h+speculateFileUsingCache c sd h = do+ debugMessage $ "Speculating on " ++ h+ copyFileUsingCache OnlySpeculate c sd h -- | Note that the files are likely to be useful soon: pipelined downloads will -- add them to the (low-priority) queue, for the rest it is a noop. speculateFilesUsingCache :: Cache -> HashedDir -> [String] -> IO () speculateFilesUsingCache _ _ [] = return ()-speculateFilesUsingCache cache sd hs =- do --debugMessage $ "Thinking about speculating on "++unwords hs- hs' <- filterM (fmap not . peekInCache cache sd) hs- unless (null hs') $ do debugMessage $ "Speculating on "++unwords hs'- copyFilesUsingCache OnlySpeculate cache sd hs'+speculateFilesUsingCache cache sd hs = do+ debugMessage $ "Thinking about speculating on " ++ unwords hs+ hs' <- filterM (fmap not . peekInCache cache sd) hs+ unless (null hs') $ do+ debugMessage $ "Speculating on " ++ unwords hs'+ copyFilesUsingCache OnlySpeculate cache sd hs' -data OrOnlySpeculate = ActuallyCopy | OnlySpeculate deriving ( Eq )+data OrOnlySpeculate = ActuallyCopy+ | OnlySpeculate+ deriving ( Eq ) --- | @copyFileUsingCache oos cache subdir f@ copy or hardlinks the--- file @f@ to one of the caches in @cache@,usually the global cache.--- If a writable cache doesn't exist the function will fail.+-- | We hace a list of locations (@cache@) ordered from "closest/fastest"+-- (typically, the destination repo) to "farthest/slowest" (typically,+-- the source repo).+-- @copyFileUsingCache@ first checks whether given file @f@ is present+-- in some writeable location, if yes, do nothing. If no, it copies it+-- to the last writeable location, which would be the global cache+-- by default, or the destination repo if `--no-cache` is passed.+-- Function does nothing if there is no writeable location at all.+-- If the copy should occur between two locations of the same filesystem,+-- a hard link is actually made.+-- TODO document @oos@: what happens when we only speculate? copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> String -> IO ()-copyFileUsingCache oos (Ca cache) subdir f =- do debugMessage $ "I'm doing copyFileUsingCache on "++(hashedDir subdir)++"/"++f- Just stickItHere <- cacheLoc cache- createDirectoryIfMissing False (reverse $ dropWhile (/='/') $ reverse stickItHere)- filterBadSources cache >>= (flip sfuc) stickItHere- `catchall` return ()- where cacheLoc [] = return Nothing- cacheLoc (c:cs) | not $ writable c = cacheLoc cs- | otherwise =- do ex <- doesFileExist $ fn c- if ex then fail "Bug in darcs: This exception should be caught in speculateFileUsingCache"- else do othercache <- cacheLoc cs- return $ othercache `mplus` Just (fn c)- sfuc [] _ = return ()- sfuc (c:cs) out- | not (writable c) =- if oos == OnlySpeculate- then speculateFileOrUrl (fn c) out `catchNonSignal` (\e -> checkCacheReachability (show e) c)- else copyFileOrUrl DefaultRemoteDarcs (fn c) out Cachable `catchNonSignal` (\e -> checkCacheReachability (show e) c)- | otherwise = sfuc cs out- fn c = hashedFilePath c subdir f+copyFileUsingCache oos (Ca cache) subdir f = do+ debugMessage $+ "I'm doing copyFileUsingCache on " ++ hashedDir subdir ++ "/" ++ f+ Just stickItHere <- cacheLoc cache+ createDirectoryIfMissing True+ (reverse $ dropWhile (/= '/') $ reverse stickItHere)+ debugMessage $ "Will effectively do copyFileUsingCache to: " ++ show stickItHere+ filterBadSources cache >>= sfuc stickItHere+ `catchall`+ return ()+ where+ -- return last writeable cache/repo location for file.+ -- usually returns the global cache unless `--no-cache` is passed.+ cacheLoc [] = return Nothing+ cacheLoc (c : cs)+ | not $ writable c = cacheLoc cs+ | otherwise = do+ let attemptPath = hashedFilePath c subdir f+ ex <- doesFileExist attemptPath+ if ex+ then fail $ "File already present in writable location."+ else do+ othercache <- cacheLoc cs+ return $ othercache `mplus` Just attemptPath+ -- do the actual copy, or hard link, or put file in download queue+ sfuc _ [] = return ()+ sfuc out (c : cs)+ | not (writable c) =+ let cacheFile = hashedFilePathReadOnly c subdir f in+ if oos == OnlySpeculate+ then speculateFileOrUrl cacheFile out+ `catchNonSignal`+ \e -> checkCacheReachability (show e) c+ else do debugMessage $ "Copying from " ++ show cacheFile ++ " to " ++ show out+ copyFileOrUrl DefaultRemoteDarcs cacheFile out Cachable+ `catchNonSignal`+ (\e -> do checkCacheReachability (show e) c+ sfuc out cs) -- try another read-only location+ | otherwise = sfuc out cs -copyFilesUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> [String] -> IO ()+copyFilesUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> [String]+ -> IO () copyFilesUsingCache oos cache subdir hs = forM_ hs $ copyFileUsingCache oos cache subdir --data FromWhere = LocalOnly | Anywhere deriving ( Eq )+data FromWhere = LocalOnly+ | Anywhere+ deriving ( Eq ) --- | Checks if a given cache entry is reachable or not.--- It receives an error caught during execution and the cache entry.--- If the caches is not reachable it is blacklisted and not longer tried for--- the rest of the session. If it is reachable it is whitelisted and future errors with such--- cache get ignore.+-- | Checks if a given cache entry is reachable or not. It receives an error+-- caught during execution and the cache entry. If the caches is not reachable+-- it is blacklisted and not longer tried for the rest of the session. If it is+-- reachable it is whitelisted and future errors with such cache get ignore. -- To determine reachability:--- * For a local cache, if the given source doesn't exist anymore, it is blacklisted.+-- * For a local cache, if the given source doesn't exist anymore, it is+-- blacklisted. -- * For remote sources if the error is timeout, it is blacklisted, if not,--- it checks if _darcs/hashed_inventory exist, if it does, the entry is whitelisted, if--- it doesn't, it is blacklisted.+-- it checks if _darcs/hashed_inventory exist, if it does, the entry is+-- whitelisted, if it doesn't, it is blacklisted. checkCacheReachability :: String -> CacheLoc -> IO () checkCacheReachability e cache- | isFile source = do- reachable <- isReachableSource- unless (reachable source) $ do- exist <- doesDirectoryExist source- if exist- then- addReachableSource source- else- addBadSource source- | isHttpUrl source = do- reachable <- isReachableSource- unless (reachable source) $ do- let string = case dropWhile (/='(') e of- (_:xs) -> fst (break (==')') xs)- _ -> e- let cerror = case reads string ::[(URL.ConnectionError,String)] of- [(ce,_)] -> Just ce- _ -> Nothing- if isJust cerror- then addBadSource source- else checkFileReachability+ | isValidLocalPath source = doUnreachableCheck $+ checkFileReachability (doesDirectoryExist source)+ | isHttpUrl source =+ doUnreachableCheck $ do+ let err = case dropWhile (/= '(') e of+ (_ : xs) -> fst (break (==')') xs)+ _ -> e+ case reads err :: [(Download.ConnectionError, String)] of+ [(_, _)] -> addBadSource source+ _ -> checkFileReachability+ (checkHashedInventoryReachability cache)+ | isSshUrl source = doUnreachableCheck $+ checkFileReachability (checkHashedInventoryReachability cache)+ | otherwise = fail $ "unknown transport protocol for: " ++ source+ where+ source = cacheSource cache - | isSshUrl source = do- reachable <- isReachableSource- unless (reachable source) checkFileReachability+ doUnreachableCheck unreachableAction = do+ reachable <- isReachableSource+ unless (reachable source) unreachableAction - | otherwise = fail $ "unknown transport protocol for: " ++ source- where source = cacheSource cache- checkFileReachability = do- reachable <- checkHashedInventoryReachability cache- if reachable- then- addReachableSource source- else- addBadSource source+ checkFileReachability doCheck = do+ reachable <- doCheck+ if reachable+ then addReachableSource source+ else addBadSource source --- | Returns a list of reachables cache entries,--- taking out the blacklisted entries+-- | Returns a list of reachables cache entries, removing blacklisted entries. filterBadSources :: [CacheLoc] -> IO [CacheLoc] filterBadSources cache = do- badSource <- isBadSource- return $ filter (not . badSource . cacheSource) cache+ badSource <- isBadSource+ return $ filter (not . badSource . cacheSource) cache --- | Checks if the _darcs/hashed_inventory exist and is reachable+-- | Checks if the _darcs/hashed_inventory exist and is reachable checkHashedInventoryReachability :: CacheLoc -> IO Bool-checkHashedInventoryReachability cache =- withTemp $ \tempout -> do- let f = cacheSource cache </> darcsdir </> "hashed_inventory"- copyFileOrUrl DefaultRemoteDarcs f tempout Cachable- return True- `catchNonSignal` (\_ -> return False)--fetchFileUsingCachePrivate :: FromWhere -> Cache -> HashedDir -> String -> IO (String, B.ByteString)-fetchFileUsingCachePrivate fromWhere (Ca cache) subdir f =- do when (fromWhere == Anywhere) $ copyFileUsingCache ActuallyCopy (Ca cache) subdir f- filterBadSources cache >>= ffuc- `catchall` debugFail ("Couldn't fetch `"++f++"'\nin subdir "++ hashedDir subdir ++- " from sources:\n\n"++show (Ca cache))- where ffuc (c:cs)- | not (writable c) && (Anywhere == fromWhere || isFile (fn c)) =- do debugMessage $ "In fetchFileUsingCachePrivate I'm going manually"- debugMessage $ " getting "++f- debugMessage $ " from " ++ fn c- x <- gzFetchFilePS (fn c) Cachable- if not $ checkHash f x- then do x' <- fetchFilePS (fn c) Cachable- when (not $ checkHash f x') $- do hPutStrLn stderr $ "Hash failure in " ++ fn c- fail $ "Hash failure in " ++ fn c- return (fn c, x')- else return (fn c, x) -- FIXME: create links in caches- `catchNonSignal` (\e -> do- checkCacheReachability (show e) c- filterBadSources cs >>= ffuc)-+checkHashedInventoryReachability cache = withTemp $ \tempout -> do+ let f = cacheSource cache </> darcsdir </> "hashed_inventory"+ copyFileOrUrl DefaultRemoteDarcs f tempout Cachable+ return True+ `catchNonSignal` const (return False) - | writable c =- do x1 <- gzFetchFilePS (fn c) Cachable- x <- if not $ checkHash f x1- then do x2 <- fetchFilePS (fn c) Cachable- when (not $ checkHash f x2) $- do hPutStrLn stderr $ "Hash failure in " ++ fn c- removeFile $ fn c- fail $ "Hash failure in " ++ fn c- return x2- else return x1- mapM_ (tryLinking (fn c)) cs- return (fn c, x)- `catchNonSignal` (\ e ->- do createCache c subdir `catchall` return () -- don't worry- checkCacheReachability (show e) c- (fname,x) <- filterBadSources cs >>= ffuc- do createLink fname (fn c)- return (fn c, x)- `catchall`- do gzWriteFilePS (fn c) x `catchall` return ()- return (fname,x))- | otherwise = ffuc cs+-- | Get contents of some hashed file taking advantage of the cache system.+-- We hace a list of locations (@cache@) ordered from "closest/fastest"+-- (typically, the destination repo) to "farthest/slowest" (typically,+-- the source repo).+-- First, if possible it copies the file from remote location to local.+-- Then, it reads it contents, and links the file across all writeable+-- locations including the destination repository.+fetchFileUsingCachePrivate :: FromWhere -> Cache -> HashedDir -> String+ -> IO (String, B.ByteString)+fetchFileUsingCachePrivate fromWhere (Ca cache) subdir f = do+ when (fromWhere == Anywhere) $+ copyFileUsingCache ActuallyCopy (Ca cache) subdir f+ filterBadSources cache >>= ffuc+ `catchall` debugFail ("Couldn't fetch `" ++ f ++ "'\nin subdir "+ ++ hashedDir subdir ++ " from sources:\n\n"+ ++ show (Ca cache))+ where+ ffuc (c : cs)+ | not (writable c) &&+ (Anywhere == fromWhere || isValidLocalPath (hashedFilePathReadOnly c subdir f)) = do+ let cacheFile = hashedFilePathReadOnly c subdir f+ -- looks like `copyFileUsingCache` could not copy the file we wanted.+ -- this can happen if `--no-cache` is NOT passed and the global cache is not accessible+ debugMessage $ "In fetchFileUsingCachePrivate I'm directly grabbing file contents from "+ ++ cacheFile+ x <- gzFetchFilePS cacheFile Cachable+ if not $ checkHash f x+ then do+ x' <- fetchFilePS cacheFile Cachable+ unless (checkHash f x') $ do+ hPutStrLn stderr $ "Hash failure in " ++ cacheFile+ fail $ "Hash failure in " ++ cacheFile+ return (cacheFile, x')+ else return (cacheFile, x) -- FIXME: create links in caches+ `catchNonSignal` \e -> do+ -- something bad happened, check if cache became unaccessible and try other ones+ checkCacheReachability (show e) c+ filterBadSources cs >>= ffuc+ | writable c = let cacheFile = hashedFilePath c subdir f in do+ debugMessage $ "About to gzFetchFilePS from " ++ show cacheFile+ x1 <- gzFetchFilePS cacheFile Cachable+ debugMessage $ "gzFetchFilePS done."+ x <- if not $ checkHash f x1+ then do+ x2 <- fetchFilePS cacheFile Cachable+ unless (checkHash f x2) $ do+ hPutStrLn stderr $ "Hash failure in " ++ cacheFile+ removeFile cacheFile+ fail $ "Hash failure in " ++ cacheFile+ return x2+ else return x1+ mapM_ (tryLinking cacheFile) cs+ return (cacheFile, x)+ `catchNonSignal` \e -> do+ debugMessage "Caught exception, now attempt creating cache."+ createCache c subdir `catchall` return ()+ checkCacheReachability (show e) c+ (fname, x) <- filterBadSources cs >>= ffuc -- fetch file from remaining locations+ debugMessage $ "Attempt creating link from: " ++ show fname ++ " to " ++ show cacheFile+ (createLink fname cacheFile >> (debugMessage "successfully created link")+ >> return (cacheFile, x))+ `catchall` do+ debugMessage $ "Attempt writing file: " ++ show cacheFile+ -- the following block is usually when files get actually written+ -- inside of _darcs or global cache.+ do createDirectoryIfMissing True (dropFileName cacheFile)+ gzWriteFilePS cacheFile x+ debugMessage $ "successfully wrote file"+ `catchall` return ()+ -- above block can fail if cache is not writeable+ return (fname, x)+ | otherwise = ffuc cs - ffuc [] = debugFail $ "No sources from which to fetch file `"++f++"'\n"++ show (Ca cache)+ ffuc [] = debugFail $ "No sources from which to fetch file `" ++ f+ ++ "'\n"++ show (Ca cache) - tryLinking ff c@(Cache Directory Writable d) =- do createDirectoryIfMissing False (d++"/"++(hashedDir subdir))- createLink ff (fn c)- `catchall` return ()- tryLinking _ _ = return ()- fn c = hashedFilePath c subdir f+ tryLinking ff c@(Cache Directory Writable d) = do+ createDirectoryIfMissing False (d ++ "/" ++ hashedDir subdir)+ createLink ff (hashedFilePath c subdir f)+ `catchall`+ return ()+ tryLinking _ _ = return () createCache :: CacheLoc -> HashedDir -> IO () createCache (Cache Directory _ d) subdir =- createDirectoryIfMissing True (d ++ "/" ++ (hashedDir subdir))+ createDirectoryIfMissing True (d ++ "/" ++ hashedDir subdir) createCache _ _ = return () --- | @write compression filename content@ writes @content@ to the file @filename@ according--- to the policy given by @compression@.+-- | @write compression filename content@ writes @content@ to the file+-- @filename@ according to the policy given by @compression@. write :: Compression -> String -> B.ByteString -> IO () write NoCompression = writeAtomicFilePS write GzipCompression = gzWriteAtomicFilePS --- | @writeFileUsingCache cache compression subdir contents@ write the string @contents@ to--- the directory subdir, except if it is already in the cache, in which case it is a noop.--- Warning (?) this means that in case of a hash collision, writing using writeFileUsingCache is--- a noop. The returned value is the filename that was given to the string.-writeFileUsingCache :: Cache -> Compression -> HashedDir -> B.ByteString -> IO String-writeFileUsingCache (Ca cache) compr subdir ps =- (fetchFileUsingCachePrivate LocalOnly (Ca cache) subdir hash >> return hash) `catchall`- wfuc cache `catchall`- debugFail ("Couldn't write `"++hash++"'\nin subdir "++(hashedDir subdir)++" to sources:\n\n"++- show (Ca cache))- where hash = cacheHash ps- wfuc (c:cs) | not $ writable c = wfuc cs- | otherwise = do createCache c subdir- write compr (fn c) ps -- FIXME: create links in caches- return hash- wfuc [] = debugFail $ "No location to write file `" ++ (hashedDir subdir) ++"/"++hash ++ "'"- fn c = hashedFilePath c subdir hash+-- | @writeFileUsingCache cache compression subdir contents@ write the string+-- @contents@ to the directory subdir, except if it is already in the cache, in+-- which case it is a noop. Warning (?) this means that in case of a hash+-- collision, writing using writeFileUsingCache is a noop. The returned value+-- is the filename that was given to the string.+writeFileUsingCache :: Cache -> Compression -> HashedDir -> B.ByteString+ -> IO String+writeFileUsingCache (Ca cache) compr subdir ps = do+ _ <- fetchFileUsingCachePrivate LocalOnly (Ca cache) subdir hash+ return hash+ `catchall`+ wfuc cache+ `catchall`+ debugFail ("Couldn't write `" ++ hash ++ "'\nin subdir "+ ++ hashedDir subdir ++ " to sources:\n\n"++ show (Ca cache))+ where+ hash = cacheHash ps+ wfuc (c : cs)+ | not $ writable c = wfuc cs+ | otherwise = do+ createCache c subdir+ -- FIXME: create links in caches+ write compr (hashedFilePath c subdir hash) ps+ return hash+ wfuc [] = debugFail $ "No location to write file `" ++ hashedDir subdir+ ++ "/" ++ hash ++ "'" cleanCaches :: Cache -> HashedDir -> IO () cleanCaches c d = cleanCachesWithHint' c d Nothing@@ -395,26 +515,34 @@ cleanCachesWithHint' :: Cache -> HashedDir -> Maybe [String] -> IO () cleanCachesWithHint' (Ca cs) subdir hint = mapM_ cleanCache cs- where cleanCache (Cache Directory Writable d) =- (withCurrentDirectory (d++"/"++(hashedDir subdir)) $- do fs' <- getDirectoryContents "."- let fs = fromMaybe fs' hint- mapM_ clean $ progressList ("Cleaning cache "++d++"/"++(hashedDir subdir)) $- filter okayHash fs) `catchall` return ()- cleanCache _ = return ()- clean f = do lc <- linkCount `liftM` getSymbolicLinkStatus f- when (lc < 2) $ removeFile f- `catchall` return ()+ where+ cleanCache (Cache Directory Writable d) =+ withCurrentDirectory (d ++ "/" ++ hashedDir subdir) (do+ fs' <- getDirectoryContents "."+ let fs = filter okayHash $ fromMaybe fs' hint+ cleanMsg = "Cleaning cache " ++ d ++ "/" ++ hashedDir subdir+ mapM_ clean $ progressList cleanMsg fs)+ `catchall`+ return ()+ cleanCache _ = return ()+ clean f = do+ lc <- linkCount `liftM` getSymbolicLinkStatus f+ when (lc < 2) $ removeFile f+ `catchall`+ return () -- | Prints an error message with a list of bad caches. reportBadSources :: IO () reportBadSources = do- sources <- getBadSourcesList- let size = length sources- unless (null sources) $- hPutStrLn stderr $- concat [ "\nHINT: I could not reach the following ", englishNum size (Noun "repository") ":"- , "\n", (intercalate "\n" (map (" " ++) sources))- , "\n If you're not using ", englishNum size It ", you should probably delete"- , "\n the corresponding ", englishNum size (Noun "entry") " from _darcs/prefs/sources."- ]+ sources <- getBadSourcesList+ let size = length sources+ unless (null sources) $ hPutStrLn stderr $+ concat [ "\nHINT: I could not reach the following "+ , englishNum size (Noun "repository") ":"+ , "\n"+ , intercalate "\n" (map (" " ++) sources)+ , "\n If you're not using "+ , englishNum size It ", you should probably delete"+ , "\n the corresponding "+ , englishNum size (Noun "entry") " from _darcs/prefs/sources."+ ]
+ src/Darcs/Repository/Compat.hs view
@@ -0,0 +1,141 @@+{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Darcs.Repository.Compat+ ( stdoutIsAPipe+ , mkStdoutTemp+ , canonFilename+ , maybeRelink+ , atomicCreate+ , sloppyAtomicCreate+ ) where++import Prelude hiding ( catch )++import Darcs.Util.File ( withCurrentDirectory )+#ifdef WIN32+import Data.Bits ( (.&.) )+import System.Random ( randomIO )+import Numeric ( showHex )+#else+#endif++import Control.Monad ( unless )+import Foreign.C.Types ( CInt(..) )+import Foreign.C.String ( CString, withCString+#ifndef WIN32+ , peekCString+#endif+ )++import Foreign.C.Error ( throwErrno, eEXIST, getErrno )+import System.Directory ( getCurrentDirectory )+import System.IO ( hFlush, stdout, stderr, hSetBuffering,+ BufferMode(NoBuffering) )+import System.IO.Error ( mkIOError, alreadyExistsErrorType )+import System.Posix.Files ( stdFileMode )+import System.Posix.IO ( openFd, closeFd, stdOutput, stdError,+ dupTo, defaultFileFlags, exclusive,+ OpenMode(WriteOnly) )+import System.Posix.Types ( Fd(..) )++import Darcs.Util.SignalHandler ( stdoutIsAPipe )++canonFilename :: FilePath -> IO FilePath+canonFilename f@(_:':':_) = return f -- absolute windows paths+canonFilename f@('/':_) = return f+canonFilename ('.':'/':f) = do cd <- getCurrentDirectory+ return $ cd ++ "/" ++ f+canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of+ "" -> fmap (++('/':f)) getCurrentDirectory+ rd -> withCurrentDirectory rd $+ do fd <- getCurrentDirectory+ return $ fd ++ "/" ++ simplefilename+ where+ simplefilename = reverse $ takeWhile (/='/') $ reverse f++#ifdef WIN32+mkstempCore :: FilePath -> IO (Fd, String)+mkstempCore fp+ = do r <- randomIO+ let fp' = fp ++ showHexLen 6 (r .&. 0xFFFFFF :: Int)+ fd <- openFd fp' WriteOnly (Just stdFileMode) flags+ return (fd, fp')+ where flags = defaultFileFlags { exclusive = True }++showHexLen :: (Integral a, Show a)+ => Int+ -> a+ -> String+showHexLen n x = let s = showHex x ""+ in replicate (n - length s) ' ' ++ s+#else+mkstempCore :: String -> IO (Fd, String)+mkstempCore str = withCString (str++"XXXXXX") $+ \cstr -> do fd <- c_mkstemp cstr+ if fd < 0+ then throwErrno $ "Failed to create temporary file "++str+ else do str' <- peekCString cstr+ fname <- canonFilename str'+ return (Fd fd, fname)++foreign import ccall unsafe "static stdlib.h mkstemp"+ c_mkstemp :: CString -> IO CInt+#endif++mkStdoutTemp :: String -> IO String+mkStdoutTemp str = do (fd, fn) <- mkstempCore str+ hFlush stdout+ hFlush stderr+ _ <- dupTo fd stdOutput+ _ <- dupTo fd stdError+ hFlush stdout+ hFlush stderr+ hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering+ return fn++++foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink+ :: CString -> CString -> CInt -> IO CInt++-- Checks whether src and dst are identical. If so, makes dst into a+-- link to src. Returns True if dst is a link to src (either because+-- we linked it or it already was). Safe against changes to src if+-- they are not in place, but not to dst.+maybeRelink :: String -> String -> IO Bool+maybeRelink src dst =+ withCString src $ \csrc ->+ withCString dst $ \cdst ->+ do rc <- maybe_relink csrc cdst 1+ case rc of+ 0 -> return True+ 1 -> return True+ -1 -> throwErrno ("Relinking " ++ dst)+ -2 -> return False+ -3 -> do putStrLn ("Relinking: race condition avoided on file " +++ dst)+ return False+ _ -> fail ("Unexpected situation when relinking " ++ dst)++sloppyAtomicCreate :: FilePath -> IO ()+sloppyAtomicCreate fp+ = do fd <- openFd fp WriteOnly (Just stdFileMode) flags+ closeFd fd+ where flags = defaultFileFlags { exclusive = True }++atomicCreate :: FilePath -> IO ()+atomicCreate fp = withCString fp $ \cstr -> do+ rc <- c_atomic_create cstr+ unless (rc >= 0) $+ do errno <- getErrno+ pwd <- getCurrentDirectory+ if errno == eEXIST+ then ioError $ mkIOError alreadyExistsErrorType+ ("atomicCreate in "++pwd)+ Nothing (Just fp)+ else throwErrno $ "atomicCreate "++fp++" in "++pwd++foreign import ccall unsafe "atomic_create.h atomic_create" c_atomic_create+ :: CString -> IO CInt
+ src/Darcs/Repository/Diff.hs view
@@ -0,0 +1,162 @@+-- Copyright (C) 2009 Petr Rockai+--+-- 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.++-- |+-- Module : Darcs.Repository.Diff+-- Copyright : 2009 Petr Rockai+-- License : MIT+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++{-# LANGUAGE CPP #-}+module Darcs.Repository.Diff+ (+ treeDiff+ ) where+++import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL++import Data.List ( sortBy )++import Storage.Hashed.Tree ( diffTrees+ , zipTrees+ , TreeItem(..)+ , Tree+ , readBlob+ , emptyBlob+ )+import Darcs.Util.Path( AnchoredPath, anchorPath )+++import Darcs.Util.ByteString ( isFunky )+import Darcs.Patch ( PrimPatch+ , hunk+ , canonize+ , binary+ , addfile+ , rmfile+ , adddir+ , rmdir+ , invert+ )+import Darcs.Repository.Prefs ( FileType(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) )+import Darcs.Patch.Witnesses.Sealed ( Gap(..) )+import Darcs.Repository.Flags ( DiffAlgorithm(..) )++#include "impossible.h"+++data Diff m = Added (TreeItem m)+ | Removed (TreeItem m)+ | Changed (TreeItem m) (TreeItem m)+++getDiff :: AnchoredPath+ -> Maybe (TreeItem m)+ -> Maybe (TreeItem m)+ -> (AnchoredPath, Diff m)+getDiff p Nothing (Just t) = (p, Added t)+getDiff p (Just from) (Just to) = (p, Changed from to)+getDiff p (Just t) Nothing = (p, Removed t)+getDiff _ Nothing Nothing = impossible -- zipTrees should never return this+++treeDiff :: forall m w prim . (Functor m, Monad m, Gap w, PrimPatch prim)+ => DiffAlgorithm+ -> (FilePath -> FileType)+ -> Tree m+ -> Tree m+ -> m (w (FL prim))+treeDiff da ft t1 t2 = do+ (from, to) <- diffTrees t1 t2+ diffs <- mapM (uncurry diff) $ sortBy organise $ zipTrees getDiff from to+ return $ foldr (joinGap (+>+)) (emptyGap NilFL) diffs+ where+ -- sort into removes, changes, adds, with removes in reverse-path order+ -- and everything else in forward order+ organise :: (AnchoredPath, Diff m) -> (AnchoredPath, Diff m) -> Ordering++ organise (p1, Changed _ _ ) (p2, Changed _ _) = compare p1 p2+ organise (p1, Added _) (p2, Added _) = compare p1 p2+ organise (p1, Removed _) (p2, Removed _) = compare p2 p1++ organise (_, Removed _) _ = LT+ organise _ (_, Removed _) = GT++ organise (_, Changed _ _) _ = LT+ organise _ (_, Changed _ _) = GT++ diff :: AnchoredPath -> Diff m -> m (w (FL prim))+ diff _ (Changed (SubTree _) (SubTree _)) = return (emptyGap NilFL)+ diff p (Removed (SubTree _)) =+ return $ freeGap (rmdir (anchorPath "" p) :>: NilFL)+ diff p (Added (SubTree _)) =+ return $ freeGap (adddir (anchorPath "" p) :>: NilFL)+ diff p (Added b'@(File _)) =+ do diff' <- diff p (Changed (File emptyBlob) b')+ return $ joinGap (:>:) (freeGap (addfile (anchorPath "" p))) diff'+ diff p (Removed a'@(File _)) =+ do diff' <- diff p (Changed a' (File emptyBlob))+ return $ joinGap (+>+) diff' (freeGap (rmfile (anchorPath "" p) :>: NilFL))+ diff p (Changed (File a') (File b')) =+ do a <- readBlob a'+ b <- readBlob b'+ let path = anchorPath "" p+ case ft path of+ TextFile | no_bin a && no_bin b ->+ return $ text_diff path a b+ _ -> return $ if a /= b+ then freeGap (binary path (strict a) (strict b) :>: NilFL)+ else emptyGap NilFL+ diff p (Changed a'@(File _) subtree@(SubTree _)) =+ do rmFileP <- diff p (Changed a' (File emptyBlob))+ addDirP <- diff p (Added subtree)+ return $ joinGap (+>+) rmFileP addDirP+ diff p (Changed subtree@(SubTree _) b'@(File _)) =+ 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++ text_diff p a b+ | BL.null a && BL.null b = emptyGap NilFL+ | BL.null a = freeGap (diff_from_empty p b)+ | BL.null b = freeGap (diff_to_empty p a)+ | otherwise = freeGap (line_diff p (linesB a) (linesB b))++ line_diff p a b = canonize da (hunk p 1 a b)++ diff_to_empty p x | BLC.last x == '\n' = line_diff p (init $ linesB x) []+ | otherwise = line_diff p (linesB x) [BS.empty]++ diff_from_empty p x = invert (diff_to_empty p x)++ no_bin = not . isFunky . strict . BL.take 4096++ linesB = map strict . BLC.split '\n'++ strict = BS.concat . BL.toChunks
+ src/Darcs/Repository/External.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE CPP #-}+module Darcs.Repository.External+ ( cloneTree+ , cloneFile+ , fetchFilePS+ , fetchFileLazyPS+ , gzFetchFilePS+ , speculateFileOrUrl+ , copyFileOrUrl+ , Cachable(..)+ , backupByRenaming+ , backupByCopying+ , environmentHelpProtocols+ ) where++import Prelude hiding ( catch )+import Control.Exception ( catch, IOException )++import System.Posix.Files+ ( getSymbolicLinkStatus+ , isRegularFile+ , isDirectory+ , createLink+ )+import System.Directory+ ( createDirectory+ , getDirectoryContents+ , doesDirectoryExist+ , doesFileExist+ , renameFile+ , renameDirectory+ , copyFile+ )++import System.Exit ( ExitCode(..) )+import System.Environment ( getEnv )+import System.FilePath.Posix ( (</>), normalise )+import System.IO.Error ( isDoesNotExistError )+import Control.Monad+ ( unless+ , when+ , zipWithM_+ )++import Data.Char ( toUpper )++import Darcs.Util.Exec ( exec, Redirect(..) )+import Darcs.Util.Download+ ( copyUrl+ , copyUrlFirst+ , waitUrl+ , Cachable(..)+ )++import Darcs.Util.URL+ ( isValidLocalPath+ , isHttpUrl+ , isSshUrl+ , splitSshUrl+ )+import Darcs.Util.Text ( breakCommand )+import Darcs.Util.Exception ( catchall )+import Darcs.Repository.Flags ( RemoteDarcs(..) )+import Darcs.Repository.Lock ( withTemp )+import Darcs.Repository.Ssh ( copySSH )++import Darcs.Util.ByteString ( gzReadFilePS )+import qualified Data.ByteString as B (ByteString, readFile )+import qualified Data.ByteString.Lazy as BL++#ifdef HAVE_HTTP+import Network.Browser+ ( browse+ , request+ , setErrHandler+ , setOutHandler+ , setAllowRedirects+ )+import Network.HTTP+ ( RequestMethod(GET)+ , rspCode+ , rspBody+ , rspReason+ , mkRequest+ )+import Network.URI+ ( parseURI+ , uriScheme+ )+#endif++copyFileOrUrl :: RemoteDarcs -> FilePath -> FilePath -> Cachable -> IO ()+copyFileOrUrl _ fou out _ | isValidLocalPath fou = copyLocal fou out+copyFileOrUrl _ fou out cache | isHttpUrl fou = copyRemote fou out cache+copyFileOrUrl rd fou out _ | isSshUrl fou = copySSH rd (splitSshUrl fou) out+copyFileOrUrl _ fou _ _ = fail $ "unknown transport protocol: " ++ fou++copyLocal :: String -> FilePath -> IO ()+copyLocal fou out = createLink fou out `catchall` cloneFile fou out++copyRemote :: String -> FilePath -> Cachable -> IO ()+copyRemote u v cache =+ do maybeget <- maybeURLCmd "GET" u+ case maybeget of+ Nothing -> copyRemoteNormal u v cache+ Just get ->+ do let (cmd,args) = breakCommand get+ r <- exec cmd (args++[u]) (Null, File v, AsIs)+ when (r /= ExitSuccess) $+ fail $ "(" ++ get ++ ") failed to fetch: " ++ u++cloneTree :: FilePath -> FilePath -> IO ()+cloneTree = cloneTreeExcept []++cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()+cloneTreeExcept except source dest =+ do fs <- getSymbolicLinkStatus source+ if isDirectory fs then do+ fps <- getDirectoryContents source+ let fps' = filter (`notElem` (".":"..":except)) fps+ mk_source fp = source </> fp+ mk_dest fp = dest </> fp+ zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')+ else fail ("cloneTreeExcept: Bad source " ++ source)+ `catch` \(_ :: IOException) -> fail ("cloneTreeExcept: Bad source " ++ source)++cloneSubTree :: FilePath -> FilePath -> IO ()+cloneSubTree source dest =+ do fs <- getSymbolicLinkStatus source+ if isDirectory fs then do+ createDirectory dest+ fps <- getDirectoryContents source+ let fps' = filter (`notElem` [".", ".."]) fps+ mk_source fp = source </> fp+ mk_dest fp = dest </> fp+ zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')+ else if isRegularFile fs then+ cloneFile source dest+ else fail ("cloneSubTree: Bad source "++ source)+ `catch` (\e -> unless (isDoesNotExistError e) $ ioError e)++cloneFile :: FilePath -> FilePath -> IO ()+cloneFile = copyFile++backupByRenaming :: FilePath -> IO ()+backupByRenaming = backupBy rename+ where rename x y = do+ isD <- doesDirectoryExist x+ if isD then renameDirectory x y else renameFile x y++backupByCopying :: FilePath -> IO ()+backupByCopying = backupBy copy+ where+ copy x y = do+ isD <- doesDirectoryExist x+ if isD then do createDirectory y+ cloneTree (normalise x) (normalise y)+ else copyFile x y++backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()+backupBy backup f =+ do hasBF <- doesFileExist f+ hasBD <- doesDirectoryExist f+ when (hasBF || hasBD) $ helper 0+ where+ helper :: Int -> IO ()+ helper i = do existsF <- doesFileExist next+ existsD <- doesDirectoryExist next+ if existsF || existsD+ then helper (i + 1)+ else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"+ backup f next+ where next = f ++ suffix+ suffix = ".~" ++ show i ++ "~"++copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a+copyAndReadFile readfn fou _ | isValidLocalPath fou = readfn fou+copyAndReadFile readfn fou cache = withTemp $ \t -> do+ copyFileOrUrl DefaultRemoteDarcs fou t cache+ readfn t++-- | @fetchFile fileOrUrl cache@ returns the content of its argument (either a+-- file or an URL). If it has to download an url, then it will use a cache as+-- required by its second argument.+--+-- We always use default remote darcs, since it is not fatal if the remote+-- darcs does not exist or is too old -- anything that supports transfer-mode+-- should do, and if not, we will fall back to SFTP or SCP.+fetchFilePS :: String -> Cachable -> IO B.ByteString+fetchFilePS = copyAndReadFile (B.readFile)++-- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of its argument+-- (either a file or an URL). Warning: this function may constitute a fd leak;+-- make sure to force consumption of file contents to avoid that. See+-- "fetchFilePS" for details.+fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString+#ifdef HAVE_HTTP+fetchFileLazyPS x c = case parseURI x of+ Just x' | uriScheme x' == "http:" -> do+ rsp <- fmap snd . browse $ do+ setErrHandler . const $ return ()+ setOutHandler . const $ return ()+ setAllowRedirects True+ request $ mkRequest GET x'+ if rspCode rsp /= (2, 0, 0)+ then fail $ "fetchFileLazyPS: " ++ rspReason rsp+ else return $ rspBody rsp+ _ -> copyAndReadFile BL.readFile x c+#else+fetchFileLazyPS = copyAndReadFile BL.readFile+#endif++gzFetchFilePS :: String -> Cachable -> IO B.ByteString+gzFetchFilePS = copyAndReadFile gzReadFilePS++maybeURLCmd :: String -> String -> IO (Maybe String)+maybeURLCmd what url =+ do let prot = map toUpper $ takeWhile (/= ':') url+ fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot))+ `catch` \(_ :: IOException) -> return Nothing++copyRemoteNormal :: String -> FilePath -> Cachable -> IO ()+copyRemoteNormal u v cache = copyUrlFirst u v cache >> waitUrl u++speculateFileOrUrl :: String -> FilePath -> IO ()+speculateFileOrUrl fou out | isHttpUrl fou = speculateRemote fou out+ | otherwise = return ()++speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable+#if defined(HAVE_CURL) || defined(HAVE_HTTP)+speculateRemote u v =+ do maybeget <- maybeURLCmd "GET" u+ case maybeget of+ Just _ -> return () -- can't pipeline these+ Nothing -> copyUrl u v Cachable+#else+speculateRemote u _ = const () `fmap` maybeURLCmd "GET" u+#endif++environmentHelpProtocols :: ([String], [String])+environmentHelpProtocols = (["DARCS_GET_FOO", "DARCS_APPLY_FOO"],[+ "When trying to access a repository with a URL beginning foo://,",+ "darcs will invoke the program specified by the DARCS_GET_FOO",+ "environment variable (if defined) to download each file, and the",+ "command specified by the DARCS_APPLY_FOO environment variable (if",+ "defined) when pushing to a foo:// URL.",+ "",+ "This method overrides all other ways of getting `foo://xxx` URLs.",+ "",+ "Note that each command should be constructed so that it sends the downloaded",+ "content to STDOUT, and the next argument to it should be the URL.",+ "Here are some examples that should work for DARCS_GET_HTTP:",+ "",+ " fetch -q -o -",+ " curl -s -f",+ " lynx -source",+ " wget -q -O -",+ "",+ "Apart from such toy examples, it is likely that you will need to",+ "manipulate the argument before passing it to the actual fetcher",+ "program. For example, consider the problem of getting read access to",+ "a repository on a CIFS (SMB) share without mount privileges:",+ "",+ " export DARCS_GET_SMB='smbclient -c get'",+ " darcs get smb://fs/twb/Desktop/hello-world",+ "",+ "The above command will not work for several reasons. Firstly, Darcs",+ "will pass it an argument beginning with `smb:`, which smbclient does",+ "not understand. Secondly, the host and share `//fs/twb` must be",+ "presented as a separate argument to the path `Desktop/hello-world`.",+ "Thirdly, smbclient requires that `get` and the path be a single",+ "argument (including a space), rather than two separate arguments.",+ "Finally, smbclient's `get` command writes the file to disk, while",+ "Darcs expects it to be printed to standard output.",+ "",+ "In principle, we could get around such problems by making the variable",+ "contain a shell script, unfortunately, Darcs splits the command on",+ "whitespace and does not understand quotation or escaping. Therefore,",+ "we instead need to put commands in separate, executable scripts.",+ "",+ "Continuing our smbclient example, we create an executable script",+ "`~/.darcs/libexec/get_smb` with the following contents:",+ "",+ " #!/bin/bash -e",+ " IFS=/ read host share file <<<'${1#smb://}'",+ " smbclient //$host/$share -c 'get $file -'",+ "",+ "And at last we can say",+ "",+ " export DARCS_GET_SMB=~/.darcs/libexec/get_smb",+ " darcs get smb://fs/twb/Desktop/hello-world",+ "",+ "The APPLY command will be called with a darcs patchfile piped into",+ "its standard input."+ ])++
+ src/Darcs/Repository/Flags.hs view
@@ -0,0 +1,115 @@+module Darcs.Repository.Flags+ (+ Compression (..)+ , RemoteDarcs (..)+ , Reorder (..)+ , Verbosity (..)+ , UpdateWorking (..)+ , UseCache (..)+ , DryRun (..)+ , UMask (..)+ , LookForAdds (..)+ , LookForReplaces (..)+ , DiffAlgorithm (..)+ , LookForMoves (..)+ , RunTest (..)+ , SetScriptsExecutable (..)+ , LeaveTestDir (..)+ , RemoteRepos (..)+ , SetDefault (..)+ , UseIndex (..)+ , ScanKnown (..)+ , CloneKind (..)+ , AllowConflicts (..)+ , ExternalMerge (..)+ , WorkRepo (..)+ , WantGuiPause (..)+ , WithPatchIndex (..)+ , WithWorkingDir (..)+ , ForgetParent (..)+ ) where++import Darcs.Util.Diff ( DiffAlgorithm(..) )++data Verbosity = Quiet | NormalVerbosity | Verbose+ deriving ( Eq, Show )++data Compression = NoCompression+ | GzipCompression+ deriving ( Eq, Show )++data WithPatchIndex = YesPatchIndex | NoPatchIndex+ deriving ( Eq, Show )++data RemoteDarcs = RemoteDarcs String+ | DefaultRemoteDarcs+ deriving ( Eq, Show )++data Reorder = NoReorder | Reorder+ deriving ( Eq )++data UpdateWorking = YesUpdateWorking | NoUpdateWorking+ deriving ( Eq, Show )++data UseCache = YesUseCache | NoUseCache+ deriving ( Eq, Show )++data DryRun = YesDryRun | NoDryRun+ deriving ( Eq, Show )++data UMask = YesUMask String | NoUMask+ deriving ( Eq, Show )++data LookForAdds = YesLookForAdds | NoLookForAdds+ deriving ( Eq, Show )++data LookForReplaces = YesLookForReplaces | NoLookForReplaces+ deriving ( Eq, Show )++data LookForMoves = YesLookForMoves | NoLookForMoves+ deriving ( Eq, Show )++data RunTest = YesRunTest | NoRunTest+ deriving ( Eq, Show )++data SetScriptsExecutable = YesSetScriptsExecutable | NoSetScriptsExecutable+ deriving ( Eq, Show )++data LeaveTestDir = YesLeaveTestDir | NoLeaveTestDir+ deriving ( Eq, Show )++data RemoteRepos = RemoteRepos [String]+ deriving ( Eq, Show )++data SetDefault = YesSetDefault Bool | NoSetDefault Bool+ deriving ( Eq, Show )++data UseIndex = UseIndex | IgnoreIndex deriving ( Eq, Show )++data ScanKnown = ScanKnown -- ^Just files already known to darcs+ | ScanAll -- ^All files, i.e. look for new ones+ | ScanBoring -- ^All files, even boring ones++-- Various kinds of getting repositories+data CloneKind = LazyClone -- ^Just copy pristine and inventories+ | NormalClone -- ^First do a lazy clone then copy everything+ | CompleteClone -- ^Same as Normal but omit telling user they can interrumpt+ deriving ( Eq, Show )++data AllowConflicts = NoAllowConflicts | YesAllowConflicts | YesAllowConflictsAndMark+ deriving ( Eq, Show )++data ExternalMerge = YesExternalMerge String | NoExternalMerge+ deriving ( Eq, Show )++data WorkRepo = WorkRepoDir String | WorkRepoPossibleURL String | WorkRepoCurrentDir+ deriving ( Eq, Show )++data WantGuiPause = YesWantGuiPause | NoWantGuiPause+ deriving ( Eq, Show )++data WithWorkingDir = WithWorkingDir | NoWorkingDir+ deriving ( Eq, Show )++data ForgetParent = YesForgetParent | NoForgetParent+ deriving ( Eq, Show )
src/Darcs/Repository/Format.hs view
@@ -4,159 +4,210 @@ {-# LANGUAGE CPP #-} -module Darcs.Repository.Format ( RepoFormat(..), RepoProperty(..),- identifyRepoFormat, tryIdentifyRepoFormat,- createRepoFormat, writeRepoFormat,- writeProblem, readProblem, readfromAndWritetoProblem,- formatHas,- ) where+module Darcs.Repository.Format+ ( RepoFormat(..)+ , RepoProperty(..)+ , identifyRepoFormat+ , tryIdentifyRepoFormat+ , createRepoFormat+ , writeRepoFormat+ , writeProblem+ , readProblem+ , transferProblem+ , formatHas+ , addToFormat+ , removeFromFormat+ ) where -import Data.Maybe ( isJust, mapMaybe )+#include "impossible.h"+ import Control.Monad ( mplus, (<=<) )+import qualified Data.ByteString.Char8 as BC ( split, unpack, elemIndex )+import qualified Data.ByteString as B ( null, empty )+import Data.List ( partition, intercalate, (\\) )+import Data.Maybe ( isJust, mapMaybe ) -import Darcs.SignalHandler ( catchNonSignal )-import Darcs.External ( fetchFilePS, Cachable( Cachable ) )-import Darcs.Flags ( DarcsFlag ( UseFormat2, UseHashedInventory, UseNoWorkingDir ) )-import Darcs.Lock ( writeBinFile )-import Darcs.Utils ( catchall, prettyException )-import Progress ( beginTedious, endTedious, finishedOneIO )-import Darcs.Global ( darcsdir )+import Darcs.Repository.External+ ( fetchFilePS+ , Cachable( Cachable )+ )+import Darcs.Util.Global ( darcsdir )+import Darcs.Repository.Lock ( writeBinFile )+import qualified Darcs.Repository.Flags as F ( WithWorkingDir (..) )+import Darcs.Util.SignalHandler ( catchNonSignal )+import Darcs.Util.Exception ( catchall, prettyException ) -import ByteStringUtils ( linesPS )-import qualified Data.ByteString.Char8 as BC (split, unpack, singleton, elemIndex, pack)-import qualified Data.ByteString as B (ByteString, null, empty)-import qualified ByteStringUtils as BU ( intercalate )+import Darcs.Util.ByteString ( linesPS )+import Darcs.Util.Progress ( beginTedious, endTedious, finishedOneIO ) -#include "impossible.h"+data RepoProperty = Darcs1+ | Darcs2+ | HashedInventory+ | NoWorkingDir+ | RebaseInProgress+ | UnknownFormat String+ deriving ( Eq ) -data RepoProperty = Darcs1_0 | Darcs2 | HashedInventory | NoWorkingDir+-- | Define string constants in one place, for reuse in show/parse functions.+darcs1Format, darcs2Format, hashedInventoryFormat :: String+noWorkingDirFormat, rebaseInProgressFormat :: String --- | @RepoFormat@ is the representation of the format of a--- repository. Each sublist corresponds to a line in the format--- file. Each line is decomposed into words.-newtype RepoFormat = RF [[B.ByteString]] deriving ( Show )+darcs1Format = "darcs-1.0"+darcs2Format = "darcs-2"+hashedInventoryFormat = "hashed"+noWorkingDirFormat = "no-working-dir"+rebaseInProgressFormat = "rebase-in-progress" --- | The file where the format information should be.-df :: FilePath-df = darcsdir++"/format"+instance Show RepoProperty where+ show Darcs1 = darcs1Format+ show Darcs2 = darcs2Format+ show HashedInventory = hashedInventoryFormat+ show NoWorkingDir = noWorkingDirFormat+ show RebaseInProgress = rebaseInProgressFormat+ show (UnknownFormat f) = "Unknown format: " ++ f --- | @identifyRepoFormat URL@ identifies the format of the repository--- at the given address. Fails if we weren't able to identify the format.+readRepoProperty :: String -> RepoProperty+readRepoProperty input+ | input == darcs1Format = Darcs1+ | input == darcs2Format = Darcs2+ | input == hashedInventoryFormat = HashedInventory+ | input == noWorkingDirFormat = NoWorkingDir+ | input == rebaseInProgressFormat = RebaseInProgress+ | otherwise = UnknownFormat input++-- | Representation of the format of a repository. Each+-- sublist corresponds to a line in the format file.+-- Currently all lines are expected to be singleton words.+newtype RepoFormat = RF [[RepoProperty]]++-- | Is a given property contained within a given format?+formatHas :: RepoProperty -> RepoFormat -> Bool+formatHas f (RF rps) = f `elem` concat rps++-- | Add a single property to an existing format.+addToFormat :: RepoProperty -> RepoFormat -> RepoFormat+addToFormat f (RF rps) = RF (rps ++ [[f]])++-- | Remove a single property from an existing format.+removeFromFormat :: RepoProperty -> RepoFormat -> RepoFormat+removeFromFormat f (RF rps) = RF (rps \\ [[f]])++instance Show RepoFormat where+ show (RF rf) = unlines $ map (intercalate "|" . map show) rf++-- | Identify the format of the repository at the+-- given location (directory, URL, or SSH path).+-- Fails if we weren't able to identify the format. identifyRepoFormat :: String -> IO RepoFormat identifyRepoFormat = either fail return <=< tryIdentifyRepoFormat --- | @tryIdentifyRepoFormat URL@ identifies the format of the repository--- at the given address. Return @Left reason@ if it fails, where--- @reason@ explains why we weren't able to identify the format.+-- | Identify the format of the repository at the+-- given location (directory, URL, or SSH path).+-- Return @'Left' reason@ if it fails, where @reason@ explains why+-- we weren't able to identify the format. Note that we do no verification of+-- the format, which is handled by 'readProblem' or 'writeProblem' on the+-- resulting 'RepoFormat'. tryIdentifyRepoFormat :: String -> IO (Either String RepoFormat)-tryIdentifyRepoFormat repo =- do let k = "Identifying repository "++repo+tryIdentifyRepoFormat repo = do+ let k = "Identifying repository " ++ repo beginTedious k finishedOneIO k "format"- dff <- fetchFilePS (repo ++ "/" ++ df) Cachable `catchall` return B.empty- -- below is a workaround for servers that don't return a 404 on nonexistent files- rf <- if B.null dff || isJust (BC.elemIndex '<' dff)- then do finishedOneIO k "inventory"- have_inventory <- doesRemoteFileExist (repo++"/"++darcsdir++"/inventory")- return $- case have_inventory of- Right _ -> Right defaultRepoFormat- Left e -> Left . unlines $- [ "Not a repository: "++repo++" ("++e++")"- , ""- , "HINT: Do you have the right URI for the repository?"- , ""- , " If so, check with the repository owner to see if the following files"- , " are readable:"- , ""- , " 1. _darcs/format - might not exist; that's OK"- , " 2. _darcs/inventory - should exist if #1 is missing"- , " 3. _darcs/hashed_inventory - should exist if #2 is missing"- ]- else return $ Right $ parseRepoFormat dff+ formatInfo <- (fetchFilePS (repoPath "format") Cachable)+ `catchall` (return B.empty)+ -- We use a workaround for servers that don't return a 404 on nonexistent+ -- files (we trivially check for something that looks like a HTML/XML tag).+ format <-+ if (B.null formatInfo || isJust (BC.elemIndex '<' formatInfo)) then do+ finishedOneIO k "inventory"+ missingInvErr <- checkFile (repoPath "inventory")+ case missingInvErr of+ Nothing -> return . Right $ RF [[Darcs1]]+ Just e -> return . Left $ makeErrorMsg e+ else return . Right $ readFormat formatInfo endTedious k- return rf- where drfe x = fetchFilePS x Cachable >> return True- doesRemoteFileExist x = fmap Right (drfe x) `catchNonSignal`- (\e -> return (Left (prettyException e)))+ return format+ where+ repoPath fileName = repo ++ "/" ++ darcsdir ++ "/" ++ fileName --- | @writeRepoFormat@ writes the repo format to the given file.-writeRepoFormat :: RepoFormat -> FilePath -> IO ()-writeRepoFormat (RF rf) loc = writeBinFile loc $ unlines $- map (BC.unpack . BU.intercalate (BC.singleton '|')) rf+ readFormat = RF . map (map (readRepoProperty . BC.unpack)) . splitFormat -parseRepoFormat :: B.ByteString -> RepoFormat-parseRepoFormat ps =- RF $ map (BC.split '|') $ filter (not . B.null) $ linesPS ps+ -- split into lines, then split each non-empty line on '|'+ splitFormat = map (BC.split '|') . filter (not . B.null) . linesPS --- | The repo format we assume if we do not find a format file.-defaultRepoFormat :: RepoFormat-defaultRepoFormat = RF [[rp2ps Darcs1_0]]+ checkFile path = (fetchFilePS path Cachable >> return Nothing)+ `catchNonSignal`+ (return . Just . prettyException) -createRepoFormat :: [DarcsFlag] -> RepoFormat-createRepoFormat fs = RF (map rp2ps (HashedInventory:flags2wd): maybe2)- where maybe2 = if UseFormat2 `notElem` fs && (UseHashedInventory `elem` fs)- then []- else [[rp2ps Darcs2]]- flags2wd = if UseNoWorkingDir `elem` fs- then [NoWorkingDir]- else []+ makeErrorMsg e = unlines+ [ "Not a repository: " ++ repo ++ " (" ++ e ++ ")"+ , ""+ , "HINT: Do you have the right URI for the repository?"+ ] --- | @writeProblem form@ tells if we can write to a repo in format @form@.--- It returns @Nothing@ if there's no problem writing to such a repository.-writeProblem :: RepoFormat -> Maybe String-writeProblem rf = readProblem rf `mplus` allProblems rf wp- where wp x | all isKnown x = Nothing- wp [] = impossible- wp x = Just $ unwords $ "Can't write repository format: " :- map BC.unpack (filter (not . isKnown) x)+-- | Write the repo format to the given file.+writeRepoFormat :: RepoFormat -> FilePath -> IO ()+writeRepoFormat rf loc = writeBinFile loc $ show rf +-- | @createRepoFormat useFormat1 useNoWorkingDir@ create a repo format+createRepoFormat :: Bool -> F.WithWorkingDir -> RepoFormat+createRepoFormat useFormat1 wwd = RF $ (HashedInventory : flags2wd wwd) : flags2format+ where+ flags2format = if useFormat1 then [] else [[Darcs2]]+ flags2wd F.NoWorkingDir = [NoWorkingDir]+ flags2wd _ = [] --- | @readfromAndWritetoProblem form@ tells if we can read from and write to a repo in--- format @form@. It returns @Nothing@ if there's no problem reading--- and writing to such a repository.-readfromAndWritetoProblem :: RepoFormat -> RepoFormat -> Maybe String-readfromAndWritetoProblem inrf outrf- | formatHas Darcs2 inrf /= formatHas Darcs2 outrf- = Just "Cannot mix darcs-2 repositories with older formats"- | otherwise = readProblem inrf `mplus` writeProblem outrf+-- | @writeProblem form@ tells if we can write to a repo in format @form@,+-- first checking if we can read that repo It returns @Nothing@ if there's no+-- problem writing to such a repository.+writeProblem :: RepoFormat -> Maybe String+writeProblem target = readProblem target `mplus` findProblems target wp+ where+ wp [] = impossible+ wp x = case partition isKnown x of+ (_, []) -> Nothing+ (_, unknowns) -> Just . unwords $+ "Can't write repository format: " : map show unknowns +-- | @'transferProblem' source target@ returns 'Just' an error message if we+-- cannot transfer patches from a repo in format @source@ to a repo in format+-- @target@, or 'Nothing' if there are no such problem.+transferProblem :: RepoFormat -> RepoFormat -> Maybe String+transferProblem source target+ | formatHas Darcs2 source /= formatHas Darcs2 target =+ Just "Cannot mix darcs-2 repositories with older formats"+ | formatHas RebaseInProgress source =+ -- we could support this, by applying an appropriate filter to the patches+ -- as we pull them.+ Just "Cannot transfer patches from a repository where a rebase is in progress" + | otherwise = readProblem source `mplus` writeProblem target --- | @readProblem form@ tells if we can read from a repo in format @form@.--- It returns @Nothing@ if there's no problem reading from such a repository.+-- | @'readProblem' source@ returns 'Just' an error message if we cannot read+-- from a repo in format @source@, or 'Nothing' if there's no such problem. readProblem :: RepoFormat -> Maybe String-readProblem rf | formatHas Darcs1_0 rf && formatHas Darcs2 rf- = Just "Invalid repositoryformat: format 2 is incompatible with format 1"-readProblem rf = allProblems rf rp- where rp x | any isKnown x = Nothing- rp [] = impossible- rp x = Just $ unwords $- "Can't understand repository format:" : map BC.unpack x---allProblems :: RepoFormat -> ([B.ByteString] -> Maybe String) -> Maybe String-allProblems (RF ks) repoFormatLineProblem = maybeSingleError $ mapMaybe repoFormatLineProblem ks- where- maybeSingleError [] = Nothing- maybeSingleError xs = Just $ unlines xs+readProblem source+ | formatHas Darcs1 source && formatHas Darcs2 source =+ Just "Invalid repositoryformat: format 2 is incompatible with format 1"+readProblem source = findProblems source rp+ where+ rp x | any isKnown x = Nothing+ rp [] = impossible+ rp x = Just . unwords $ "Can't understand repository format:" : map show x +-- |'findProblems' applies a function that maps format-entries to an optional+-- error message, to each repoformat entry. Returning any errors.+findProblems :: RepoFormat -> ([RepoProperty] -> Maybe String) -> Maybe String+findProblems (RF ks) formatHasProblem = case mapMaybe formatHasProblem ks of+ [] -> Nothing+ xs -> Just $ unlines xs -- | Does this version of darcs know how to handle this property?-isKnown :: B.ByteString -> Bool-isKnown p = p `elem` map rp2ps knownProperties---- | This is the list of properties which this version of darcs knows--- how to handle.-knownProperties :: [RepoProperty]-knownProperties = [Darcs1_0, Darcs2, HashedInventory, NoWorkingDir]--formatHas :: RepoProperty -> RepoFormat -> Bool-formatHas f (RF ks) = rp2ps f `elem` concat ks--instance Show RepoProperty where- show Darcs1_0 = "darcs-1.0"- show Darcs2 = "darcs-2"- show HashedInventory = "hashed"- show NoWorkingDir = "no-working-dir"-rp2ps :: RepoProperty -> B.ByteString-rp2ps = BC.pack . show+isKnown :: RepoProperty -> Bool+isKnown p = p `elem` knownProperties+ where+ knownProperties :: [RepoProperty]+ knownProperties = [ Darcs1+ , Darcs2+ , HashedInventory+ , NoWorkingDir+ , RebaseInProgress+ ]
src/Darcs/Repository/HashedIO.hs view
@@ -14,21 +14,22 @@ -- along with this program; if not, write to the Free Software Foundation, -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +{-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} -#include "gadts.h" module Darcs.Repository.HashedIO ( HashedIO, copyHashed, copyPartialsHashed,- cleanHashdir,+ cleanHashdir, getHashedFiles, RW(RW) -- only exported to make warning go away+ , pathsAndContents ) where -import Darcs.Global ( darcsdir )+import Darcs.Util.Global ( darcsdir ) import qualified Data.Set as Set import System.Directory ( getDirectoryContents, createDirectoryIfMissing )-import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift )-import Control.Monad ( when )+import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift, evalStateT )+import Control.Monad ( when, void, unless ) import Control.Applicative ( (<$>) ) import Data.Maybe ( isJust ) import System.IO.Unsafe ( unsafeInterleaveIO )@@ -36,33 +37,43 @@ import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache, writeFileUsingCache, peekInCache, speculateFileUsingCache, okayHash, cleanCachesWithHint, HashedDir(..), hashedDir )-import Darcs.RepoPath ( FilePathLike, toFilePath ) import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )-import Darcs.Flags ( Compression( .. ) )-import Darcs.Lock ( writeAtomicFilePS, removeFileMayNotExist )-import Darcs.Utils ( withCurrentDirectory )-import Progress ( debugMessage, tediousSize, finishedOneIO )-import Darcs.Patch.FileName ( FileName, normPath, fp2fn, fn2fp, fn2niceps, niceps2fn,- breakOnDir, ownName, superName )+import Darcs.Repository.Flags ( Compression( .. ), WithWorkingDir (..) )+import Darcs.Repository.Lock ( writeAtomicFilePS, removeFileMayNotExist )+import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Progress ( debugMessage, tediousSize, finishedOneIO )+import Darcs.Util.Path+ ( FileName+ , normPath+ , fp2fn+ , fn2fp+ , fn2niceps+ , niceps2fn+ , breakOnDir+ , ownName+ , superName+ , FilePathLike+ , toFilePath+ , isMaliciousSubPath+ ) -import ByteStringUtils ( linesPS, unlinesPS )+import Darcs.Util.ByteString ( linesPS, unlinesPS ) import qualified Data.ByteString as B (ByteString, length, empty) import qualified Data.ByteString.Char8 as BC (unpack, pack) import Storage.Hashed.Darcs( readDarcsHashedDir, darcsLocation, decodeDarcsHash, decodeDarcsSize ) import Storage.Hashed.Tree( ItemType(..), Tree )-import Darcs.CommandsAux -- | @readHashFile c subdir hash@ reads the file with hash @hash@ in dir subdir, -- fetching it from 'Cache' @c@ if needed. readHashFile :: Cache -> HashedDir -> String -> IO (String,B.ByteString) readHashFile c subdir hash =- do debugMessage $ "Reading hash file "++hash++" from "++(hashedDir subdir)++"/"+ do debugMessage $ "Reading hash file "++hash++" from "++hashedDir subdir++"/" fetchFileUsingCache c subdir hash data HashDir r p = HashDir { permissions :: !r, cache :: !Cache,- compress :: !Compression, rootHash :: !String }+ rootHash :: !String } type HashedIO p = StateT (HashDir RW p) IO data RW = RW@@ -173,22 +184,18 @@ return (h',x) inh :: String -> HashedIO p a -> HashedIO p a-inh h j = do hd <- get- put $ hd { rootHash = h }- x <- j- put hd- return x+inh h j = snd `fmap` withh h j readroot :: HashedIO p [(ObjType, FileName, String)] readroot = do haveitalready <- peekroot cc <- gets rootHash >>= readdir- when (not haveitalready) $ speculate cc+ unless haveitalready $ speculate cc return cc where speculate :: [(a,b,String)] -> HashedIO q () speculate c = do cac <- gets cache mapM_ (\(_,_,z) -> lift $ speculateFileUsingCache cac HashedPristineDir z) c peekroot :: HashedIO p Bool- peekroot = do HashDir _ c _ h <- get+ peekroot = do HashDir _ c h <- get lift $ peekInCache c HashedPristineDir h writeroot :: [(ObjType, FileName, String)] -> HashedIO p ()@@ -232,44 +239,70 @@ writeHashFile :: B.ByteString -> HashedIO p String writeHashFile ps = do c <- gets cache- compr <- gets compress- lift $ writeFileUsingCache c compr HashedPristineDir ps+ -- pristine files are always compressed+ lift $ writeFileUsingCache c GzipCompression HashedPristineDir ps -copyHashed :: String -> Cache -> Compression -> String -> IO ()--- Warning: A do-notation statement discarded a result of type ((), HashDir RO ghc-prim-copyHashed k c compr z = do _ <- runStateT cph $ HashDir { permissions = RW, cache = c,- compress = compr, rootHash = z }- return ()++-- | Grab a whole pristine tree from a hash, and, if asked,+-- write files in the working copy.+copyHashed :: String -> Cache -> WithWorkingDir -> String -> IO ()+copyHashed k c wwd z = void . runStateT cph $ HashDir { permissions = RW, cache = c, rootHash = z } where cph = do cc <- readroot lift $ tediousSize k (length cc) mapM_ cp cc- cp (F,n,h) = do ps <- readhash h- lift $ finishedOneIO k (fn2fp n)- lift $ writeAtomicFilePS (fn2fp n) ps- cp (D,n,h) = if isMaliciousSubPath (fn2fp n)- then fail ("Caught malicious path: " ++ fn2fp n)- else do- lift $ createDirectoryIfMissing False (fn2fp n)- lift $ finishedOneIO k (fn2fp n)- lift $ withCurrentDirectory (fn2fp n) $ copyHashed k c compr h+ cp (F,n,h) = do+ ps <- readhash h+ lift $ finishedOneIO k (fn2fp n)+ case wwd of+ WithWorkingDir -> lift $ writeAtomicFilePS (fn2fp n) ps+ NoWorkingDir -> ps `seq` return ()+ -- force evaluation of ps to actually copy hashed file+ cp (D,n,h) =+ if isMaliciousSubPath (fn2fp n)+ then fail ("Caught malicious path: " ++ fn2fp n)+ else do+ lift $ finishedOneIO k (fn2fp n)+ case wwd of+ WithWorkingDir -> do+ lift $ createDirectoryIfMissing False (fn2fp n)+ lift $ withCurrentDirectory (fn2fp n) $ copyHashed k c WithWorkingDir h+ NoWorkingDir ->+ lift $ copyHashed k c NoWorkingDir h +-- | Returns a list of pairs (FilePath, (strict) ByteString) of+-- the pristine tree starting with the hash @root@.+-- @path@ should be either "." or end with "/"+-- Separator "/" is used since this function is used to generate+-- zip archives from pristine trees.+pathsAndContents :: FilePath -> Cache -> String -> IO [(FilePath,B.ByteString)]+pathsAndContents path c root = evalStateT cph $ HashDir { permissions = RW, cache = c, rootHash = root }+ where cph = do cc <- readroot+ pacs <- concat <$> mapM cp cc+ let current = if path == "." then [] else [(path ++ "/" , B.empty)]+ return $ current ++ pacs+ cp (F,n,h) = do+ ps <- readhash h+ let p = (if path == "." then "" else path ++ "/") ++ fn2fp n+ return [(p,ps)]+ cp (D,n,h) = do+ let p = (if path == "." then "" else path) ++ fn2fp n ++ "/"+ lift $ pathsAndContents p c h+ copyPartialsHashed :: FilePathLike fp =>- Cache -> Compression -> String -> [fp] -> IO ()-copyPartialsHashed c compr root = mapM_ (copyPartialHashed c compr root)+ Cache -> String -> [fp] -> IO ()+copyPartialsHashed c root = mapM_ (copyPartialHashed c root) -copyPartialHashed :: FilePathLike fp => Cache -> Compression -> String -> fp -> IO ()-copyPartialHashed c compr root ff =+copyPartialHashed :: FilePathLike fp => Cache -> String -> fp -> IO ()+copyPartialHashed c root ff = do createDirectoryIfMissing True (basename $ toFilePath ff)--- Warning: A do-notation statement discarded a result of type ((), HashDir RO ghc-prim- _ <- runStateT (cp $ fp2fn $ toFilePath ff) $+ void $ runStateT (cp $ fp2fn $ toFilePath ff) HashDir { permissions = RW, cache = c,- compress=compr, rootHash = root }- return ()+ rootHash = root } where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse cp f = do mt <- identifyThing f case mt of Just (D,h) -> do lift $ createDirectoryIfMissing True (fn2fp f)- lift $ withCurrentDirectory (fn2fp f) $ copyHashed "" c compr h+ lift $ withCurrentDirectory (fn2fp f) $ copyHashed "" c WithWorkingDir h Just (F,h) -> do ps <- readhash h lift $ writeAtomicFilePS (fn2fp f) ps Nothing -> return ()@@ -277,15 +310,9 @@ cleanHashdir :: Cache -> HashedDir -> [String] -> IO () cleanHashdir c dir_ hashroots = do -- we'll remove obsolete bits of "dir"- debugMessage $ "Cleaning out " ++ (hashedDir dir_) ++ "..."- let hashdir = darcsdir ++ "/" ++ (hashedDir dir_) ++ "/"- listone h = do let size = decodeDarcsSize $ BC.pack h- hash = decodeDarcsHash $ BC.pack h- x <- readDarcsHashedDir hashdir (size, hash)- let subs = [ fst $ darcsLocation "" (s, h') | (TreeType, _, s, h') <- x ]- hashes = h : [ fst $ darcsLocation "" (s, h') | (_, _, s, h') <- x ]- (hashes++) . concat <$> mapM listone subs- hs <- set . concat <$> mapM listone hashroots+ debugMessage $ "Cleaning out " ++ hashedDir dir_ ++ "..."+ let hashdir = darcsdir ++ "/" ++ hashedDir dir_ ++ "/"+ hs <- set <$> getHashedFiles hashdir hashroots fs <- set . filter okayHash <$> getDirectoryContents hashdir mapM_ (removeFileMayNotExist . (hashdir++)) (unset $ fs `Set.difference` hs) -- and also clean out any global caches.@@ -293,3 +320,16 @@ cleanCachesWithHint c dir_ (unset $ fs `Set.difference` hs) where set = Set.fromList . map BC.pack unset = map BC.unpack . Set.toList++-- | getHashedFiles returns all hash files targeted by files in hashroots in+-- the hashdir directory.+getHashedFiles :: String -> [String] -> IO [String]+getHashedFiles hashdir hashroots = do+ let listone h = do let size = decodeDarcsSize $ BC.pack h+ hash = decodeDarcsHash $ BC.pack h+ x <- readDarcsHashedDir hashdir (size, hash)+ let subs = [ fst $ darcsLocation "" (s, h') | (TreeType, _, s, h') <- x ]+ hashes = h : [ fst $ darcsLocation "" (s, h') | (_, _, s, h') <- x ]+ (hashes++) . concat <$> mapM listone subs+ hs <- concat <$> mapM listone hashroots+ return hs
src/Darcs/Repository/HashedRepo.hs view
@@ -15,470 +15,798 @@ -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. {-# LANGUAGE CPP, ScopedTypeVariables #-}--#include "gadts.h"--module Darcs.Repository.HashedRepo ( revertTentativeChanges, finalizeTentativeChanges,- cleanPristine,- copyPristine, copyPartialsPristine,- applyToTentativePristine, addToSpecificInventory,- addToTentativeInventory, removeFromTentativeInventory,- readRepo, readTentativeRepo,- readRepoUsingSpecificInventory, writeAndReadPatch,- writeTentativeInventory, copyRepo,- readHashedPristineRoot, pris2inv, copySources,- listInventories, writePatchIfNecessary,- readRepoFromInventoryList, readPatchIds- ) where--import Prelude hiding ( catch )--import System.Directory ( createDirectoryIfMissing )-import System.FilePath.Posix( (</>) )-import System.IO.Unsafe ( unsafeInterleaveIO )-import System.IO ( stderr, hPutStrLn )-import Data.List ( delete )-import Control.Monad ( unless )-import Control.Applicative ( (<$>) )-import Control.Exception ( catch, IOException )--import Workaround ( renameFile )-import Darcs.Flags ( Compression, RemoteDarcs )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.RepoPath ( FilePathLike, ioAbsoluteOrRemote, toPath )-import Darcs.Repository.Cache ( Cache(..), CacheLoc(..), fetchFileUsingCache,- speculateFilesUsingCache, writeFileUsingCache,- unionCaches, repo2cache, okayHash, takeHash,- HashedDir(..), hashedDir,- peekInCache )-import qualified Darcs.Repository.Cache as DarcsCache-import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed,- cleanHashdir )-import Darcs.Repository.InternalTypes ( Repository(..), extractCache, modifyCache )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, patchInfoAndPatch, info,- extractHash, createHashed )-import Darcs.Patch ( RepoPatch, Patchy, showPatch, readPatch, apply )-import Darcs.Patch.Apply ( Apply, ApplyState )-import Darcs.Patch.ReadMonads ( parseStrictly )-import Darcs.Patch.Depends ( commuteToEnd, slightlyOptimizePatchset )-import Darcs.Patch.Info ( PatchInfo, showPatchInfo, humanFriendly, readPatchInfo )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( reverseRL, reverseFL, (+<+) )--import ByteStringUtils ( gzReadFilePS, dropSpace )-import qualified Data.ByteString as B (null, length, empty- ,tail, take, drop, ByteString)-import qualified Data.ByteString.Char8 as BC (unpack, dropWhile, break, pack)--import Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text, invisiblePS )-import Darcs.ColorPrinter () -- for instance Show Doc-import Crypt.SHA256 ( sha256sum )-import Darcs.External ( copyFileOrUrl, cloneFile, fetchFilePS, gzFetchFilePS,- Cachable( Uncachable ) )-import Darcs.Lock ( writeBinFile, writeDocBinFile, writeAtomicFilePS, appendBinFile, appendDocBinFile )-import Darcs.Utils ( withCurrentDirectory )-import Progress ( beginTedious, endTedious, debugMessage, finishedOneIO )-#include "impossible.h"-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), mapRL, mapFL )-import Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal )-import Darcs.Global ( darcsdir )--import Storage.Hashed.Darcs( hashedTreeIO, readDarcsHashedNosize, readDarcsHashed,- writeDarcsHashed,- decodeDarcsHash, decodeDarcsSize )-import Storage.Hashed.Tree( treeHash, Tree )-import Storage.Hashed.Hash( encodeBase16, Hash(..) )--applyHashed'- :: (Apply p, ApplyState p ~ Tree) => Hash -> p C(x y) -> IO String-applyHashed' root p = do case root of- (SHA256 _) -> return ()- _ -> fail $ "Cannot handle hash: " ++ show root- s <- readDarcsHashedNosize "_darcs/pristine.hashed" root- (_, t) <- (hashedTreeIO (apply p) s "_darcs/pristine.hashed")- 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` \(_ :: IOException) -> do- hPutStrLn stderr warn- inv <- gzReadFilePS invpath- let oldroot = BC.pack $ inv2pris inv- oldroot_hash = decodeDarcsHash oldroot- oldroot_size = decodeDarcsSize oldroot- old <- readDarcsHashed "_darcs/pristine.hashed" (oldroot_size, oldroot_hash)- root <- writeDarcsHashed old "_darcs/pristine.hashed"- let newroot = BC.unpack $ encodeBase16 root- writeDocBinFile invpath $ pris2inv newroot inv- cleanHashdir (Ca []) HashedPristineDir [newroot]- hPutStrLn stderr "Pristine conversion done..."- applyHashed' root p- where invpath = darcsdir ++ "/hashed_inventory"- hash = decodeDarcsHash $ BC.pack h- warn = "WARNING: Doing a one-time conversion of pristine format.\n" ++- "This may take a while. The new format is backwards-compatible."--revertTentativeChanges :: IO ()-revertTentativeChanges =- do cloneFile (darcsdir++"/hashed_inventory") (darcsdir++"/tentative_hashed_inventory")- i <- gzReadFilePS (darcsdir++"/hashed_inventory")- writeBinFile (darcsdir++"/tentative_pristine") $ "pristine:" ++ inv2pris i--finalizeTentativeChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> Compression -> IO ()-finalizeTentativeChanges r compr =- do let t = darcsdir++"/tentative_hashed_inventory"- -- first let's optimize it...- debugMessage "Optimizing the inventory..."- ps <- readTentativeRepo r "."- writeTentativeInventory (extractCache r) compr ps- -- then we'll add in the pristine cache,- i <- gzReadFilePS t- p <- gzReadFilePS $ darcsdir++"/tentative_pristine"- writeDocBinFile t $ pris2inv (inv2pris p) i- -- and rename it to its final value- renameFile t $ darcsdir++"/hashed_inventory"- -- note: in general we can't clean the pristine cache, because a- -- simultaneous get might be in progress--readHashedPristineRoot :: Repository p C(r u t) -> IO (Maybe String)-readHashedPristineRoot (Repo d _ _ _) =- withCurrentDirectory d $ do- i <- (Just `fmap` gzReadFilePS (darcsdir++"/hashed_inventory")) `catch` (\(_ :: IOException) -> return Nothing)- return $ inv2pris `fmap` i--cleanPristine :: Repository p C(r u t) -> IO ()-cleanPristine r@(Repo d _ _ _) = withCurrentDirectory d $- do -- we'll remove obsolete bits of our pristine cache- debugMessage "Cleaning out the pristine cache..."- i <- gzReadFilePS (darcsdir++"/hashed_inventory")- cleanHashdir (extractCache r) HashedPristineDir [inv2pris i]--addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression- -> PatchInfoAnd p C(x y) -> IO FilePath-addToSpecificInventory invPath c compr p = do- let invFile = darcsdir </> invPath- hash <- snd `fmap` writePatchIfNecessary c compr p- appendDocBinFile invFile $ showPatchInfo $ info p- appendBinFile invFile $ "\nhash: " ++ hash ++ "\n"- return $ darcsdir </> "patches" </> hash--addToTentativeInventory :: RepoPatch p => Cache -> Compression- -> PatchInfoAnd p C(x y) -> IO FilePath-addToTentativeInventory = addToSpecificInventory "tentative_hashed_inventory"--removeFromTentativeInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> Compression- -> FL (PatchInfoAnd p) C(x t) -> IO ()-removeFromTentativeInventory repo compr to_remove =- -- FIXME: This algorithm should be *far* simpler. All we need do is- -- to to remove the patches from a patchset and then write that- -- patchset. The commutation behavior of PatchInfoAnd should track- -- which patches need to be rewritten for us.- do allpatches <- readTentativeRepo repo "."- _ :> skipped <- return $ commuteToEnd (reverseFL to_remove) allpatches- okay <- simpleRemoveFromTentativeInventory repo compr- (mapFL info to_remove ++ mapRL info skipped)- unless okay $ bug "bug in HashedRepo.removeFromTentativeInventory"- sequence_ $ mapFL (addToTentativeInventory (extractCache repo) compr) (reverseRL skipped)--simpleRemoveFromTentativeInventory :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree) =>- Repository p C(r u t) -> Compression -> [PatchInfo] -> IO Bool-simpleRemoveFromTentativeInventory repo compr pis = do- inv <- readTentativeRepo repo "."- case cut_inv pis inv of- Nothing -> return False- Just (Sealed inv') -> do writeTentativeInventory (extractCache repo) compr inv'- return True- where cut_inv :: [PatchInfo] -> PatchSet p C(start x) -> Maybe (SealedPatchSet p C(start))- cut_inv [] x = Just $ seal x- cut_inv x (PatchSet NilRL (Tagged t _ ps :<: ts))- = cut_inv x (PatchSet (t :<: ps) ts)- cut_inv xs (PatchSet (hp:<:r) ts)- | info hp `elem` xs = cut_inv (info hp `delete` xs) (PatchSet r ts)- cut_inv _ _ = Nothing--writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String-writeHashFile c compr subdir d = do debugMessage $ "Writing hash file to "++(hashedDir subdir)- writeFileUsingCache c compr subdir $ renderPS d--readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> String -> IO (PatchSet p C(Origin r))-readRepo repo d = readRepoUsingSpecificInventory "hashed_inventory" repo d--readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> String -> IO (PatchSet p C(Origin t))-readTentativeRepo repo d =- readRepoUsingSpecificInventory "tentative_hashed_inventory" repo d--readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p C(r u t)- -> String -> IO (PatchSet p C(Origin s))-readRepoUsingSpecificInventory invPath repo dir = do- realdir <- toPath `fmap` ioAbsoluteOrRemote dir- Sealed ps <- readRepoPrivate (extractCache repo) realdir invPath `catch`- (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir)- ioError e)- return $ unsafeCoerceP ps--readRepoPrivate :: (RepoPatch p, ApplyState p ~ Tree) => Cache -> FilePath -> FilePath -> IO (SealedPatchSet p C(Origin))-readRepoPrivate cache d iname = do- inventory <- readInventoryPrivate cache (d </> "_darcs") iname- readRepoFromInventoryList cache inventory--readRepoFromInventoryList :: (RepoPatch p, ApplyState p ~ Tree) => Cache- -> (Maybe String, [(PatchInfo, String)]) -> IO (SealedPatchSet p C(Origin))-readRepoFromInventoryList cache inventory = parseinvs inventory- where read_patches :: (RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)]- -> IO (Sealed (RL (PatchInfoAnd p) C(x)))- read_patches [] = return $ seal NilRL- read_patches allis@((i1,h1):is1) =- lift2Sealed (\p rest -> i1 `patchInfoAndPatch` p :<: rest)- (rp is1)- (createHashed h1 (const $ speculate h1 allis >> parse i1 h1))- where rp :: (RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)]- -> IO (Sealed (RL (PatchInfoAnd p) C(x)))- rp [] = return $ seal NilRL- rp [(i,h),(il,hl)] =- lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)- (rp [(il,hl)])- (createHashed h (const $ speculate h (reverse allis) >> parse i h))- rp ((i,h):is) = lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)- (rp is)- (createHashed h (parse i))- read_tag :: (RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String) -> IO (Sealed (PatchInfoAnd p C(x)))- read_tag (i,h) = mapSeal (patchInfoAndPatch i) `fmap` createHashed h (parse i)- speculate :: String -> [(PatchInfo, String)] -> IO ()- speculate h is =- do already_got_one <- peekInCache cache HashedPatchesDir h- unless already_got_one $- speculateFilesUsingCache cache HashedPatchesDir (map snd is)- parse :: Patchy p => PatchInfo -> String -> IO (Sealed (p C(x)))- parse i h = do debugMessage ("Reading patch file: "++ show (humanFriendly i))- (fn,ps) <- fetchFileUsingCache cache HashedPatchesDir h- case readPatch ps of- Just p -> return p- Nothing -> fail $ unlines ["Couldn't parse file "++fn,- "which is patch",- renderString $ humanFriendly i]- parseinvs :: (RepoPatch p, ApplyState p ~ Tree) => (Maybe String, [(PatchInfo, String)])- -> IO (SealedPatchSet p C(Origin))- parseinvs (Nothing, ris) = mapSeal (\ps -> PatchSet ps NilRL)- `fmap` (read_patches $ reverse ris)- parseinvs (Just h, []) = bug $ "bad inventory "++h++" (no tag) in parseinvs!"- parseinvs (Just h, t:ris) = do Sealed ts <- unseal seal `fmap`- unsafeInterleaveIO (read_ts t h)- Sealed ps <- unseal seal `fmap`- unsafeInterleaveIO (read_patches $- reverse ris)- return $ seal $ PatchSet ps ts- read_ts :: (RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String) -> String -> IO (Sealed (RL (Tagged p) C(Origin)))- read_ts tag0 h0 =- do contents <- unsafeInterleaveIO $ readTaggedInventory cache h0- let is = reverse $ case contents of (Just _, _:ris0) -> ris0- (Nothing, ris0) -> ris0- (Just _, []) -> bug "inventory without tag!!!!"- Sealed ts <- fmap (unseal seal) $ unsafeInterleaveIO $- case contents of- (Just h', t':_) -> read_ts t' h'- (Just _, []) -> bug "inventory without tag!!!!"- (Nothing, _) -> return $ seal NilRL- Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches is)- Sealed tag00 <- read_tag tag0- return $ seal $ Tagged tag00 (Just h0) ps :<: ts- lift2Sealed :: (FORALL(y z) q C(y z) -> p C(x y) -> r C(x z))- -> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b))))- -> IO (Sealed (r C(x)))- lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap`- unsafeInterleaveIO iox- Sealed y <- unseal seal `fmap`- unsafeInterleaveIO ioy- return $ seal $ f y x--readTaggedInventory :: Cache -> String -> IO (Maybe String, [(PatchInfo, String)])-readTaggedInventory cache ihash = do- (fn,i_and_p) <- fetchFileUsingCache cache HashedInventoriesDir ihash- let i = skipPristine i_and_p- (rest,str) <- case BC.break ((==)'\n') i of- (swt,pistr) | swt == BC.pack "Starting with inventory:" ->- case BC.break ((==)'\n') $ B.tail pistr of- (h,thisinv) | okayHash hash -> return (Just hash, thisinv)- where hash = BC.unpack h- _ -> fail $ "Bad hash in file " ++ fn- _ -> return (Nothing,i)- return (rest, readPatchIds str)--copyRepo :: RepoPatch p => Repository p C(r u t) -> RemoteDarcs -> String -> IO ()-copyRepo repo@(Repo outr _ _ _) remote inr = do- createDirectoryIfMissing False (outr++"/"++darcsdir++"/inventories")- copyFileOrUrl remote (inr </> darcsdir </> "hashed_inventory")- (outr </> darcsdir </> "hashed_inventory")- Uncachable -- no need to copy anything but hashed_inventory!- copySources repo inr- debugMessage "Done copying hashed inventory."---- |'copySources' copies the prefs/sources file to the local repo, from the--- remote, having first filtered the local filesystem sources.-copySources :: RepoPatch p => Repository p C(r u t) -> String -> IO ()-copySources repo@(Repo outr _ _ _) inr = do- let repoCache = extractCache $ modifyCache repo dropNonRepos- appendBinFile (outr++"/"++darcsdir++"/prefs/sources") (show $ repo2cache inr `unionCaches` repoCache )- where- dropNonRepos (Ca cache) = Ca $ filter notRepo cache- notRepo xs = case xs of- Cache DarcsCache.Directory _ _ -> False- Cache _ DarcsCache.Writable _ -> False- _ -> True--writeAndReadPatch :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y)- -> IO (PatchInfoAnd p C(x y))-writeAndReadPatch c compr p = do (i,h) <- writePatchIfNecessary c compr p- unsafeInterleaveIO $ readp h i- where parse i h = do debugMessage ("Rereading patch file: "++ show (humanFriendly i))- (fn,ps) <- fetchFileUsingCache c HashedPatchesDir h- case readPatch ps of- Just x -> return x- Nothing -> fail $ unlines ["Couldn't parse patch file "++fn,- "which is",- renderString $ humanFriendly i]- readp h i = do Sealed x <- createHashed h (parse i)- return $ patchInfoAndPatch i $ unsafeCoerceP x--writeTentativeInventory :: RepoPatch p => Cache -> Compression -> PatchSet p C(Origin x) -> IO ()-writeTentativeInventory cache compr = writeEitherInventory cache compr "tentative_hashed_inventory"--writeEitherInventory :: RepoPatch p => Cache -> Compression -> String -> PatchSet p C(Origin x) -> IO ()-writeEitherInventory cache compr iname x =- do debugMessage "in writeEitherInventory..."- createDirectoryIfMissing False $ "_darcs/inventories"- let k = "Writing inventory"- beginTedious k- hsh <- writeInventoryPrivate cache k compr $ slightlyOptimizePatchset x- endTedious k- debugMessage "still in writeEitherInventory..."- case hsh of- Nothing -> writeBinFile ("_darcs" </> iname) ""- Just h -> fmap snd (fetchFileUsingCache cache HashedInventoriesDir h)- >>= writeAtomicFilePS ("_darcs" </> iname)--writeInventoryPrivate :: RepoPatch p => Cache -> String -> Compression- -> PatchSet p C(Origin x) -> IO (Maybe String)-writeInventoryPrivate _ _ _ (PatchSet NilRL NilRL) = return Nothing-writeInventoryPrivate cache _ compr (PatchSet x NilRL) =- do inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) x- let inventorylist = hcat (map pihash $ reverse inventory)- hash <- writeHashFile cache compr HashedInventoriesDir inventorylist- return $ Just hash-writeInventoryPrivate cache k compr (PatchSet x xs@(Tagged t _ _ :<: _)) =- do resthash <- write_ts xs- finishedOneIO k $ maybe "" id resthash- inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) (x+<+t:<:NilRL)- let inventorylist = hcat (map pihash $ reverse inventory)- inventorycontents =- case resthash of- Just h -> text ("Starting with inventory:\n"++h) $$ inventorylist- Nothing -> inventorylist- hash <- writeHashFile cache compr HashedInventoriesDir inventorycontents- return $ Just hash- where write_ts :: RepoPatch p => RL (Tagged p) C(Origin x) -> IO (Maybe String)- write_ts (Tagged _ (Just h) _ :<: _) = return (Just h) -- already written!- write_ts (Tagged _ Nothing pps :<: tts) =- writeInventoryPrivate cache k compr $ PatchSet pps tts- write_ts NilRL = return Nothing--writePatchIfNecessary :: RepoPatch p => Cache -> Compression- -> PatchInfoAnd p C(x y) -> IO (PatchInfo, String)-writePatchIfNecessary c compr hp =- seq infohp $ case extractHash hp of- Right h -> return (infohp, h)- Left p -> (\h -> (infohp, h)) `fmap`- writeHashFile c compr HashedPatchesDir (showPatch p)- where infohp = info hp--pihash :: (PatchInfo,String) -> Doc-pihash (pinf,hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n")--readInventoryPrivate :: Cache -> String -> String -> IO (Maybe String, [(PatchInfo, String)])-readInventoryPrivate _ d iname = do- i <- skipPristine `fmap` gzFetchFilePS (d </> iname) Uncachable- (rest,str) <- case BC.break ((==)'\n') i of- (swt,pistr) | swt == BC.pack "Starting with inventory:" ->- case BC.break ((==)'\n') $ B.tail pistr of- (h,thisinv) | okayHash hash -> return (Just hash, thisinv)- where hash = BC.unpack h- _ -> fail $ "Bad hash in " ++ toPath d ++ "/_darcs/" ++ iname- _ -> return (Nothing, i)- return (rest, readPatchIds str)--listInventories :: IO [String]-listInventories = do- x <- fst <$> readInventoryPrivate (Ca []) darcsdir "hashed_inventory"- maybe (return []) f x- where- f i = do- x <- fst <$> readInventoryPrivate (Ca []) (darcsdir </> "inventories") i- (i :) <$> maybe (return []) f x---- | 'readPatchIds inventory' parses the content of a hashed_inventory file--- after the "pristine:" and "Starting with inventory:" header lines have--- been removed. The second value in the resulting tuples is the file hash--- of the associated patch (the "hash:" line).-readPatchIds :: B.ByteString -> [(PatchInfo, String)]-readPatchIds inv | B.null inv = []-readPatchIds inv = case parseStrictly readPatchInfo inv of- Nothing -> []- Just (pinfo,r) ->- case readHash r of- Nothing -> []- Just (h,r') -> (pinfo,h) : readPatchIds r'--readHash :: B.ByteString -> Maybe (String, B.ByteString)-readHash s = let s' = dropSpace s- (l,r) = BC.break ((==)'\n') s'- (kw,h) = BC.break ((==)' ') l- in if kw /= BC.pack "hash:" || B.length h <= 1- then Nothing- else Just (BC.unpack $ B.tail h,r)--applyPristine :: (ApplyState q ~ Tree, Patchy q) => String -> String -> q C(x y) -> IO ()-applyPristine d iname p =- do i <- gzReadFilePS (d++"/"++iname)- h <- applyHashed (inv2pris i) p- writeDocBinFile (d++"/"++iname) $ pris2inv h i--applyToTentativePristine :: (ApplyState q ~ Tree, Patchy q) => q C(x y) -> IO ()-applyToTentativePristine p = applyPristine "." (darcsdir++"/tentative_pristine") p--copyPristine :: Cache -> Compression -> String -> String -> IO ()-copyPristine c compr d iname = do- i <- fetchFilePS (d++"/"++iname) Uncachable- debugMessage $ "Copying hashed pristine tree: "++inv2pris i- let k = "Copying pristine"- beginTedious k- copyHashed k c compr $ inv2pris i- endTedious k--copyPartialsPristine :: FilePathLike fp =>- Cache -> Compression -> String -> String -> [fp] -> IO ()-copyPartialsPristine c compr d iname fps =- do i <- fetchFilePS (d++"/"++iname) Uncachable- copyPartialsHashed c compr (inv2pris i) fps--inv2pris :: B.ByteString -> String-inv2pris inv | B.take pristineNameLength inv == pristineName =- case takeHash $ B.drop pristineNameLength inv of- Just (h,_) -> h- Nothing -> error "Bad hash in inventory!"- | otherwise = sha256sum B.empty--pris2inv :: String -> B.ByteString -> Doc-pris2inv h inv = invisiblePS pristineName <> text h $$ invisiblePS (skipPristine inv)--pristineName :: B.ByteString-pristineName = BC.pack "pristine:"--skipPristine :: B.ByteString -> B.ByteString-skipPristine ps- | B.take pristineNameLength ps == pristineName = B.drop 1 $ BC.dropWhile (/= '\n') $- B.drop pristineNameLength ps- | otherwise = ps--pristineNameLength :: Int-pristineNameLength = B.length pristineName+module Darcs.Repository.HashedRepo+ ( inventoriesDir+ , pristineDir+ , patchesDir+ , hashedInventory+ , revertTentativeChanges+ , finalizeTentativeChanges+ , cleanPristine+ , filterDirContents+ , cleanInventories+ , cleanPatches+ , copyPristine+ , copyPartialsPristine+ , applyToTentativePristine+ , addToSpecificInventory+ , addToTentativeInventory+ , removeFromTentativeInventory+ , readRepo+ , readTentativeRepo+ , readRepoUsingSpecificInventory+ , writeAndReadPatch+ , writeTentativeInventory+ , copyHashedInventory+ , readHashedPristineRoot+ , pris2inv+ , inv2pris+ , copySources+ , listInventories+ , listInventoriesLocal+ , listInventoriesRepoDir+ , listPatchesLocalBucketed+ , writePatchIfNecessary+ , readRepoFromInventoryList+ , readPatchIds+ , set+ , unset+ ) where++#include "impossible.h"++import Prelude hiding ( catch )++import Control.Applicative ( (<$>) )+import Control.Arrow ( (&&&) )+import Control.Exception ( catch, IOException )+import Control.Monad ( unless )+import Data.Maybe+import qualified Data.ByteString as B ( null, length, empty ,tail, drop,+ ByteString, splitAt )+import qualified Data.ByteString.Char8 as BC ( unpack, dropWhile, break, pack,+ ByteString )+import Data.List ( delete )+import qualified Data.Set as Set+import Storage.Hashed.Darcs( hashedTreeIO, readDarcsHashedNosize,+ readDarcsHashed, writeDarcsHashed,+ decodeDarcsHash, decodeDarcsSize )+import Storage.Hashed.Tree( treeHash, Tree )+import Storage.Hashed.Hash( encodeBase16, Hash(..) )+import System.Directory ( createDirectoryIfMissing, getDirectoryContents+ , doesFileExist, doesDirectoryExist )+import System.FilePath.Posix( (</>) )+import System.IO.Unsafe ( unsafeInterleaveIO )+import System.IO ( stderr, hPutStrLn )++import Darcs.Util.Printer.Color ( showDoc )+import Darcs.Repository.External+ ( copyFileOrUrl+ , cloneFile+ , fetchFilePS+ , gzFetchFilePS+ , Cachable( Uncachable )+ )+import Darcs.Repository.Flags ( Compression, RemoteDarcs, WithWorkingDir )+import Darcs.Util.Global ( darcsdir )+import Darcs.Repository.Lock+ ( writeBinFile+ , writeDocBinFile+ , writeAtomicFilePS+ , appendBinFile+ , appendDocBinFile+ , removeFileMayNotExist+ )+import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin )++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, patchInfoAndPatch, info,+ extractHash, createHashed )+import Darcs.Patch ( RepoPatch, Patchy, showPatch, readPatch, apply )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.ReadMonads ( parseStrictly )+import Darcs.Patch.Depends ( commuteToEnd, slightlyOptimizePatchset )+import Darcs.Patch.Info ( PatchInfo, showPatchInfo, showPatchInfoUI,+ readPatchInfo )+import Darcs.Util.Path ( FilePathLike, ioAbsoluteOrRemote, toPath )+import Darcs.Repository.Cache ( Cache(..), CacheLoc(..), fetchFileUsingCache,+ speculateFilesUsingCache, writeFileUsingCache,+ unionCaches, repo2cache, okayHash, takeHash,+ HashedDir(..), hashedDir, peekInCache, bucketFolder )+import qualified Darcs.Repository.Cache as DarcsCache+import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed,+ cleanHashdir )+import Darcs.Repository.InternalTypes ( Repository(..), extractCache,+ modifyCache )+import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Patch.Witnesses.Ordered+ ( reverseRL, reverseFL, (+<+), FL(..), RL(..),+ (:>)(..), mapRL, mapFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )++import Darcs.Util.ByteString ( gzReadFilePS, dropSpace )+import Darcs.Util.Crypt.SHA256 ( sha256sum )+import Darcs.Util.Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text,+ invisiblePS, RenderMode(..) )+import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage, finishedOneIO )+import Darcs.Util.Workaround ( renameFile )+import Darcs.Repository.Prefs ( globalCacheDir )++makeDarcsdirPath :: String -> String+makeDarcsdirPath name = darcsdir </> name++hashedInventory, hashedInventoryPath :: String+hashedInventory = "hashed_inventory"+hashedInventoryPath = makeDarcsdirPath hashedInventory++tentativeHashedInventory, tentativeHashedInventoryPath :: String+tentativeHashedInventory = "tentative_hashed_inventory"+tentativeHashedInventoryPath = makeDarcsdirPath tentativeHashedInventory++inventoriesDir, inventoriesDirPath :: String+inventoriesDir = "inventories"+inventoriesDirPath = makeDarcsdirPath inventoriesDir++pristineDir, tentativePristinePath, pristineDirPath :: String+tentativePristinePath = makeDarcsdirPath "tentative_pristine"+pristineDir = "pristine.hashed"+pristineDirPath = makeDarcsdirPath pristineDir++patchesDir, patchesDirPath :: String+patchesDir = "patches"+patchesDirPath = makeDarcsdirPath patchesDir++pristineNamePrefix :: String+pristineNamePrefix = "pristine:"++pristineName :: B.ByteString+pristineName = BC.pack pristineNamePrefix++-- | 'applyToHashedPristine' takes a root hash, a patch @p@ and attempts to+-- apply the patch to the 'Tree' identified by @h@. If we encounter an old,+-- size-prefixed pristine, we first convert it to the non-size-prefixed format,+-- then apply the patch.+applyToHashedPristine :: (ApplyState p ~ Tree, Patchy p) => String -> p wX wY+ -> IO String+applyToHashedPristine h p = applyOrConvertOldPristineAndApply+ where+ applyOrConvertOldPristineAndApply =+ tryApply hash `catch` \(_ :: IOException) -> handleOldPristineAndApply++ hash = decodeDarcsHash $ BC.pack h++ failOnMalformedRoot (SHA256 _) = return ()+ failOnMalformedRoot root = fail $ "Cannot handle hash: " ++ show root++ hash2root = BC.unpack . encodeBase16++ tryApply :: Hash -> IO String+ tryApply root = do+ failOnMalformedRoot root+ -- Read a non-size-prefixed pristine, failing if we encounter one.+ tree <- readDarcsHashedNosize pristineDirPath root+ (_, updatedTree) <- hashedTreeIO (apply p) tree pristineDirPath+ return . hash2root $ treeHash updatedTree++ warn = "WARNING: Doing a one-time conversion of pristine format.\n"+ ++ "This may take a while. The new format is backwards-compatible."++ handleOldPristineAndApply = do+ hPutStrLn stderr warn+ inv <- gzReadFilePS hashedInventoryPath+ let oldroot = BC.pack $ inv2pris inv+ oldrootSizeandHash = (decodeDarcsSize &&& decodeDarcsHash) oldroot+ -- Read the old size-prefixed pristine tree+ old <- readDarcsHashed pristineDirPath oldrootSizeandHash+ -- Write out the pristine tree as a non-size-prefixed pristine.+ root <- writeDarcsHashed old pristineDirPath+ let newroot = hash2root root+ -- Write out the new inventory.+ writeDocBinFile hashedInventoryPath $ pris2inv newroot inv+ cleanHashdir (Ca []) HashedPristineDir [newroot]+ hPutStrLn stderr "Pristine conversion done..."+ -- Retry applying the patch, which should now succeed.+ tryApply root++-- |revertTentativeChanges swaps the tentative and "real" hashed inventory+-- files, and then updates the tentative pristine with the "real" inventory+-- hash.+revertTentativeChanges :: IO ()+revertTentativeChanges = do+ cloneFile hashedInventoryPath tentativeHashedInventoryPath+ i <- gzReadFilePS hashedInventoryPath+ writeBinFile tentativePristinePath $ pristineNamePrefix ++ inv2pris i++-- |finalizeTentativeChanges trys to atomically swap the tentative+-- inventory/pristine pointers with the "real" pointers; it first re-reads the+-- inventory to optimize it, presumably to take account of any new tags, and+-- then writes out the new tentative inventory, and finally does the atomic+-- swap. In general, we can't clean the pristine cache at the same time, since+-- a simultaneous get might be in progress.+finalizeTentativeChanges :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> Compression -> IO ()+finalizeTentativeChanges r compr = do+ debugMessage "Optimizing the inventory..."+ -- Read the tentative patches+ ps <- readTentativeRepo r "."+ writeTentativeInventory (extractCache r) compr ps+ i <- gzReadFilePS tentativeHashedInventoryPath+ p <- gzReadFilePS tentativePristinePath+ -- Write out the "optimised" tentative inventory.+ writeDocBinFile tentativeHashedInventoryPath $ pris2inv (inv2pris p) i+ -- Atomically swap.+ renameFile tentativeHashedInventoryPath hashedInventoryPath++-- |readHashedPristineRoot attempts to read the pristine hash from the current+-- inventory, returning Nothing if it cannot do so.+readHashedPristineRoot :: Repository p wR wU wT -> IO (Maybe String)+readHashedPristineRoot (Repo d _ _ _) = withCurrentDirectory d $ do+ i <- (Just <$> gzReadFilePS hashedInventoryPath)+ `catch` (\(_ :: IOException) -> return Nothing)+ return $ inv2pris <$> i++-- |cleanPristine removes any obsolete (unreferenced) entries in the pristine+-- cache.+cleanPristine :: Repository p wR wU wT -> IO ()+cleanPristine r@(Repo d _ _ _) = withCurrentDirectory d $ do+ debugMessage "Cleaning out the pristine cache..."+ i <- gzReadFilePS hashedInventoryPath+ cleanHashdir (extractCache r) HashedPristineDir [inv2pris i]++-- |filterDirContents returns the contents of the directory @d@+-- except files whose names begin with '.' (directories . and ..,+-- hidden files) and files whose names are filtered by the function @f@, if+-- @dir@ is empty, no paths are returned.+filterDirContents :: FilePath -> (FilePath -> Bool) -> IO [FilePath]+filterDirContents d f = do+ let realPath = makeDarcsdirPath d+ exists <- doesDirectoryExist realPath+ if exists+ then filter (\x -> head x /= '.' && f x) <$>+ getDirectoryContents realPath+ else return []++-- |set converts a list of strings into a set of Char8 ByteStrings for faster+-- Set operations.+set :: [String] -> Set.Set BC.ByteString+set = Set.fromList . map BC.pack++-- |unset is the inverse of set.+unset :: Set.Set BC.ByteString -> [String]+unset = map BC.unpack . Set.toList++-- |cleanInventories removes any obsolete (unreferenced) files in the+-- inventories directory.+cleanInventories :: Repository p wR wU wT -> IO ()+cleanInventories _ = do+ debugMessage "Cleaning out inventories..."+ hs <- listInventoriesLocal+ fs <- filterDirContents inventoriesDir (const True)+ mapM_ (removeFileMayNotExist . (inventoriesDirPath </>))+ (unset $ (set fs) `Set.difference` (set hs))++-- |specialPatches list of special patch files that may exist in the directory+-- _darcs/patches/.+specialPatches :: [FilePath]+specialPatches = ["unrevert", "pending", "pending.tentative"]++-- |cleanPatches removes any obsolete (unreferenced) files in the+-- patches directory.+cleanPatches :: Repository p wR wU wT -> IO ()+cleanPatches _ = do+ debugMessage "Cleaning out patches..."+ hs <- listPatchesLocal darcsdir+ fs <- filterDirContents patchesDir (`notElem` specialPatches)+ mapM_ (removeFileMayNotExist . (patchesDirPath </>))+ (unset $ (set fs) `Set.difference` (set hs))+++-- |addToSpecificInventory adds a patch to a specific inventory file, and+-- returns the FilePath whichs corresponds to the written-out patch.+addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression+ -> PatchInfoAnd p wX wY -> IO FilePath+addToSpecificInventory invPath c compr p = do+ let invFile = darcsdir </> invPath+ hash <- snd <$> writePatchIfNecessary c compr p+ appendDocBinFile invFile $ showPatchInfo $ info p+ appendBinFile invFile $ "\nhash: " ++ hash ++ "\n"+ return $ darcsdir </> "patches" </> hash++addToTentativeInventory :: RepoPatch p => Cache -> Compression+ -> PatchInfoAnd p wX wY -> IO FilePath+addToTentativeInventory = addToSpecificInventory tentativeHashedInventory++-- |removeFromTentativeInventory attempts to remove an FL of patches from the+-- tentative inventory. This is used for commands that wish to modify+-- already-recorded patches.+removeFromTentativeInventory :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> Compression+ -> FL (PatchInfoAnd p) wX wT -> IO ()+removeFromTentativeInventory repo compr to_remove = do+ -- FIXME: This algorithm should be *far* simpler. All we need do is to to+ -- remove the patches from a patchset and then write that patchset. The+ -- commutation behavior of PatchInfoAnd should track which patches need to+ -- be rewritten for us.+ allpatches <- readTentativeRepo repo "."+ _ :> skipped <- return $ commuteToEnd (reverseFL to_remove) allpatches+ okay <- simpleRemoveFromTentativeInventory $+ mapFL info to_remove ++ mapRL info skipped+ unless okay $ bug "bug in HashedRepo.removeFromTentativeInventory"+ sequence_ $ mapFL (addToTentativeInventory (extractCache repo) compr)+ (reverseRL skipped)+ where+ simpleRemoveFromTentativeInventory :: [PatchInfo] -> IO Bool+ simpleRemoveFromTentativeInventory pis = do+ inv <- readTentativeRepo repo "."+ case cut_inv pis inv of+ Nothing -> return False+ Just (Sealed inv') -> do+ writeTentativeInventory (extractCache repo) compr inv'+ return True+ cut_inv :: [PatchInfo] -> PatchSet p wStart wX+ -> Maybe (SealedPatchSet p wStart)+ cut_inv [] x = Just $ seal x+ cut_inv x (PatchSet NilRL (Tagged t _ ps :<: ts)) =+ cut_inv x (PatchSet (t :<: ps) ts)+ cut_inv xs (PatchSet (hp:<:r) ts) | info hp `elem` xs =+ cut_inv (info hp `delete` xs) (PatchSet r ts)+ cut_inv _ _ = Nothing++-- |writeHashFile takes a Doc and writes it as a hash-named file, returning the+-- filename that the contents were written to.+writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String+writeHashFile c compr subdir d = do+ debugMessage $ "Writing hash file to " ++ hashedDir subdir+ writeFileUsingCache c compr subdir $ renderPS Standard d++-- |readRepo returns the "current" repo patchset.+readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT+ -> String -> IO (PatchSet p Origin wR)+readRepo = readRepoUsingSpecificInventory hashedInventory++-- |readRepo returns the tentative repo patchset.+readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> String+ -> IO (PatchSet p Origin wT)+readTentativeRepo = readRepoUsingSpecificInventory tentativeHashedInventory++-- |readRepoUsingSpecificInventory uses the inventory at @invPath@ to read the+-- repository @repo@.+readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree)+ => String -> Repository p wR wU wT+ -> String -> IO (PatchSet p Origin wS)+readRepoUsingSpecificInventory invPath repo dir = do+ realdir <- toPath <$> ioAbsoluteOrRemote dir+ Sealed ps <- readRepoPrivate (extractCache repo) realdir invPath+ `catch` \e -> do+ hPutStrLn stderr ("Invalid repository: " ++ realdir)+ ioError e+ return $ unsafeCoerceP ps+ where+ readRepoPrivate :: (RepoPatch p, ApplyState p ~ Tree) => Cache -> FilePath+ -> FilePath -> IO (SealedPatchSet p Origin)+ readRepoPrivate cache d iname = do+ inventory <- readInventoryPrivate (d </> darcsdir) iname+ readRepoFromInventoryList cache inventory++-- |readRepoFromInventoryList allows the caller to provide an optional "from+-- inventory" hash, and a list of info/hash pairs that identify a list of+-- patches, returning a patchset of the resulting repo.+readRepoFromInventoryList :: (RepoPatch p, ApplyState p ~ Tree) => Cache+ -> (Maybe String, [(PatchInfo, String)])+ -> IO (SealedPatchSet p Origin)+readRepoFromInventoryList cache = parseinvs+ where+ speculateAndParse h is i = speculate h is >> parse i h++ read_patches :: (RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)]+ -> IO (Sealed (RL (PatchInfoAnd p) wX))+ read_patches [] = return $ seal NilRL+ read_patches allis@((i1, h1) : is1) =+ lift2Sealed (\p rest -> i1 `patchInfoAndPatch` p :<: rest) (rp is1)+ (createHashed h1 (const $ speculateAndParse h1 allis i1))+ where+ rp :: (RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)]+ -> IO (Sealed (RL (PatchInfoAnd p) wX))+ rp [] = return $ seal NilRL+ rp [(i, h), (il, hl)] =+ lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)+ (rp [(il, hl)])+ (createHashed h+ (const $ speculateAndParse h (reverse allis) i))+ rp ((i, h) : is) =+ lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)+ (rp is)+ (createHashed h (parse i))++ read_tag :: (RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String)+ -> IO (Sealed (PatchInfoAnd p wX))+ read_tag (i, h) =+ mapSeal (patchInfoAndPatch i) <$> createHashed h (parse i)++ speculate :: String -> [(PatchInfo, String)] -> IO ()+ speculate h is = do+ already_got_one <- peekInCache cache HashedPatchesDir h+ unless already_got_one $+ speculateFilesUsingCache cache HashedPatchesDir (map snd is)++ parse :: ReadPatch p => PatchInfo -> String -> IO (Sealed (p wX))+ parse i h = do+ debugMessage ("Reading patch file: "++ showDoc Encode (showPatchInfoUI i))+ (fn, ps) <- fetchFileUsingCache cache HashedPatchesDir h+ case readPatch ps of+ Just p -> return p+ Nothing -> fail $ unlines [ "Couldn't parse file " ++ fn+ , "which is patch"+ , renderString Encode $ showPatchInfoUI i ]++ parseinvs :: (RepoPatch p, ApplyState p ~ Tree)+ => (Maybe String, [(PatchInfo, String)])+ -> IO (SealedPatchSet p Origin)+ parseinvs (Nothing, ris) =+ mapSeal (flip PatchSet NilRL) <$> read_patches (reverse ris)+ parseinvs (Just h, []) =+ bug $ "bad inventory " ++ h ++ " (no tag) in parseinvs!"+ parseinvs (Just h, t : ris) = do+ Sealed ts <- unseal seal <$> unsafeInterleaveIO (read_ts t h)+ Sealed ps <- unseal seal <$>+ unsafeInterleaveIO (read_patches $ reverse ris)+ return $ seal $ PatchSet ps ts++ read_ts :: (RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String)+ -> String -> IO (Sealed (RL (Tagged p) Origin))+ read_ts tag0 h0 = do+ contents <- unsafeInterleaveIO $ readTaggedInventoryFromHash h0+ let is = reverse $ case contents of+ (Just _, _ : ris0) -> ris0+ (Nothing, ris0) -> ris0+ (Just _, []) -> bug "inventory without tag!"+ Sealed ts <- unseal seal <$>+ unsafeInterleaveIO+ (case contents of+ (Just h', t' : _) -> read_ts t' h'+ (Just _, []) -> bug "inventory without tag!"+ (Nothing, _) -> return $ seal NilRL)+ Sealed ps <- unseal seal <$> unsafeInterleaveIO (read_patches is)+ Sealed tag00 <- read_tag tag0+ return $ seal $ Tagged tag00 (Just h0) ps :<: ts++ readTaggedInventoryFromHash :: String+ -> IO (Maybe String, [(PatchInfo, String)])+ readTaggedInventoryFromHash invHash = do+ (fileName, pristineAndInventory) <-+ fetchFileUsingCache cache HashedInventoriesDir invHash+ readInventoryFromContent fileName pristineAndInventory++ lift2Sealed :: (forall wY wZ . q wY wZ -> p wX wY -> r wX wZ)+ -> IO (Sealed (p wX))+ -> (forall wB . IO (Sealed (q wB)))+ -> IO (Sealed (r wX))+ lift2Sealed f iox ioy = do+ Sealed x <- unseal seal <$> unsafeInterleaveIO iox+ Sealed y <- unseal seal <$> unsafeInterleaveIO ioy+ return $ seal $ f y x++-- |readInventoryPrivate reads the inventory with name @invName@ in @dir@.+readInventoryPrivate :: String -> String+ -> IO (Maybe String, [(PatchInfo, String)])+readInventoryPrivate dir invName = do+ inv <- skipPristine <$> gzFetchFilePS (dir </> invName) Uncachable+ readInventoryFromContent (toPath dir ++ "/" ++ darcsdir ++ invName) inv++-- |readInventoryFromContent extracts an inventory from the content of an+-- inventory file, who's path is @fileName@.+readInventoryFromContent :: FilePath -> B.ByteString+ -> IO (Maybe String, [(PatchInfo, String)])+readInventoryFromContent fileName pristineAndInventory = do+ (hash, patchIds) <-+ if mbStartingWith == BC.pack "Starting with inventory:"+ then let (hash, pids) = BC.break ('\n' ==) $ B.tail pistr+ hashStr = BC.unpack hash in+ if okayHash hashStr+ then return (Just hashStr, pids)+ else fail $ "Bad hash in file " ++ fileName+ else return (Nothing, inventory)+ return (hash, readPatchIds patchIds)+ where+ inventory = skipPristine pristineAndInventory+ (mbStartingWith, pistr) = BC.break ('\n' ==) inventory++-- |copyRepo copies the hashed inventory of @repo@ to the repository located at+-- @remote@.+copyHashedInventory :: RepoPatch p => Repository p wR wU wT -> RemoteDarcs -> String -> IO ()+copyHashedInventory (Repo outr _ _ _) remote inr = do+ createDirectoryIfMissing False (outr ++ "/" ++ inventoriesDirPath)+ copyFileOrUrl remote (inr </> darcsdir </> hashedInventory)+ (outr </> darcsdir </> hashedInventory)+ Uncachable -- no need to copy anything but hashed_inventory!+ debugMessage "Done copying hashed inventory."++-- |'copySources' copies the prefs/sources file to the local repo, from the+-- remote, having first filtered the local filesystem sources.+copySources :: RepoPatch p => Repository p wR wU wT -> String -> IO ()+copySources repo@(Repo outr _ _ _) inr = do+ let repoCache = extractCache $ modifyCache repo dropNonRepos+ appendBinFile (outr ++ "/" ++ darcsdir ++ "/prefs/sources")+ (show $ repo2cache inr `unionCaches` repoCache )+ debugMessage "Done copying and filtering pref/sources."+ where+ dropNonRepos (Ca cache) = Ca $ filter notRepo cache+ notRepo xs = case xs of+ Cache DarcsCache.Directory _ _ -> False+ Cache _ DarcsCache.Writable _ -> False+ _ -> True++-- |writeAndReadPatch makes a patch lazy, by writing it out to disk (thus+-- forcing it), and then re-reads the patch lazily.+writeAndReadPatch :: RepoPatch p => Cache -> Compression+ -> PatchInfoAnd p wX wY -> IO (PatchInfoAnd p wX wY)+writeAndReadPatch c compr p = do+ (i, h) <- writePatchIfNecessary c compr p+ unsafeInterleaveIO $ readp h i+ where+ parse i h = do+ debugMessage ("Rereading patch file: "++ showDoc Encode (showPatchInfoUI i))+ (fn, ps) <- fetchFileUsingCache c HashedPatchesDir h+ case readPatch ps of+ Just x -> return x+ Nothing -> fail $ unlines [ "Couldn't parse patch file " ++ fn+ , "which is"+ , renderString Encode $ showPatchInfoUI i]++ readp h i = do Sealed x <- createHashed h (parse i)+ return . patchInfoAndPatch i $ unsafeCoerceP x++-- | writeTentativeInventory writes @patchSet@ as the tentative inventory.+writeTentativeInventory :: RepoPatch p => Cache -> Compression+ -> PatchSet p Origin wX -> IO ()+writeTentativeInventory cache compr patchSet = do+ debugMessage "in writeTentativeInventory..."+ createDirectoryIfMissing False inventoriesDirPath+ beginTedious tediousName+ hsh <- writeInventoryPrivate $ slightlyOptimizePatchset patchSet+ endTedious tediousName+ debugMessage "still in writeTentativeInventory..."+ case hsh of+ Nothing -> writeBinFile (darcsdir </> tentativeHashedInventory) ""+ Just h -> do+ content <- snd <$> fetchFileUsingCache cache HashedInventoriesDir h+ writeAtomicFilePS (darcsdir </> tentativeHashedInventory) content+ where+ tediousName = "Writing inventory"+ writeInventoryPrivate :: RepoPatch p => PatchSet p Origin wX+ -> IO (Maybe String)+ writeInventoryPrivate (PatchSet NilRL NilRL) = return Nothing+ writeInventoryPrivate (PatchSet ps NilRL) = do+ inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) ps+ let inventorylist = hcat (map pihash $ reverse inventory)+ hash <- writeHashFile cache compr HashedInventoriesDir inventorylist+ return $ Just hash+ writeInventoryPrivate+ (PatchSet x xs@(Tagged t _ _ :<: _)) = do+ resthash <- write_ts xs+ finishedOneIO tediousName $ fromMaybe "" resthash+ inventory <- sequence $ mapRL (writePatchIfNecessary cache compr)+ (x +<+ t :<: NilRL)+ let inventorylist = hcat (map pihash $ reverse inventory)+ inventorycontents =+ case resthash of+ Just h -> text ("Starting with inventory:\n" ++ h) $$+ inventorylist+ Nothing -> inventorylist+ hash <- writeHashFile cache compr HashedInventoriesDir inventorycontents+ return $ Just hash+ where+ -- | write_ts writes out a tagged patchset. If it has already been+ -- written, we'll have the hash, so we can immediately return it.+ write_ts :: RepoPatch p => RL (Tagged p) Origin wX+ -> IO (Maybe String)+ write_ts (Tagged _ (Just h) _ :<: _) = return (Just h)+ write_ts (Tagged _ Nothing pps :<: tts) =+ writeInventoryPrivate $ PatchSet pps tts+ write_ts NilRL = return Nothing++-- |writeHashIfNecessary writes the patch and returns the resulting info/hash,+-- if it has not already been written. If it has been written, we have the hash+-- in the PatchInfoAnd, so we extract and return the info/hash.+writePatchIfNecessary :: RepoPatch p => Cache -> Compression+ -> PatchInfoAnd p wX wY -> IO (PatchInfo, String)+writePatchIfNecessary c compr hp = infohp `seq`+ case extractHash hp of+ Right h -> return (infohp, h)+ Left p -> (\h -> (infohp, h)) <$>+ writeHashFile c compr HashedPatchesDir (showPatch p)+ where+ infohp = info hp++-- |pihash takes an info/hash pair, and renders the info, along with the hash+-- as a Doc.+pihash :: (PatchInfo, String) -> Doc+pihash (pinf, hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n")++-- |listInventoriesWith returns a list of the inventories hashes.+-- The function @f@ can be readInventoryPrivate or readInventoryLocalPrivate.+-- The argument @hashedRepoDir@ is the path to the repository,+-- where it's the 'hashed_inventory' file.+-- The argument @darcsDir@ is the path to the directory of inventories files.+listInventoriesWith :: (String -> String+ -> IO (Maybe String, [(PatchInfo, String)]))+ -> String -> String -> IO [String]+listInventoriesWith f darcsDir hashedRepoDir = do+ mbStartingWithInv <- getStartingWithHash hashedRepoDir hashedInventory+ followStartingWiths mbStartingWithInv+ where+ getStartingWithHash invDir inv =+ fst <$> f invDir inv++ followStartingWiths Nothing = return []+ followStartingWiths (Just startingWith) = do+ mbNextInv <- getStartingWithHash (darcsDir </> inventoriesDir) startingWith+ (startingWith :) <$> followStartingWiths mbNextInv++-- |listInventoriesBucketedWith is similar to listInventoriesWith, but+-- it read the inventory directory under @darcsDir@ in bucketed format.+listInventoriesBucketedWith :: (String -> String+ -> IO (Maybe String, [(PatchInfo, String)]))+ -> String -> String -> IO [String]+listInventoriesBucketedWith f darcsDir hashedRepoDir = do+ mbStartingWithInv <- getStartingWithHash hashedRepoDir hashedInventory+ followStartingWiths mbStartingWithInv+ where+ getStartingWithHash invDir inv =+ fst <$> f invDir inv++ followStartingWiths Nothing = return []+ followStartingWiths (Just startingWith) = do+ mbNextInv <- getStartingWithHash+ (darcsDir </> inventoriesDir </> bucketFolder startingWith) startingWith+ (startingWith :) <$> followStartingWiths mbNextInv++-- |listInventories returns a list of the inventories hashes.+-- This function attempts to retrieve missing inventory files.+listInventories :: IO [String]+listInventories = listInventoriesWith readInventoryPrivate darcsdir darcsdir++-- |readInventoryLocalPrivate reads the inventory with name @invName@ in @dir@+-- if it exist, otherwise returns an empty inventory.+readInventoryLocalPrivate :: String -> String+ -> IO (Maybe String, [(PatchInfo, String)])+readInventoryLocalPrivate dir invName = do+ b <- doesFileExist (dir </> invName)+ if b then readInventoryPrivate dir invName+ else return (Nothing, [])++-- |listInventoriesLocal returns a list of the inventories hashes.+-- This function does not attempt to retrieve missing inventory files.+listInventoriesLocal :: IO [String]+listInventoriesLocal = listInventoriesWith readInventoryLocalPrivate darcsdir darcsdir++-- |listInventoriesRepoDir returns a list of the inventories hashes.+-- The argument @repoDir@ is the directory of the repository from which+-- we are going to read the "hashed_inventory" file.+-- The rest of hashed files are read from the global cache.+listInventoriesRepoDir :: String -> IO [String]+listInventoriesRepoDir repoDir = do+ gCacheDir' <- globalCacheDir+ let gCacheInvDir = fromJust gCacheDir'+ listInventoriesBucketedWith readInventoryLocalPrivate gCacheInvDir (repoDir </> darcsdir)++-- |listPatchesLocal returns a list of the patches hashes, extracted+-- from inventory files, by following the inventory "chain" of "Starting+-- with inventory" hashes. This function does not attempt to download missing+-- inventory files.+-- The argument @darcsDir@ is the path to the darcs directory (e.g. "_darcs")+-- of the repository from which we're going to read the inventories.+listPatchesLocal :: String -> IO [String]+listPatchesLocal darcsDir = do+ inventory <- readInventoryPrivate darcsDir hashedInventory+ followStartingWiths (fst inventory) (getPatches inventory)+ where+ followStartingWiths Nothing patches = return patches+ followStartingWiths (Just startingWith) patches = do+ inv <- readInventoryLocalPrivate (darcsDir </> inventoriesDir) startingWith+ (patches++) <$> followStartingWiths (fst inv) (getPatches inv)++ getPatches inv = map snd (snd inv)++-- |listPatchesLocalBucketed is similar to listPatchesLocal, but+-- it read the inventory directory under @darcsDir@ in bucketed format.+listPatchesLocalBucketed :: String -> String -> IO [String]+listPatchesLocalBucketed darcsDir hashedRepoDir = do+ inventory <- readInventoryPrivate hashedRepoDir hashedInventory+ followStartingWiths (fst inventory) (getPatches inventory)+ where+ followStartingWiths Nothing patches = return patches+ followStartingWiths (Just startingWith) patches = do+ inv <- readInventoryLocalPrivate+ (darcsDir </> inventoriesDir </> bucketFolder startingWith) startingWith+ (patches++) <$> followStartingWiths (fst inv) (getPatches inv)++ getPatches inv = map snd (snd inv)++-- | 'readPatchIds inventory' parses the content of a hashed_inventory file+-- after the "pristine:" and "Starting with inventory:" header lines have+-- been removed. The second value in the resulting tuples is the file hash+-- of the associated patch (the "hash:" line).+readPatchIds :: B.ByteString -> [(PatchInfo, String)]+readPatchIds inv | B.null inv = []+readPatchIds inv = case parseStrictly readPatchInfo inv of+ Nothing -> []+ Just (pinfo, r) ->+ case readHash r of+ Nothing -> []+ Just (h, r') -> (pinfo, h) : readPatchIds r'+ where+ readHash :: B.ByteString -> Maybe (String, B.ByteString)+ readHash s = let s' = dropSpace s+ (l, r) = BC.break ('\n' ==) s'+ (kw, h) = BC.break (' ' ==) l in+ if kw /= BC.pack "hash:" || B.length h <= 1+ then Nothing+ else Just (BC.unpack $ B.tail h, r)++-- |applyToTentativePristine applies a patch @p@ to the tentative pristine+-- tree, and updates the tentative pristine hash+applyToTentativePristine :: (ApplyState p ~ Tree, Patchy p) => p wX wY+ -> IO ()+applyToTentativePristine p = do+ tentativePristine <- gzReadFilePS tentativePristinePath+ -- Extract the pristine hash from the tentativePristine file, using+ -- inv2pris (this is valid since we normally just extract the hash from the+ -- first line of an inventory file; we can pass in a one-line file that+ -- just contains said hash).+ let tentativePristineHash = inv2pris tentativePristine+ newPristineHash <- applyToHashedPristine tentativePristineHash p+ writeDocBinFile tentativePristinePath $+ pris2inv newPristineHash tentativePristine++-- | copyPristine copies a pristine tree into the current pristine dir,+-- and possibly copies a clean working copy.+-- The target is read from the passed-in dir/inventory name combination.+copyPristine :: Cache -> String -> String -> WithWorkingDir -> IO ()+copyPristine cache dir iname wwd = do+ i <- fetchFilePS (dir ++ "/" ++ iname) Uncachable+ debugMessage $ "Copying hashed pristine tree: " ++ inv2pris i+ let tediousName = "Copying pristine"+ beginTedious tediousName+ copyHashed tediousName cache wwd $ inv2pris i+ endTedious tediousName++-- |copyPartialsPristine copies the pristine entries for a given list of+-- filepaths.+copyPartialsPristine :: FilePathLike fp => Cache -> String+ -> String -> [fp] -> IO ()+copyPartialsPristine c d iname fps = do+ i <- fetchFilePS (d ++ "/" ++ iname) Uncachable+ copyPartialsHashed c (inv2pris i) fps++-- |pris2inv takes an updated pristine hash and an inventory, and outputs the+-- new pristine hash followed by the original inventory (having skipped the old+-- inventory hash).+pris2inv :: String -> B.ByteString -> Doc+pris2inv h inv = invisiblePS pristineName <> text h $$+ invisiblePS (skipPristine inv)++-- |inv2pris takes the content of an inventory, and extracts the corresponding+-- pristine hash from the inventory (the hash is prefixed by "pristine:").+inv2pris :: B.ByteString -> String+inv2pris inv = case tryDropPristineName inv of+ Just rest -> case takeHash rest of+ Just (h, _) -> h+ Nothing -> error "Bad hash in inventory!"+ Nothing -> sha256sum B.empty++-- |skipPristine drops the 'pristine: HASH' prefix line, if present.+skipPristine :: B.ByteString -> B.ByteString+skipPristine ps = case tryDropPristineName ps of+ Just rest -> B.drop 1 $ BC.dropWhile (/= '\n') rest+ Nothing -> ps++-- |tryDropPristineName returns the result of dropping the pristineName from+-- the input, if it was present, otherwise it returns Nothing.+tryDropPristineName :: B.ByteString -> Maybe B.ByteString+tryDropPristineName input =+ if prefix == pristineName then Just rest else Nothing+ where+ (prefix, rest) = B.splitAt (B.length pristineName) input
src/Darcs/Repository/Internal.hs view
@@ -18,867 +18,1025 @@ {-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-} -#include "gadts.h"--module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), RepoJob(..),-- maybeIdentifyRepository, identifyDarcsRepository, identifyRepositoryFor,- IdentifyRepo(..),- findRepository, amInRepository, amNotInRepository,- amInHashedRepository,- revertRepositoryChanges,- announceMergeConflicts, setTentativePending,- checkUnrecordedConflicts,- withRecorded,- readRepo, readTentativeRepo, readRepoUsingSpecificInventory,- prefsUrl, makePatchLazy,- withRepoLock, withRepoReadLock,- withRepository, withRepositoryDirectory, withGutsOf,- tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,- tentativelyAddPatch_,- tentativelyReplacePatches,- finalizeRepositoryChanges,- unrevertUrl,- applyToWorking, patchSetToPatches,- createPristineDirectoryTree, createPartialsPristineDirectoryTree,- optimizeInventory, cleanRepository,- setScriptsExecutable, setScriptsExecutablePatches,- getRepository, rIO,- testTentative, testRecorded,- UpdatePristine(..), MakeChanges(..), applyToTentativePristine,- makeNewPending, seekRepo- ) where--import Prelude hiding ( catch )--import Printer ( putDocLn, (<+>), text, ($$), redText, putDocLnWith, (<>), ($$))-import Darcs.ColorPrinter (fancyPrinters)--import Darcs.Repository.Prefs ( getPrefval )-import Darcs.Repository.State ( readRecorded, readWorking )-import Darcs.Repository.LowLevel- ( readPending, readTentativePending- , writeTentativePending- , readNewPending, writeNewPending- , pendingName )-import System.Exit ( ExitCode(..), exitWith )-import System.Cmd ( system )-import Darcs.IO ( runTolerantly, runSilently )--import Darcs.SignalHandler ( withSignalsBlocked )-import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2 , HashedInventory, NoWorkingDir ),- tryIdentifyRepoFormat, formatHas,- writeProblem, readProblem, readfromAndWritetoProblem )-import System.Directory ( doesDirectoryExist, setCurrentDirectory,- 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 )-import qualified Data.ByteString.Char8 as BC (pack)--import Darcs.Patch ( Effect, primIsHunk, primIsBinary, description,- tryToShrink, commuteFLorComplain, commute, fromPrim )--import Darcs.Patch.Dummy ( DummyPatch )--import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.V1 ( Patch )-import Darcs.Patch.V2 ( RealPatch )-import Darcs.Patch.Prim.V1 ( Prim )--import Darcs.Patch.Inspect ( PatchInspect )-import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, tryShrinkingInverse, PrimPatch )-import Darcs.Patch.Bundle ( scanBundle, makeBundleN )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )-import qualified Darcs.Repository.HashedRepo as HashedRepo- ( revertTentativeChanges, finalizeTentativeChanges,- removeFromTentativeInventory,- copyPristine, copyPartialsPristine,- applyToTentativePristine,- writeTentativeInventory, writeAndReadPatch,- addToTentativeInventory,- readRepo, readTentativeRepo,- readRepoUsingSpecificInventory, cleanPristine )-import qualified Darcs.Repository.Old as Old- ( readOldRepo, revertTentativeChanges, oldRepoFailMsg )-import Darcs.Flags ( DarcsFlag(Verbose, Quiet,- MarkConflicts, AllowConflicts, NoUpdateWorking,- WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir,- SetScriptsExecutable, DryRun ),- wantExternalMerge, compression, Compression )-import Darcs.Witnesses.Eq ( EqCheck(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart )-import Darcs.Witnesses.Ordered ( FL(..), RL(..),- (:\/:)(..), (:/\:)(..), (:>)(..),- (+>+), lengthFL,- allFL, filterFLFL,- reverseFL, mapFL_FL, concatFL )-import Darcs.Patch ( RepoPatch, Patchy, merge,- listConflictedFiles, listTouchedFiles,- Named,- commuteRL, fromPrims,- readPatch,- effect, invert,- primIsAddfile, primIsAdddir,- primIsSetpref,- apply, applyToTree,- )-import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL )-import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2FL )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Patch.Depends ( deepOptimizePatchset, removeFromPatchSet, mergeThem )-import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath,- ioAbsoluteOrRemote, toPath )-import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort )-import Progress ( debugMessage )-import Darcs.ProgressPatches (progressFL)-import Darcs.URL ( isFile )-import Darcs.Repository.Prefs ( getCaches )-import Darcs.Lock ( withLock, writeDocBinFile, removeFileMayNotExist,- withTempDir, withPermDir )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal, mapSeal )-import Darcs.Repository.InternalTypes( Repository(..), RepoType(..), Pristine(..) )-import Darcs.Global ( darcsdir )--import System.Mem( performGC )--import qualified Storage.Hashed.Tree as Tree-import Storage.Hashed.Tree ( Tree )-import Storage.Hashed.AnchoredPath( anchorPath )--#include "impossible.h"---- | Repository IO monad. This monad-like datatype is responsible for--- sequencing IO actions that modify the tentative recorded state of--- the repository.-newtype RIO p C(r u t t1) a = RIO {- unsafeUnRIO :: Repository p C(r u t) -> IO a -- ^ converts @RIO a@ to @IO a@.- }---- | This is just like @>>=@ from the Monad class except that it--- respects type witness safe repository transformations. Even so, it--- only tracks modifications to the tentative recorded state.-(>>>=) :: RIO p C(r u t t1) a -> (a -> RIO p C(r u t1 t2) b) -> RIO p C(r u t t2) b-m >>>= k = RIO $ \ (Repo x y z w) ->- do a <- unsafeUnRIO m (Repo x y z w)- unsafeUnRIO (k a) (Repo x y z w)---- | This corresponds to @>>@ from the Monad class.-(>>>) :: RIO p C(r u t t1) a -> RIO p C(r u t1 t2) b -> RIO p C(r u t t2) b-a >>> b = a >>>= (const b)---- | This corresponds to @return@ from the Monad class.-returnR :: a -> RIO p C(r u t t) a-returnR = rIO . return---- | This the @RIO@ equivalent of @liftIO@.-rIO :: IO a -> RIO p C(r u t t) a-rIO = RIO . const--instance Functor (RIO p C(r u t t)) where- fmap f m = RIO $ \r -> fmap f (unsafeUnRIO m r)---- | We have an instance of Monad so that IO actions that do not--- change the tentative recorded state are convenient in the IO monad.-instance Monad (RIO p C(r u t t)) where- (>>=) = (>>>=)- (>>) = (>>>)- return = returnR- fail = rIO . fail---- | Similar to the @ask@ function of the MonadReader class.--- This allows actions in the RIO monad to get the current--- repository.--- FIXME: Don't export this. If we don't export this--- it makes it harder for arbitrary IO actions to access--- the repository and hence our code is easier to audit.-getRepository :: RIO p C(r u t t) (Repository p C(r u t))-getRepository = RIO return---- | The status of a given directory: is it a darcs repository?-data IdentifyRepo p C(r u t) = BadRepository String -- ^ looks like a repository with some error- | NonRepository String -- ^ safest guess- | GoodRepository (Repository p C(r u t))---- | Tries to identify the repository in a given directory-maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (IdentifyRepo p C(r u t))-maybeIdentifyRepository opts "." =- do darcs <- doesDirectoryExist darcsdir- rf_or_e <- tryIdentifyRepoFormat "."- here <- toPath `fmap` ioAbsoluteOrRemote "."- case rf_or_e of- Left err -> return $ NonRepository err- Right rf ->- case readProblem rf of- Just err -> return $ BadRepository err- Nothing -> if darcs then do pris <- identifyPristine- cs <- getCaches opts here- return $ GoodRepository $ Repo here opts rf (DarcsRepository pris cs)- else return (NonRepository "Not a repository")-maybeIdentifyRepository opts url' =- do url <- toPath `fmap` ioAbsoluteOrRemote url'- rf_or_e <- tryIdentifyRepoFormat url- case rf_or_e of- Left e -> return $ NonRepository e- Right rf -> case readProblem rf of- Just err -> return $ BadRepository err- Nothing -> do cs <- getCaches opts url- return $ GoodRepository $ Repo url opts rf (DarcsRepository NoPristine cs)--identifyPristine :: IO Pristine-identifyPristine =- do pristine <- doesDirectoryExist $ darcsdir++"/pristine"- current <- doesDirectoryExist $ darcsdir++"/current"- hashinv <- doesFileExist $ darcsdir++"/hashed_inventory"- case (pristine || current, hashinv) of- (False, False) -> return NoPristine- (True, False) -> return PlainPristine- (False, True ) -> return HashedPristine- _ -> fail "Multiple pristine trees."---- | identifyDarcsRepository identifies the repo at 'url'. Warning:--- you have to know what kind of patches are found in that repo.-identifyDarcsRepository :: forall p C(r u t). [DarcsFlag] -> String- -> IO (Repository p C(r u t))-identifyDarcsRepository opts url =- do er <- maybeIdentifyRepository opts url- case er of- BadRepository s -> fail s- NonRepository s -> fail s- GoodRepository r -> return r---- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url',--- but fails if it is not compatible for reading from and writing to.-identifyRepositoryFor :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> String -> IO (Repository p C(r u t))-identifyRepositoryFor (Repo _ opts rf _) url =- do Repo absurl _ rf_ t <- identifyDarcsRepository opts url- let t' = case t of DarcsRepository x c -> DarcsRepository x c- case readfromAndWritetoProblem rf_ rf of- Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e- Nothing -> return $ Repo absurl opts rf_ t'--amInRepository :: [DarcsFlag] -> IO (Either String ())-amInRepository (WorkRepoDir d:_) =- do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)- status <- maybeIdentifyRepository [] "."- case status of- GoodRepository _ -> return (Right ())- BadRepository e -> return (Left $ "While " ++ d ++ " looks like a repository directory, we have a problem with it:\n" ++ e)- NonRepository _ -> return (Left "You need to be in a repository directory to run this command.")-amInRepository (_:fs) = amInRepository fs-amInRepository [] = do- maybe (Left $ "You need to be in a repository directory " ++- "to run this command.") id <$> seekRepo--amInHashedRepository :: [DarcsFlag] -> IO (Either String ())-amInHashedRepository flags- = do inrepo <- amInRepository flags- case inrepo of- Right _ -> do pristine <- identifyPristine- case pristine of- HashedPristine -> return (Right ())- _ -> return (Left Old.oldRepoFailMsg)- left -> return left---- | hunt upwards for the darcs repository--- This keeps changing up one parent directory, testing at each--- step if the current directory is a repository or not. $--- The result is:--- Nothing, if no repository found--- Just (Left errorMessage), if bad repository found--- Just (Right ()), if good repository found.--- WARNING this changes the current directory for good if matchFn succeeds-seekRepo :: IO (Maybe (Either String ()))-seekRepo = getCurrentDirectory >>= helper where- helper startpwd = do- status <- maybeIdentifyRepository [] "."- case status of- GoodRepository _ -> return . Just $ Right ()- BadRepository e -> return . Just $ Left e- NonRepository _ ->- do cd <- toFilePath `fmap` getCurrentDirectory- setCurrentDirectory ".."- cd' <- toFilePath `fmap` getCurrentDirectory- if cd' /= cd- then helper startpwd- else do setCurrentDirectory startpwd- return Nothing---- The performGC in this function is a workaround for a library/GHC bug,--- http://hackage.haskell.org/trac/ghc/ticket/2924 -- (doesn't seem to be a--- problem on fast machines, but virtual ones trip this from time to time)-amNotInRepository :: [DarcsFlag] -> IO (Either String ())-amNotInRepository (WorkRepoDir d:_) = do createDirectoryIfMissing False d- `catchall` (performGC >> createDirectoryIfMissing False d)- -- note that the above could always fail- setCurrentDirectory d- amNotInRepository []-amNotInRepository (_:f) = amNotInRepository f-amNotInRepository [] =- do status <- maybeIdentifyRepository [] "."- case status of- GoodRepository _ -> return (Left $ "You may not run this command in a repository.")- BadRepository e -> return (Left $ "You may not run this command in a repository.\nBy the way, we have a problem with it:\n" ++ e)- NonRepository _ -> return (Right ())--findRepository :: [DarcsFlag] -> IO (Either String ())-findRepository (WorkRepoUrl d:_) | isFile d =- do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)- findRepository []-findRepository (WorkRepoDir d:_) =- do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)- findRepository []-findRepository (_:fs) = findRepository fs-findRepository [] = maybe (Right ()) id <$> seekRepo---- TODO: see also Repository.State.readPendingLL ... to be removed after GHC 7.2-readNewPendingLL :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> IO (Sealed ((FL p) C(t)))-readNewPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` readNewPending repo--makeNewPending :: forall p C(r u t y). (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> FL (PrimOf p) C(t y) -> IO ()-makeNewPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()-makeNewPending repo@(Repo r _ _ tp) origp =- withCurrentDirectory r $- do let newname = pendingName tp ++ ".new"- debugMessage $ "Writing new pending: " ++ newname- Sealed sfp <- return $ siftForPending origp- writeNewPending repo sfp- 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 :: IOException) -> do- let buggyname = pendingName tp ++ "_buggy"- renameFile newname buggyname- bugDoc $ text ("There was an attempt to write an invalid pending! " ++ show err)- $$ text "If possible, please send the contents of"- <+> text buggyname- $$ text "along with a bug report."- renameFile newname (pendingName tp)- debugMessage $ "Finished writing new pending: " ++ newname--siftForPending :: forall prim C(x y) . PrimPatch prim => FL prim C(x y) -> Sealed (FL prim C(x))-siftForPending simple_ps =- let oldps = maybe simple_ps id $ tryShrinkingInverse $ crudeSift simple_ps- in if allFL (\p -> primIsAddfile p || primIsAdddir p) $ oldps- then seal oldps- else fromJust $ do- Sealed x <- return $ sfp NilFL $ reverseFL oldps- return (case tryToShrink x of- ps | lengthFL ps < lengthFL oldps -> siftForPending ps- | otherwise -> seal ps)- where sfp :: FL prim C(a b) -> RL prim C(c a) -> Sealed (FL prim C(c))- sfp sofar NilRL = seal sofar- sfp sofar (p:<:ps)- | primIsHunk p || primIsBinary p- = case commuteFLorComplain (p :> sofar) of- Right (sofar' :> _) -> sfp sofar' ps- Left _ -> sfp (p:>:sofar) ps- sfp sofar (p:<:ps) = sfp (p:>:sofar) ps---- @todo: we should not have to open the result of HashedRepo and--- seal it. Instead, update this function to work with type witnesses--- by fixing DarcsRepo to match HashedRepo in the handling of--- Repository state.-readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO (PatchSet p C(Origin r))-readRepo repo@(Repo r _ rf _)- | formatHas HashedInventory rf = HashedRepo.readRepo repo r- | otherwise = do Sealed ps <- Old.readOldRepo r- return $ unsafeCoerceP ps--readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO (PatchSet p C(Origin t))-readTentativeRepo repo@(Repo r _ rf _)- | formatHas HashedInventory rf = HashedRepo.readTentativeRepo repo r- | otherwise = fail Old.oldRepoFailMsg--readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p C(r u t)- -> IO (PatchSet p C(Origin t))-readRepoUsingSpecificInventory invPath repo@(Repo r _ rf _)- | formatHas HashedInventory rf =- HashedRepo.readRepoUsingSpecificInventory invPath repo r- | otherwise = fail Old.oldRepoFailMsg--makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y))-makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p- | formatHas HashedInventory rf = withCurrentDirectory r $ HashedRepo.writeAndReadPatch c (compression opts) p- | otherwise = fail Old.oldRepoFailMsg--prefsUrl :: Repository p C(r u t) -> String-prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs"--unrevertUrl :: Repository p C(r u t) -> String-unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/patches/unrevert"--applyToWorking :: (ApplyState (PrimOf p) ~ Tree, RepoPatch p)- => Repository p C(r u t) -> [DarcsFlag] -> FL (PrimOf p) C(u y)- -> IO (Repository p C(r y t))-applyToWorking (Repo r ropts rf (DarcsRepository t c)) opts patch =- do- unless (formatHas NoWorkingDir rf) $- withCurrentDirectory r $ if Quiet `elem` opts- then runSilently $ apply patch- else runTolerantly $ apply patch- return (Repo r ropts rf (DarcsRepository t c))--handlePendForAdd :: forall p C(r u t x y). (RepoPatch p)- => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO ()-handlePendForAdd (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()-handlePendForAdd repo p =- do- Sealed pend <- readTentativePending repo- let effectp = if allFL isSimple pend then crudeSift $ effect p- else effect p- Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) (unsafeCoercePStart pend)- writeTentativePending repo (unsafeCoercePStart newpend)- where rmpend :: FL (PrimOf p) C(a b) -> FL (PrimOf p) C(a c) -> Sealed (FL (PrimOf p) C(b))- rmpend NilFL x = Sealed x- rmpend _ NilFL = Sealed NilFL- rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys- rmpend (x:>:xs) ys =- case commuteWhatWeCanFL (x:>xs) of- a:>x':>b -> case rmpend a ys of- Sealed ys' -> case commute (invert (x':>:b) :> ys') of- Just (ys'' :> _) -> seal ys''- Nothing -> seal $ invert (x':>:b)+>+ys'- -- DJR: I don't think this- -- last case should be- -- reached, but it also- -- shouldn't lead to- -- corruption.--isSimple :: PrimPatch prim => prim C(x y) -> Bool-isSimple x = primIsHunk x || primIsBinary x || primIsSetpref x--crudeSift :: forall prim C(x y) . PrimPatch prim => FL prim C(x y) -> FL prim C(x y)-crudeSift xs = if allFL isSimple xs then filterFLFL ishunkbinary xs else xs- where ishunkbinary :: prim C(a b) -> EqCheck C(a b)- ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq- | otherwise = NotEq--data HashedVsOld a = HvsO { old, hashed :: a }--decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a-decideHashedOrNormal rf (HvsO { hashed = h, old = o })- | formatHas HashedInventory rf = h- | otherwise = o--data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq )--announceMergeConflicts :: (PrimPatch p, PatchInspect p) => String -> [DarcsFlag] -> FL p C(x y) -> IO Bool-announceMergeConflicts cmd opts resolved_pw =- case nubsort $ listTouchedFiles resolved_pw of- [] -> return False- cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts- || wantExternalMerge opts /= Nothing- then do putDocLnWith fancyPrinters $ - redText "We have conflicts in the following files:" $$ text (unwords cfs)- return True- else do putDocLnWith fancyPrinters $- redText "There are conflicts in the following files:" $$ text (unwords cfs)- fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++- "If you would rather apply the patch and mark the conflicts,\n"++- "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++- "These can set as defaults by adding\n"++- " "++cmd++" mark-conflicts\n"++- "to "++darcsdir++"/prefs/defaults in the target repo. "--checkUnrecordedConflicts :: forall p C(t y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(t y) -> IO Bool-checkUnrecordedConflicts opts _ | NoUpdateWorking `elem` opts = return False-checkUnrecordedConflicts opts pc =- do repository <- identifyDarcsRepository opts "."- cuc repository- where cuc :: Repository p C(r u t) -> IO Bool- cuc r = do Sealed (mpend :: FL (PrimOf p) C(t x)) <- readPending r :: IO (Sealed (FL (PrimOf p) C(t)))- case mpend of- NilFL -> return False- pend ->- case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of- _ :/\: pend' ->- case listConflictedFiles pend' of- [] -> return False- fs -> do putStrLn ("You have conflicting local changes to:\n"- ++ unwords fs)- confirmed <- promptYorn "Proceed?"- unless confirmed $- do putStrLn "Cancelled."- exitWith ExitSuccess- return True- fromPrims_ :: FL (PrimOf p) C(a b) -> FL p C(a b)- fromPrims_ = fromPrims--tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> Compression -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y))-tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine--data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq---- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun--- :: Bool, with dryRun = unsafePerformIO $ readIORef ...-tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree)- => UpdatePristine -> Repository p C(r u t) -> Compression- -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y))-tentativelyAddPatch_ up r@(Repo dir ropts rf (DarcsRepository t c)) compr p =- withCurrentDirectory dir $--- Warning: A do-notation statement discarded a result of type FilePath.- do _ <- decideHashedOrNormal rf $ HvsO {- hashed = HashedRepo.addToTentativeInventory c compr p,- old = fail Old.oldRepoFailMsg}- when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."- applyToTentativePristine r p- debugMessage "Updating pending..."- handlePendForAdd r p- return (Repo dir ropts rf (DarcsRepository t c))--applyToTentativePristine :: (ApplyState q ~ Tree, Effect q, Patchy q, PrimPatchBase q)- => Repository p C(r u t) -> q C(t y) -> IO ()-applyToTentativePristine (Repo dir opts rf (DarcsRepository _ _)) p =- withCurrentDirectory dir $- do when (Verbose `elem` opts) $ putDocLn $ text "Applying to pristine..." <+> description p- decideHashedOrNormal rf $ HvsO {hashed = HashedRepo.applyToTentativePristine p,- old = fail Old.oldRepoFailMsg}---- | This fuction is unsafe because it accepts a patch that works on the tentative--- pending and we don't currently track the state of the tentative pending.-tentativelyAddToPending :: forall p C(r u t x y). RepoPatch p- => Repository p C(r u t) -> [DarcsFlag] -> FL (PrimOf p) C(x y) -> IO ()-tentativelyAddToPending (Repo _ opts _ _) _ _- | NoUpdateWorking `elem` opts = return ()- | DryRun `elem` opts = bug "tentativelyAddToPending called when --dry-run is specified"-tentativelyAddToPending repo@(Repo dir _ _ _) _ patch =- withCurrentDirectory dir $ do- Sealed pend <- readTentativePending repo- FlippedSeal newpend_ <- return $ newpend (unsafeCoerceP pend :: FL (PrimOf p) C(a x)) patch- writeTentativePending repo (unsafeCoercePStart newpend_)- where newpend :: FL prim C(a b) -> FL prim C(b c) -> FlippedSeal (FL prim) C(c)- newpend NilFL patch_ = flipSeal patch_- newpend p patch_ = flipSeal $ p +>+ patch_---- | setTentativePending is basically unsafe. It overwrites the pending state with a new one, not related to--- the repository state.-setTentativePending :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL (PrimOf p) C(x y) -> IO ()-setTentativePending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()-setTentativePending repo@(Repo dir _ _ _) patch = do- Sealed prims <- return $ siftForPending patch- withCurrentDirectory dir $ writeTentativePending repo (unsafeCoercePStart prims)---- | prepend is basically unsafe. It overwrites the pending state--- with a new one, not related to the repository state.-prepend :: forall p C(r u t x y). RepoPatch p =>- Repository p C(r u t) -> FL (PrimOf p) C(x y) -> IO ()-prepend (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()-prepend repo@(Repo _ _ _ _) patch =- do- Sealed pend <- readTentativePending repo- Sealed newpend_ <- return $ newpend (unsafeCoerceP pend) patch- writeTentativePending repo (unsafeCoercePStart $ crudeSift newpend_)- where newpend :: FL prim C(b c) -> FL prim C(a b) -> Sealed (FL prim C(a))- newpend NilFL patch_ = seal patch_- newpend p patch_ = seal $ patch_ +>+ p--tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> Compression- -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x))-tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine--tentativelyRemovePatches_ :: forall p C(r u t x). (RepoPatch p, ApplyState p ~ Tree)- => UpdatePristine- -> Repository p C(r u t) -> Compression- -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x))-tentativelyRemovePatches_ up repository@(Repo dir ropts rf (DarcsRepository t c)) compr ps =- withCurrentDirectory dir $ do- when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."- prepend repository $ effect ps- removeFromUnrevertContext repository ps- debugMessage "Removing changes from tentative inventory..."- if formatHas HashedInventory rf- then do HashedRepo.removeFromTentativeInventory repository compr ps- when (up == UpdatePristine) $- HashedRepo.applyToTentativePristine $- progressFL "Applying inverse to pristine" $ invert ps- else fail Old.oldRepoFailMsg- return (Repo dir ropts rf (DarcsRepository t c))--tentativelyReplacePatches :: forall p C(r u t x). (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> Compression- -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u t))-tentativelyReplacePatches repository compr ps =- do repository' <- tentativelyRemovePatches_ DontUpdatePristine repository compr ps- mapAdd repository' ps- where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j))- mapAdd r NilFL = return r- mapAdd r (a:>:as) =- do r' <- tentativelyAddPatch_ DontUpdatePristine r compr a- mapAdd r' as--finalizePending :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> IO ()-finalizePending (Repo dir opts _ rt)- | NoUpdateWorking `elem` opts =- withCurrentDirectory dir $ removeFileMayNotExist $ (pendingName rt)-finalizePending repository@(Repo dir _ _ _) = do- withCurrentDirectory dir $ do- Sealed tpend <- readTentativePending repository- Sealed new_pending <- return $ siftForPending tpend- makeNewPending repository new_pending--finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-finalizeRepositoryChanges (Repo _ opts _ _)- | DryRun `elem` opts = bug "finalizeRepositoryChanges called when --dry-run specified"-finalizeRepositoryChanges repository@(Repo dir opts rf _)- | formatHas HashedInventory rf =- withCurrentDirectory dir $ do debugMessage "Considering whether to test..."- _ <- testTentative repository- debugMessage "Finalizing changes..."- withSignalsBlocked $ do HashedRepo.finalizeTentativeChanges repository (compression opts)- finalizePending repository- debugMessage "Done finalizing changes..."- | otherwise = fail Old.oldRepoFailMsg--testTentative :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO (ExitCode)-testTentative = testAny withTentative--testRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO (ExitCode)-testRecorded = testAny withRecorded--testAny :: RepoPatch p => (Repository p C(r u t)- -> ((AbsolutePath -> IO (ExitCode)) -> IO (ExitCode))- -> ((AbsolutePath -> IO (ExitCode)) -> IO (ExitCode)))- -> Repository p C(r u t) -> IO (ExitCode)-testAny withD repository@(Repo dir opts _ _) =- debugMessage "Considering whether to test..." >>- if not $ Test `elem` opts then return ExitSuccess else withCurrentDirectory dir $- do let putInfo = if Quiet `elem` opts then const (return ()) else putStrLn- debugMessage "About to run test if it exists."- testline <- getPrefval "test"- case testline of- Nothing -> return ExitSuccess- Just testcode ->- withD repository (wd "testing") $ \_ ->- do putInfo "Running test...\n"- when (SetScriptsExecutable `elem` opts) setScriptsExecutable- ec <- system testcode- if ec == ExitSuccess- then putInfo "Test ran successfully.\n"- else putInfo "Test failed!\n"- return ec- where wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir--revertRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO ()-revertRepositoryChanges (Repo _ opts _ _)- | DryRun `elem` opts = bug "revertRepositoryChanges called when --dry-run is specified"-revertRepositoryChanges r@(Repo dir opts rf dr@(DarcsRepository _ _)) =- withCurrentDirectory dir $- do removeFileMayNotExist (pendingName dr ++ ".tentative")- Sealed x <- readPending r- setTentativePending r x- when (NoUpdateWorking `elem` opts) $ removeFileMayNotExist $ pendingName dr- decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revertTentativeChanges,- old = Old.revertTentativeChanges }--patchSetToPatches :: RepoPatch p => PatchSet p C(x y) -> FL (Named p) C(x y)-patchSetToPatches patchSet = mapFL_FL hopefully $ newset2FL patchSet--getUMask :: [DarcsFlag] -> Maybe String-getUMask [] = Nothing-getUMask ((UMask u):_) = Just u-getUMask (_:l) = getUMask l--withUMaskFromOpts :: [DarcsFlag] -> IO a -> IO a-withUMaskFromOpts = maybe id withUMask . getUMask--withGutsOf :: Repository p C(r u t) -> IO a -> IO a-withGutsOf (Repo _ _ rf _) | formatHas HashedInventory rf = id- | otherwise = withSignalsBlocked--data RepoJob a- -- = RepoJob (forall p C(r u) . RepoPatch p => Repository p C(r u r) -> IO a)- -- TODO: Unbind Tree from RepoJob, possibly renaming existing RepoJob- = RepoJob (forall p C(r u) . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)- => Repository p C(r u r) -> IO a)- | V1Job (forall C(r u) . Repository (Patch Prim) C(r u r) -> IO a)- | V2Job (forall C(r u) . Repository (RealPatch Prim) C(r u r) -> IO a)- | PrimV1Job (forall p C(r u) . (RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim)- => Repository p C(r u r) -> IO a)--onRepoJob :: RepoJob a- -> (forall p C(r u) . RepoPatch p => (Repository p C(r u r) -> IO a) -> (Repository p C(r u r) -> IO a))- -> RepoJob a-onRepoJob (RepoJob job) f = RepoJob (f job)--- onRepoJob (TreeJob job) f = TreeJob (f job)-onRepoJob (V1Job job) f = V1Job (f job)-onRepoJob (V2Job job) f = V2Job (f job)-onRepoJob (PrimV1Job job) f = PrimV1Job (f job)--withRepository :: [DarcsFlag] -> RepoJob a -> IO a-withRepository opts1 = withRepositoryDirectory opts1 "."--withRepositoryDirectory :: forall a. [DarcsFlag] -> String -> RepoJob a -> IO a-withRepositoryDirectory opts1 url repojob =- do Repo dir opts rf (DarcsRepository t c) <- identifyDarcsRepository opts1 url- if formatHas Darcs2 rf- then do debugMessage $ "Identified darcs-2 repo: " ++ dir- let therepo = Repo dir opts rf (DarcsRepository t c) :: Repository (RealPatch Prim) C(r u r)- case repojob of- RepoJob job -> job therepo- -- TreeJob job -> job therepo- V2Job job -> job therepo- PrimV1Job job -> job therepo- V1Job _ -> fail "This repository contains darcs v1 patches, but the command requires darcs v2 patches."- else do debugMessage $ "Identified darcs-1 repo: " ++ dir- let therepo = Repo dir opts rf (DarcsRepository t c) :: Repository (Patch Prim) C(r u r)- case repojob of- RepoJob job -> job therepo- -- TreeJob job -> job therepo- V1Job job -> job therepo- PrimV1Job job -> job therepo- V2Job _ -> fail "This repository contains darcs v2 patches, but the command requires darcs v1 patches."--withRepoLock :: [DarcsFlag] -> RepoJob a -> IO a-withRepoLock opts repojob =- withRepository opts $ onRepoJob repojob $ \job repository@(Repo _ _ rf _) ->- do maybe (return ()) fail $ writeProblem rf- let name = "./"++darcsdir++"/lock"- withUMaskFromOpts opts $ if DryRun `elem` opts- then job repository- else withLock name (revertRepositoryChanges repository >> job repository)--withRepoReadLock :: [DarcsFlag] -> RepoJob a -> IO a-withRepoReadLock opts repojob =- withRepository opts $ onRepoJob repojob $ \job repository@(Repo _ _ rf _) ->- do maybe (return ()) fail $ writeProblem rf- let name = "./"++darcsdir++"/lock"- withUMaskFromOpts opts $ if formatHas HashedInventory rf || DryRun `elem` opts- then job repository- else withLock name (revertRepositoryChanges repository >> job repository)--removeFromUnrevertContext :: forall p C(r u t x). (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> FL (PatchInfoAnd p) C(x t) -> IO ()-removeFromUnrevertContext repository ps = do- Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (PatchSet NilRL NilRL))- remove_from_unrevert_context_ bundle- where unrevert_impossible =- do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?"- if confirmed then removeFileMayNotExist (unrevertUrl repository)- else fail "Cancelled."- unrevert_patch_bundle :: IO (SealedPatchSet p C(Origin))- unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository)- case scanBundle pf of- Right foo -> return foo- Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err- remove_from_unrevert_context_ :: PatchSet p C(Origin z) -> IO ()- remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return ()- remove_from_unrevert_context_ bundle =- do debugMessage "Adjusting the context of the unrevert changes..."- debugMessage $ "Removing "++ show (lengthFL ps) ++- " patches in removeFromUnrevertContext!"- ref <- readTentativeRepo repository- let withSinglet :: Sealed (FL ppp C(xxx))- -> (FORALL(yyy) ppp C(xxx yyy) -> IO ()) -> IO ()- withSinglet (Sealed (x :>: NilFL)) j = j x- withSinglet _ _ = return ()- withSinglet (mergeThem ref bundle) $ \h_us ->- case commuteRL (reverseFL ps :> h_us) of- Nothing -> unrevert_impossible- Just (us' :> _) ->- case removeFromPatchSet ps ref of- Nothing -> unrevert_impossible- Just common ->- do debugMessage "Have now found the new context..."- bundle' <- makeBundleN Nothing common (hopefully us':>:NilFL)- writeDocBinFile (unrevertUrl repository) bundle'- debugMessage "Done adjusting the context of the unrevert changes!"---- | Writes out a fresh copy of the inventory that minimizes the--- amount of inventory that need be downloaded when people pull from--- the repository.------ Specifically, it breaks up the inventory on the most recent tag.--- This speeds up most commands when run remotely, both because a--- smaller file needs to be transfered (only the most recent--- inventory). It also gives a guarantee that all the patches prior--- to a given tag are included in that tag, so less commutation and--- history traversal is needed. This latter issue can become very--- important in large repositories.-optimizeInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-optimizeInventory repository@(Repo _ opts rf (DarcsRepository _ c)) =- do ps <- readRepo repository- decideHashedOrNormal rf $- HvsO { hashed = do revertRepositoryChanges repository- HashedRepo.writeTentativeInventory c (compression opts) $ deepOptimizePatchset ps- finalizeRepositoryChanges repository,- old = fail Old.oldRepoFailMsg}--cleanRepository :: RepoPatch p => Repository p C(r u t) -> IO ()-cleanRepository repository@(Repo _ _ rf _) =- decideHashedOrNormal rf $- HvsO { hashed = HashedRepo.cleanPristine repository,- old = fail Old.oldRepoFailMsg}--createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO ()-createPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) reldir- | formatHas HashedInventory rf =- do createDirectoryIfMissing True reldir- withCurrentDirectory reldir $ HashedRepo.copyPristine c (compression opts) r (darcsdir++"/hashed_inventory")- | otherwise = fail Old.oldRepoFailMsg---- fp below really should be FileName--- | Used by the commands dist and diff-createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO ()-createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir- | formatHas HashedInventory rf =- do createDirectoryIfMissing True dir- withCurrentDirectory dir $- HashedRepo.copyPartialsPristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs- | otherwise = fail Old.oldRepoFailMsg--withRecorded :: RepoPatch p => Repository p C(r u t)- -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a-withRecorded repository mk_dir f- = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d)- f d--withTentative :: forall p a C(r u t). (RepoPatch p, ApplyState p ~ Tree) =>- Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a)- -> (AbsolutePath -> IO a) -> IO a-withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f- | formatHas HashedInventory rf =- mk_dir $ \d -> do HashedRepo.copyPristine c (compression opts) dir (darcsdir++"/tentative_pristine")- f d-withTentative repository@(Repo dir _ _ _) mk_dir f =- withRecorded repository mk_dir $ \d ->- do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine")- apply ps- f d- where read_patches :: FilePath -> IO (Sealed (FL p C(x)))- read_patches fil = do ps <- B.readFile fil- return $ maybe (seal NilFL) id $ readPatch ps---- | Sets scripts in or below the current directory executable. A script is any file that starts--- with the bytes '#!'. This is used for --set-scripts-executable.-setScriptsExecutable_ :: Patchy p => Maybe (p C(x y)) -> IO ()-setScriptsExecutable_ pw = do- debugMessage "Making scripts executable"- tree <- readWorking- paths <- case pw of- Just ps -> filterM doesFileExist $ listTouchedFiles ps- Nothing -> return [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ]- let setExecutableIfScript f =- do contents <- B.readFile f- when (BC.pack "#!" `B.isPrefixOf` contents) $ do- debugMessage ("Making executable: " ++ f)- setExecutable f True- mapM_ setExecutableIfScript paths---setScriptsExecutable :: IO ()-setScriptsExecutable = setScriptsExecutable_ (Nothing :: Maybe (FL DummyPatch C(x y)))--setScriptsExecutablePatches :: Patchy p => p C(x y) -> IO ()-setScriptsExecutablePatches = setScriptsExecutable_ . Just+module Darcs.Repository.Internal+ ( Repository(..)+ , maybeIdentifyRepository+ , identifyRepository+ , identifyRepositoryFor+ , IdentifyRepo(..)+ , findRepository+ , amInRepository+ , amNotInRepository+ , amInHashedRepository+ , revertRepositoryChanges+ , announceMergeConflicts+ , setTentativePending+ , checkUnrecordedConflicts+ , readRepo+ , readTentativeRepo+ , readRepoUsingSpecificInventory+ , prefsUrl+ , withRecorded+ , withTentative+ , tentativelyAddPatch+ , tentativelyRemovePatches+ , tentativelyRemovePatches_+ , tentativelyRemoveFromPending+ , tentativelyAddToPending+ , tentativelyAddPatch_+ , tentativelyAddPatches_+ , tentativelyReplacePatches+ , finalizeRepositoryChanges+ , unrevertUrl+ , applyToWorking+ , patchSetToPatches+ , createPristineDirectoryTree+ , createPartialsPristineDirectoryTree+ , reorderInventory+ , cleanRepository+ , setScriptsExecutable+ , setScriptsExecutablePatches+ , UpdatePristine(..)+ , MakeChanges(..)+ , applyToTentativePristine+ , makeNewPending+ , seekRepo+ ) where++import Prelude hiding ( catch )++import Darcs.Util.Printer ( putDocLn+ , (<+>)+ , text+ , ($$)+ , redText+ , putDocLnWith+ , ($$)+ )+import Darcs.Util.Printer.Color (fancyPrinters)++import Darcs.Repository.State ( readRecorded+ , readWorking+ , updateIndex+ )+import Darcs.Repository.LowLevel+ ( readPending+ , readTentativePending+ , writeTentativePending+ , readNewPending+ , writeNewPending+ , pendingName+ )+import System.Exit ( exitSuccess )+import Darcs.Repository.ApplyPatches+ ( runTolerantly+ , runSilently+ , runDefault+ )++import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Repository.Format ( RepoFormat+ , RepoProperty( HashedInventory+ , NoWorkingDir+ )+ , tryIdentifyRepoFormat+ , formatHas+ , readProblem+ , transferProblem+ )+import System.Directory ( doesDirectoryExist+ , setCurrentDirectory+ , createDirectoryIfMissing+ , doesFileExist+ )+import Control.Monad ( when+ , unless+ , filterM+ , void+ )++import Control.Applicative ( (<$>) )+import Control.Exception ( catch, IOException )++import qualified Data.ByteString as B ( readFile+ , isPrefixOf+ )+import qualified Data.ByteString.Char8 as BC (pack)+import Data.List.Ordered ( nubSort )+import Data.Maybe ( fromMaybe )+import Darcs.Patch ( Effect+ , primIsHunk+ , primIsBinary+ , description+ , tryToShrink+ , commuteFLorComplain+ , commute+ , fromPrim+ , RepoPatch+ , Patchy+ , merge+ , listConflictedFiles+ , listTouchedFiles+ , Named+ , commuteRL+ , fromPrims+ , readPatch+ , effect+ , invert+ , primIsAddfile+ , primIsAdddir+ , primIsSetpref+ , apply+ , applyToTree+ )++import Darcs.Patch.Dummy ( DummyPatch )++import Darcs.Patch.Apply ( ApplyState )++import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Prim ( PrimPatchBase+ , PrimOf+ , tryShrinkingInverse+ , PrimPatch+ )+import Darcs.Patch.Bundle ( scanBundle+ , makeBundleN+ )+import Darcs.Patch.Info ( isTag )+import Darcs.Patch.MaybeInternal ( flIsInternal )+import Darcs.Patch.Named ( patchcontents )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd+ , hopefully+ , info+ )+import qualified Darcs.Repository.HashedRepo as HashedRepo+ ( revertTentativeChanges+ , finalizeTentativeChanges+ , removeFromTentativeInventory+ , copyPristine+ , copyPartialsPristine+ , applyToTentativePristine+ , addToTentativeInventory+ , readTentativeRepo+ , readRepoUsingSpecificInventory+ , cleanPristine+ , cleanInventories+ , cleanPatches+ )+import qualified Darcs.Repository.Old as Old+ ( revertTentativeChanges+ , oldRepoFailMsg+ )+import Darcs.Repository.Flags+ ( Compression, Verbosity(..), UseCache(..), UpdateWorking (..), AllowConflicts (..), ExternalMerge (..)+ , WorkRepo (..), WithWorkingDir (WithWorkingDir) )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Unsafe+ ( unsafeCoerceP, unsafeCoercePStart )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..)+ , RL(..)+ , (:\/:)(..)+ , (:/\:)(..)+ , (:>)(..)+ , (+>+)+ , (+<+)+ , lengthFL+ , allFL+ , filterOutFLFL+ , reverseFL+ , mapFL_FL+ , concatFL+ , reverseRL+ , mapRL+ )+import Darcs.Patch.Witnesses.Sealed+ ( Sealed(Sealed)+ , seal+ , FlippedSeal(FlippedSeal)+ , flipSeal+ , mapSeal+ )+import Darcs.Patch.Permutations ( commuteWhatWeCanFL+ , removeFL+ )+import Darcs.Patch.Set ( PatchSet(..)+ , SealedPatchSet+ , newset2FL+ , newset2RL+ , Origin+ )+import Darcs.Patch.Depends ( removeFromPatchSet+ , mergeThem+ , splitOnTag+ )+import Darcs.Patch.Show ( ShowPatch )+import Darcs.Util.Path+ ( FilePathLike+ , AbsolutePath+ , toFilePath+ , ioAbsoluteOrRemote+ , toPath+ , anchorPath+ )+import Darcs.Util.Exception ( catchall )+import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Patch.Progress (progressFL)+import Darcs.Util.URL ( isValidLocalPath )+import Darcs.Util.Workaround+ ( getCurrentDirectory+ , renameFile+ , setExecutable+ )+import Darcs.Repository.Prefs ( getCaches )+import Darcs.Repository.Lock+ ( writeDocBinFile+ , removeFileMayNotExist+ )+import Darcs.Repository.InternalTypes( Repository(..)+ , Pristine(..)+ )+import Darcs.Util.Global ( darcsdir )++import System.Mem( performGC )++import qualified Storage.Hashed.Tree as Tree+import Storage.Hashed.Tree ( Tree )+import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk, doesPatchIndexExist )+import Darcs.Repository.Read ( readRepo )+#include "impossible.h"++-- | The status of a given directory: is it a darcs repository?+data IdentifyRepo p wR wU wT = BadRepository String -- ^ looks like a repository with some error+ | NonRepository String -- ^ safest guess+ | GoodRepository (Repository p wR wU wT)++-- | Tries to identify the repository in a given directory+maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo p wR wU wT)+maybeIdentifyRepository useCache "." =+ do darcs <- doesDirectoryExist darcsdir+ if not darcs+ then return (NonRepository $ "Missing " ++ darcsdir ++ " directory")+ else do+ repoFormatOrError <- tryIdentifyRepoFormat "."+ here <- toPath `fmap` ioAbsoluteOrRemote "."+ case repoFormatOrError of+ Left err -> return $ NonRepository err+ Right rf ->+ case readProblem rf of+ Just err -> return $ BadRepository err+ Nothing -> do pris <- identifyPristine+ cs <- getCaches useCache here+ return $ GoodRepository $ Repo here rf pris cs+maybeIdentifyRepository useCache url' =+ do url <- toPath `fmap` ioAbsoluteOrRemote url'+ repoFormatOrError <- tryIdentifyRepoFormat url+ case repoFormatOrError of+ Left e -> return $ NonRepository e+ Right rf -> case readProblem rf of+ Just err -> return $ BadRepository err+ Nothing -> do cs <- getCaches useCache url+ return $ GoodRepository $ Repo url rf NoPristine cs++identifyPristine :: IO Pristine+identifyPristine =+ do pristine <- doesDirectoryExist $ darcsdir++"/pristine"+ current <- doesDirectoryExist $ darcsdir++"/current"+ hashinv <- doesFileExist $ darcsdir++"/hashed_inventory"+ case (pristine || current, hashinv) of+ (False, False) -> return NoPristine+ (True, False) -> return PlainPristine+ (False, True ) -> return HashedPristine+ _ -> fail "Multiple pristine trees."++-- | identifyRepository identifies the repo at 'url'. Warning:+-- you have to know what kind of patches are found in that repo.+identifyRepository :: forall p wR wU wT. UseCache -> String+ -> IO (Repository p wR wU wT)+identifyRepository useCache url =+ do er <- maybeIdentifyRepository useCache url+ case er of+ BadRepository s -> fail s+ NonRepository s -> fail s+ GoodRepository r -> return r++-- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url',+-- but fails if it is not compatible for reading from and writing to.+identifyRepositoryFor :: forall p wR wU wT vR vU vT. RepoPatch p+ => Repository p wR wU wT+ -> UseCache+ -> String+ -> IO (Repository p vR vU vT)+identifyRepositoryFor (Repo _ source _ _) useCache url =+ do Repo absurl target x c <- identifyRepository useCache url+ case transferProblem target source of+ Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e+ Nothing -> return $ Repo absurl target x c++amInRepository :: WorkRepo -> IO (Either String ())+amInRepository (WorkRepoDir d) = do+ setCurrentDirectory d `catchall` fail ("can't set directory to "++d)+ status <- maybeIdentifyRepository YesUseCache "."+ case status of+ GoodRepository _ -> return (Right ())+ BadRepository e -> return (Left $ "While " ++ d ++ " looks like a repository directory, we have a problem with it:\n" ++ e)+ NonRepository _ -> return (Left "You need to be in a repository directory to run this command.")+amInRepository _ =+ fromMaybe (Left "You need to be in a repository directory to run this command.") <$> seekRepo++amInHashedRepository :: WorkRepo -> IO (Either String ())+amInHashedRepository wd+ = do inrepo <- amInRepository wd+ case inrepo of+ Right _ -> do pristine <- identifyPristine+ case pristine of+ HashedPristine -> return (Right ())+ _ -> return (Left Old.oldRepoFailMsg)+ left -> return left++-- | hunt upwards for the darcs repository+-- This keeps changing up one parent directory, testing at each+-- step if the current directory is a repository or not. $+-- The result is:+-- Nothing, if no repository found+-- Just (Left errorMessage), if bad repository found+-- Just (Right ()), if good repository found.+-- WARNING this changes the current directory for good if matchFn succeeds+seekRepo :: IO (Maybe (Either String ()))+seekRepo = getCurrentDirectory >>= helper where+ helper startpwd = do+ status <- maybeIdentifyRepository YesUseCache "."+ case status of+ GoodRepository _ -> return . Just $ Right ()+ BadRepository e -> return . Just $ Left e+ NonRepository _ ->+ do cd <- toFilePath `fmap` getCurrentDirectory+ setCurrentDirectory ".."+ cd' <- toFilePath `fmap` getCurrentDirectory+ if cd' /= cd+ then helper startpwd+ else do setCurrentDirectory startpwd+ return Nothing++-- The performGC in this function is a workaround for a library/GHC bug,+-- http://hackage.haskell.org/trac/ghc/ticket/2924 -- (doesn't seem to be a+-- problem on fast machines, but virtual ones trip this from time to time)+amNotInRepository :: WorkRepo -> IO (Either String ())+amNotInRepository (WorkRepoDir d) = do+ createDirectoryIfMissing False d+ `catchall` (performGC >> createDirectoryIfMissing False d)+ -- note that the above could always fail+ setCurrentDirectory d+ amNotInRepository WorkRepoCurrentDir+amNotInRepository _ = do+ status <- maybeIdentifyRepository YesUseCache "."+ case status of+ GoodRepository _ -> return (Left "You may not run this command in a repository.")+ BadRepository e -> return (Left $ "You may not run this command in a repository.\nBy the way, we have a problem with it:\n" ++ e)+ NonRepository _ -> return (Right ())++findRepository :: WorkRepo -> IO (Either String ())+findRepository (WorkRepoPossibleURL d) | isValidLocalPath d =+ do setCurrentDirectory d `catchall` fail ("can't set directory to "++d)+ findRepository WorkRepoCurrentDir+findRepository (WorkRepoDir d) =+ do setCurrentDirectory d `catchall` fail ("can't set directory to "++d)+ findRepository WorkRepoCurrentDir+findRepository _ = fromMaybe (Right ()) <$> seekRepo++-- TODO: see also Repository.State.readPendingLL ... to be removed after GHC 7.2+readNewPendingLL :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> IO (Sealed ((FL p) wT))+readNewPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` readNewPending repo+++-- | @makeNewPending repo YesUpdateWorking pendPs@ verifies that the+-- @pendPs@ could be applied to pristine if we wanted to, and if so+-- writes it to disk. If it can't be applied, @pendPs@ must+-- be somehow buggy, so we save it for forensics and crash.+makeNewPending :: forall p wR wU wT wY. (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> UpdateWorking+ -> FL (PrimOf p) wT wY+ -> IO ()+makeNewPending _ NoUpdateWorking _ = return ()+makeNewPending repo@(Repo r _ _ _) YesUpdateWorking origp =+ withCurrentDirectory r $+ do let newname = pendingName ++ ".new"+ debugMessage $ "Writing new pending: " ++ newname+ Sealed sfp <- return $ siftForPending origp+ writeNewPending repo sfp+ cur <- readRecorded repo+ Sealed p <- readNewPendingLL repo -- :: IO (Sealed (FL (PrimOf p) wT))+ -- We don't ever use the resulting tree.+ _ <- catch (applyToTree p cur) $ \(err :: IOException) -> do+ let buggyname = pendingName ++ "_buggy"+ renameFile newname buggyname+ bugDoc $ text ("There was an attempt to write an invalid pending! " ++ show err)+ $$ text "If possible, please send the contents of"+ <+> text buggyname+ $$ text "along with a bug report."+ renameFile newname pendingName+ debugMessage $ "Finished writing new pending: " ++ newname++-- | @siftForPending ps@ simplifies the candidate pending patch @ps@+-- through a combination of looking for self-cancellations+-- (sequences of patches followed by their inverses), coalescing,+-- and getting rid of any hunk/binary patches we can commute out+-- the back+--+-- The visual image of sifting can be quite helpful here. We are+-- repeatedly tapping (shrinking) the patch sequence and+-- shaking it (sift). Whatever falls out is the pending we want+-- to keep. We do this until the sequence looks about as clean as+-- we can get it+siftForPending :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> Sealed (FL prim wX)+siftForPending simple_ps =+ if allFL (\p -> primIsAddfile p || primIsAdddir p) oldps+ then seal oldps+ else fromJust $ do+ Sealed x <- return $ sift NilFL $ reverseFL oldps+ return $ case tryToShrink x of+ ps | lengthFL ps < lengthFL oldps -> siftForPending ps+ | otherwise -> seal ps+ where+ oldps = fromMaybe simple_ps $ tryShrinkingInverse $ crudeSift simple_ps+ -- get rid of any hunk/binary patches that we can commute out the+ -- back (ie. we work our way backwards, pushing the patches down+ -- to the very end and popping them off; so in (addfile f :> hunk)+ -- we can nuke the hunk, but not so in (hunk :> replace)+ sift :: FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC)+ sift sofar NilRL = seal sofar+ sift sofar (p:<:ps) | primIsHunk p || primIsBinary p =+ case commuteFLorComplain (p :> sofar) of+ Right (sofar' :> _) -> sift sofar' ps+ Left _ -> sift (p:>:sofar) ps+ sift sofar (p:<:ps) = sift (p:>:sofar) ps++readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> IO (PatchSet p Origin wT)+readTentativeRepo repo@(Repo r rf _ _)+ | formatHas HashedInventory rf = HashedRepo.readTentativeRepo repo r+ | otherwise = fail Old.oldRepoFailMsg++readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree)+ => String+ -> Repository p wR wU wT+ -> IO (PatchSet p Origin wT)+readRepoUsingSpecificInventory invPath repo@(Repo r rf _ _)+ | formatHas HashedInventory rf =+ HashedRepo.readRepoUsingSpecificInventory invPath repo r+ | otherwise = fail Old.oldRepoFailMsg++prefsUrl :: Repository p wR wU wT -> String+prefsUrl (Repo r _ _ _) = r ++ "/"++darcsdir++"/prefs"++unrevertUrl :: Repository p wR wU wT -> String+unrevertUrl (Repo r _ _ _) = r ++ "/"++darcsdir++"/patches/unrevert"++applyToWorking :: (ApplyState (PrimOf p) ~ Tree, RepoPatch p)+ => Repository p wR wU wT -> Verbosity -> FL (PrimOf p) wU wY+ -> IO (Repository p wR wY wT)+applyToWorking (Repo r rf t c) verb patch =+ do+ unless (formatHas NoWorkingDir rf) $+ withCurrentDirectory r $ if verb == Quiet+ then runSilently $ apply patch+ else runTolerantly $ apply patch+ return (Repo r rf t c)++-- | @tentativelyRemoveFromPending p@ is used by Darcs whenever it+-- adds a patch to the repository (eg. with apply or record).+-- Think of it as one part of transferring patches from pending to+-- somewhere else.+--+-- Question (Eric Kow): how do we detect patch equivalence?+tentativelyRemoveFromPending :: forall p wR wU wT wX wY. (RepoPatch p)+ => Repository p wR wU wT+ -> UpdateWorking+ -> PatchInfoAnd p wX wY+ -> IO ()+tentativelyRemoveFromPending _ NoUpdateWorking _ = return ()+tentativelyRemoveFromPending repo YesUpdateWorking p = do+ Sealed pend <- readTentativePending repo+ -- Question (Eric Kow): why does pending being all simple matter for+ -- changepref patches in p? isSimple includes changepref, so what do+ -- adddir/etc have to do with it? Why don't we we systematically+ -- crudeSift/not?+ let effectp = if allFL isSimple pend+ then crudeSift $ effect p+ else effect p+ Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp)+ (unsafeCoercePStart pend)+ writeTentativePending repo (unsafeCoercePStart newpend)+ where+ -- @rmpend effect pending@ removes as much of @effect@ from @pending@+ -- as possible+ --+ -- Note that @effect@ and @pending@ must start from the same context+ -- This is not a bad thing to assume because @effect@ is a patch we want to+ -- add to the repository anyway so it'd kind of have to start from wR anyway+ --+ -- Question (Eric Kow), ok then why not+ -- @PatchInfoAnd p wR wY@ in the type signature above?+ rmpend :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB)+ rmpend NilFL x = Sealed x+ rmpend _ NilFL = Sealed NilFL+ rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys+ rmpend (x:>:xs) ys =+ case commuteWhatWeCanFL (x:>xs) of+ a:>x':>b -> case rmpend a ys of+ Sealed ys' -> case commute (invert (x':>:b) :> ys') of+ Just (ys'' :> _) -> seal ys''+ Nothing -> seal $ invert (x':>:b)+>+ys'+ -- DJR: I don't think this last case should be+ -- reached, but it also shouldn't lead to corruption.++isSimple :: PrimPatch prim => prim wX wY -> Bool+isSimple x = primIsHunk x || primIsBinary x || primIsSetpref x++-- This seems to do the opposite of sifting, ie. we retain hunk/binary patches+-- but delete changepref patches.+--+-- Why not just filterOutFLFL (not . primIsSetpref)? Is it important to only+-- have this behaviour when all other patches are either hunk or binary?+crudeSift :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> FL prim wX wY+crudeSift xs = if allFL isSimple xs then filterOutFLFL ishunkbinary xs else xs+ where ishunkbinary :: prim wA wB -> EqCheck wA wB+ ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq+ | otherwise = NotEq++data HashedVsOld a = HvsO { old, hashed :: a }++decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a+decideHashedOrNormal rf (HvsO { hashed = h, old = o })+ | formatHas HashedInventory rf = h+ | otherwise = o++data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq )++announceMergeConflicts :: (PrimPatch p, PatchInspect p)+ => String+ -> AllowConflicts+ -> ExternalMerge+ -> FL p wX wY+ -> IO Bool+announceMergeConflicts cmd allowConflicts externalMerge resolved_pw =+ case nubSort $ listTouchedFiles resolved_pw of+ [] -> return False+ cfs -> if allowConflicts `elem` [YesAllowConflicts,YesAllowConflictsAndMark]+ || externalMerge /= NoExternalMerge+ then do putDocLnWith fancyPrinters $+ redText "We have conflicts in the following files:" $$ text (unlines cfs)+ return True+ else do putDocLnWith fancyPrinters $+ redText "There are conflicts in the following files:" $$ text (unlines cfs)+ fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"+++ "If you would rather apply the patch and mark the conflicts,\n"+++ "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"+++ "These can set as defaults by adding\n"+++ " "++cmd++" mark-conflicts\n"+++ "to "++darcsdir++"/prefs/defaults in the target repo. "++checkUnrecordedConflicts :: forall p wT wY. RepoPatch p+ => UpdateWorking+ -> FL (Named p) wT wY+ -> IO Bool+checkUnrecordedConflicts NoUpdateWorking _+ = return False -- because we are called by `darcs convert` hence we don't care+checkUnrecordedConflicts _ pc =+ do repository <- identifyRepository NoUseCache "."+ cuc repository+ where cuc :: Repository p wR wU wT -> IO Bool+ cuc r = do Sealed (mpend :: FL (PrimOf p) wT wX) <- readPending r :: IO (Sealed (FL (PrimOf p) wT))+ case mpend of+ NilFL -> return False+ pend ->+ case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of+ _ :/\: pend' ->+ case listConflictedFiles pend' of+ [] -> return False+ fs -> do putStrLn ("You have conflicting local changes to:\n"+ ++ unwords fs)+ confirmed <- promptYorn "Proceed?"+ unless confirmed $+ do putStrLn "Cancelled."+ exitSuccess+ return True+ fromPrims_ :: FL (PrimOf p) wA wB -> FL p wA wB+ fromPrims_ = fromPrims++tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> Compression+ -> Verbosity+ -> UpdateWorking+ -> PatchInfoAnd p wT wY+ -> IO (Repository p wR wU wY)+tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine++data UpdatePristine = UpdatePristine + | DontUpdatePristine+ | DontUpdatePristineNorRevert deriving Eq++tentativelyAddPatches_+ :: forall p wR wU wT wY+ . (RepoPatch p, ApplyState p ~ Tree)+ => UpdatePristine+ -> Repository p wR wU wT+ -> Compression+ -> Verbosity+ -> UpdateWorking+ -> FL (PatchInfoAnd p) wT wY+ -> IO (Repository p wR wU wY)+tentativelyAddPatches_ _up r _compr _verb _uw NilFL = return r+tentativelyAddPatches_ up r compr verb uw (p:>:ps) = do+ r' <- tentativelyAddPatch_ up r compr verb uw p+ tentativelyAddPatches_ up r' compr verb uw ps++-- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun+-- :: Bool, with dryRun = unsafePerformIO $ readIORef ...+tentativelyAddPatch_ :: forall p wR wU wT wY+ . (RepoPatch p, ApplyState p ~ Tree)+ => UpdatePristine+ -> Repository p wR wU wT+ -> Compression+ -> Verbosity+ -> UpdateWorking+ -> PatchInfoAnd p wT wY+ -> IO (Repository p wR wU wY)++tentativelyAddPatch_ up r@(Repo dir rf t c) compr verb uw p =+ withCurrentDirectory dir $ do+ decideHashedOrNormal rf HvsO {+ hashed = void $ HashedRepo.addToTentativeInventory c compr p,+ old = fail Old.oldRepoFailMsg}+ when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."+ applyToTentativePristine r verb p+ debugMessage "Updating pending..."+ tentativelyRemoveFromPending r uw p+ return (Repo dir rf t c)++applyToTentativePristine :: (ApplyState q ~ Tree, Effect q, Patchy q, ShowPatch q, PrimPatchBase q)+ => Repository p wR wU wT+ -> Verbosity+ -> q wT wY+ -> IO ()+applyToTentativePristine (Repo dir rf _ _) verb p =+ withCurrentDirectory dir $+ do when (verb == Verbose) $ putDocLn $ text "Applying to pristine..." <+> description p+ decideHashedOrNormal rf HvsO {hashed = HashedRepo.applyToTentativePristine p,+ old = fail Old.oldRepoFailMsg}++-- | @tentativelyAddToPending repo NoDryRun YesUpdateWorking pend ps@+-- appends @ps@ to the pending patch.+--+-- It has no effect with @NoUpdateWorking@.+--+-- This fuction is unsafe because it accepts a patch that works on the+-- tentative pending and we don't currently track the state of the+-- tentative pending.+tentativelyAddToPending :: forall p wR wU wT wX wY. RepoPatch p+ => Repository p wR wU wT+ -> UpdateWorking+ -> FL (PrimOf p) wX wY+ -> IO ()+tentativelyAddToPending _ NoUpdateWorking _ = return ()+tentativelyAddToPending repo@(Repo dir _ _ _) YesUpdateWorking patch =+ withCurrentDirectory dir $ do+ Sealed pend <- readTentativePending repo+ FlippedSeal newpend_ <- return $+ newpend (unsafeCoerceP pend :: FL (PrimOf p) wA wX) patch+ writeTentativePending repo (unsafeCoercePStart newpend_)+ where+ newpend :: FL prim wA wB -> FL prim wB wC -> FlippedSeal (FL prim) wC+ newpend NilFL patch_ = flipSeal patch_+ newpend p patch_ = flipSeal $ p +>+ patch_++-- | setTentativePending is basically unsafe. It overwrites the pending+-- state with a new one, not related to the repository state.+setTentativePending :: forall p wR wU wT wX wY. RepoPatch p+ => Repository p wR wU wT+ -> UpdateWorking+ -> FL (PrimOf p) wX wY+ -> IO ()+setTentativePending _ NoUpdateWorking _ = return ()+setTentativePending repo@(Repo dir _ _ _) YesUpdateWorking patch = do+ Sealed prims <- return $ siftForPending patch+ withCurrentDirectory dir $ writeTentativePending repo (unsafeCoercePStart prims)++-- | @prepend repo YesUpdateWorking ps@ prepends @ps@ to the pending patch+-- It's used right before removing @ps@ from the repo. This ensures that+-- the pending patch can still be applied on top of the recorded state.+--+-- This function is basically unsafe. It overwrites the pending state+-- with a new one, not related to the repository state.+prepend :: forall p wR wU wT wX wY. RepoPatch p+ => Repository p wR wU wT+ -> UpdateWorking+ -> FL (PrimOf p) wX wY+ -> IO ()+prepend _ NoUpdateWorking _ = return ()+prepend repo YesUpdateWorking patch = do+ Sealed pend <- readTentativePending repo+ Sealed newpend_ <- return $ newpend (unsafeCoerceP pend) patch+ writeTentativePending repo (unsafeCoercePStart $ crudeSift newpend_)+ where+ newpend :: FL prim wB wC -> FL prim wA wB -> Sealed (FL prim wA)+ newpend NilFL patch_ = seal patch_+ newpend p patch_ = seal $ patch_ +>+ p++tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> Compression+ -> UpdateWorking+ -> FL (PatchInfoAnd p) wX wT+ -> IO (Repository p wR wU wX)+tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine++tentativelyRemovePatches_ :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree)+ => UpdatePristine+ -> Repository p wR wU wT+ -> Compression+ -> UpdateWorking+ -> FL (PatchInfoAnd p) wX wT+ -> IO (Repository p wR wU wX)+tentativelyRemovePatches_ up repository@(Repo dir rf t c) compr uw ps =+ withCurrentDirectory dir $ do+ when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."+ prepend repository uw $ effect ps+ unless (up == DontUpdatePristineNorRevert) $ removeFromUnrevertContext repository ps+ debugMessage "Removing changes from tentative inventory..."+ if formatHas HashedInventory rf+ then do HashedRepo.removeFromTentativeInventory repository compr ps+ when (up == UpdatePristine) $+ HashedRepo.applyToTentativePristine $+ progressFL "Applying inverse to pristine" $ invert ps+ else fail Old.oldRepoFailMsg+ return (Repo dir rf t c)++-- FIXME this is a rather weird API. If called with a patch that isn't already+-- in the repo, it fails with an obscure error from 'commuteToEnd'. It also+-- ends up redoing the work that the caller has already done - if it has+-- already commuted these patches to the end, it must also know the commuted+-- versions of the other patches in the repo.+-- |Given a sequence of patches anchored at the end of the current repository,+-- actually pull them to the end of the repository by removing any patches+-- with the same name and then adding the passed in sequence.+-- Typically callers will have obtained the passed in sequence using+-- 'findCommon' and friends.+tentativelyReplacePatches :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> Compression+ -> UpdateWorking+ -> Verbosity+ -> FL (PatchInfoAnd p) wX wT+ -> IO ()+tentativelyReplacePatches repository compr uw verb ps =+ do let ps' = filterOutFLFL (flIsInternal . patchcontents . hopefully) ps+ repository' <- tentativelyRemovePatches_ DontUpdatePristineNorRevert repository compr uw ps'+ mapAdd repository' ps'+ where mapAdd :: Repository p wM wL wI+ -> FL (PatchInfoAnd p) wI wJ+ -> IO ()+ mapAdd _ NilFL = return ()+ mapAdd r (a:>:as) =+ do r' <- tentativelyAddPatch_ DontUpdatePristine r compr verb uw a+ mapAdd r' as++-- | Replace the pending patch with the tentative pending.+-- If @NoUpdateWorking@, this merely deletes the tentative pending+-- without replacing the current one.+--+-- Question (Eric Kow): shouldn't this also delete the tentative+-- pending if @YesUpdateWorking@? I'm just puzzled by the seeming+-- inconsistency of the @NoUpdateWorking@ doing deletion, but+-- @YesUpdateWorking@ not bothering.+finalizePending :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> UpdateWorking+ -> IO ()+finalizePending (Repo dir _ _ _) NoUpdateWorking =+ withCurrentDirectory dir $ removeFileMayNotExist pendingName+finalizePending repository@(Repo dir _ _ _) updateWorking@YesUpdateWorking =+ withCurrentDirectory dir $ do+ Sealed tpend <- readTentativePending repository+ Sealed new_pending <- return $ siftForPending tpend+ makeNewPending repository updateWorking new_pending++finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> UpdateWorking+ -> Compression+ -> IO ()+finalizeRepositoryChanges repository@(Repo dir rf _ _) updateWorking compr+ | formatHas HashedInventory rf =+ withCurrentDirectory dir $ do+ debugMessage "Finalizing changes..."+ withSignalsBlocked $ do+ HashedRepo.finalizeTentativeChanges repository compr+ finalizePending repository updateWorking+ debugMessage "Done finalizing changes..."+ doesPatchIndexExist dir >>= (`when` createOrUpdatePatchIndexDisk repository)+ updateIndex repository+ | otherwise = fail Old.oldRepoFailMsg++-- TODO: rename this and document the transaction protocol (revert/finalize)+-- clearly.+-- |Slightly confusingly named: as well as throwing away any tentative+-- changes, revertRepositoryChanges also re-initialises the tentative state.+-- It's therefore used before makign any changes to the repo.+revertRepositoryChanges :: RepoPatch p+ => Repository p wR wU wT+ -> UpdateWorking+ -> IO ()+revertRepositoryChanges r@(Repo dir rf _ _) uw =+ withCurrentDirectory dir $+ do removeFileMayNotExist (pendingName ++ ".tentative")+ Sealed x <- readPending r+ setTentativePending r uw x+ when (uw == NoUpdateWorking) $ removeFileMayNotExist pendingName+ decideHashedOrNormal rf HvsO { hashed = HashedRepo.revertTentativeChanges,+ old = Old.revertTentativeChanges }++patchSetToPatches :: RepoPatch p => PatchSet p wX wY -> FL (Named p) wX wY+patchSetToPatches patchSet = mapFL_FL hopefully $ newset2FL patchSet++removeFromUnrevertContext :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> FL (PatchInfoAnd p) wX wT+ -> IO ()+removeFromUnrevertContext repository ps = do+ Sealed bundle <- unrevert_patch_bundle `catchall` return (seal (PatchSet NilRL NilRL))+ remove_from_unrevert_context_ bundle+ where unrevert_impossible =+ do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?"+ if confirmed then removeFileMayNotExist (unrevertUrl repository)+ else fail "Cancelled."+ unrevert_patch_bundle :: IO (SealedPatchSet p Origin)+ unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository)+ case scanBundle pf of+ Right foo -> return foo+ Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err+ remove_from_unrevert_context_ :: PatchSet p Origin wZ -> IO ()+ remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return ()+ remove_from_unrevert_context_ bundle =+ do debugMessage "Adjusting the context of the unrevert changes..."+ debugMessage $ "Removing "++ show (lengthFL ps) +++ " patches in removeFromUnrevertContext!"+ ref <- readTentativeRepo repository+ let withSinglet :: Sealed (FL ppp wXxx)+ -> (forall wYyy . ppp wXxx wYyy -> IO ()) -> IO ()+ withSinglet (Sealed (x :>: NilFL)) j = j x+ withSinglet _ _ = return ()+ withSinglet (mergeThem ref bundle) $ \h_us ->+ case commuteRL (reverseFL ps :> h_us) of+ Nothing -> unrevert_impossible+ Just (us' :> _) ->+ case removeFromPatchSet ps ref of+ Nothing -> unrevert_impossible+ Just common ->+ do debugMessage "Have now found the new context..."+ bundle' <- makeBundleN Nothing common (hopefully us':>:NilFL)+ writeDocBinFile (unrevertUrl repository) bundle'+ debugMessage "Done adjusting the context of the unrevert changes!"++cleanRepository :: RepoPatch p => Repository p wR wU wT -> IO ()+cleanRepository repository@(Repo _ rf _ _) =+ decideHashedOrNormal rf+ HvsO { hashed = cleanHashedRepo repository,+ old = fail Old.oldRepoFailMsg}+ where+ cleanHashedRepo r = do+ HashedRepo.cleanPristine r+ HashedRepo.cleanInventories r+ HashedRepo.cleanPatches r+++-- | grab the pristine hash of _darcs/hash_inventory, and retrieve whole pristine tree,+-- possibly writing a clean working copy in the process.+createPristineDirectoryTree :: RepoPatch p => Repository p wR wU wT -> FilePath -> WithWorkingDir -> IO ()+createPristineDirectoryTree (Repo r rf _ c) reldir wwd+ | formatHas HashedInventory rf =+ do createDirectoryIfMissing True reldir+ withCurrentDirectory reldir $ HashedRepo.copyPristine c r (darcsdir++"/hashed_inventory") wwd+ | otherwise = fail Old.oldRepoFailMsg++-- fp below really should be FileName+-- | Used by the commands dist and diff+createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p)+ => Repository p wR wU wT+ -> [fp]+ -> FilePath+ -> IO ()+createPartialsPristineDirectoryTree (Repo r rf _ c) prefs dir+ | formatHas HashedInventory rf =+ do createDirectoryIfMissing True dir+ withCurrentDirectory dir $+ HashedRepo.copyPartialsPristine c r (darcsdir++"/hashed_inventory") prefs+ | otherwise = fail Old.oldRepoFailMsg++withRecorded :: RepoPatch p+ => Repository p wR wU wT+ -> ((AbsolutePath -> IO a) -> IO a)+ -> (AbsolutePath -> IO a)+ -> IO a+withRecorded repository mk_dir f+ = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) WithWorkingDir+ f d++withTentative :: forall p a wR wU wT. (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> ((AbsolutePath -> IO a) -> IO a)+ -> (AbsolutePath -> IO a)+ -> IO a+withTentative (Repo dir rf _ c) mk_dir f+ | formatHas HashedInventory rf =+ mk_dir $ \d -> do HashedRepo.copyPristine+ c+ dir+ (darcsdir++"/tentative_pristine")+ WithWorkingDir+ f d+withTentative repository@(Repo dir _ _ _) mk_dir f =+ withRecorded repository mk_dir $ \d ->+ do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine")+ runDefault $ apply ps+ f d+ where read_patches :: FilePath -> IO (Sealed (FL p wX))+ read_patches fil = do ps <- B.readFile fil+ return $ fromMaybe (seal NilFL) $ readPatch ps++-- | Sets scripts in or below the current directory executable.+-- A script is any file that starts with the bytes '#!'.+-- This is used for --set-scripts-executable.+setScriptsExecutable_ :: PatchInspect p => Maybe (p wX wY) -> IO ()+setScriptsExecutable_ pw = do+ debugMessage "Making scripts executable"+ tree <- readWorking+ paths <- case pw of+ Just ps -> filterM doesFileExist $ listTouchedFiles ps+ Nothing -> return [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ]+ let setExecutableIfScript f =+ do contents <- B.readFile f+ when (BC.pack "#!" `B.isPrefixOf` contents) $ do+ debugMessage ("Making executable: " ++ f)+ setExecutable f True+ mapM_ setExecutableIfScript paths++setScriptsExecutable :: IO ()+setScriptsExecutable = setScriptsExecutable_ (Nothing :: Maybe (FL DummyPatch wX wY))++setScriptsExecutablePatches :: PatchInspect p => p wX wY -> IO ()+setScriptsExecutablePatches = setScriptsExecutable_ . Just+++-- | Writes out a fresh copy of the inventory that minimizes the+-- amount of inventory that need be downloaded when people pull from+-- the repository.+--+-- Specifically, it breaks up the inventory on the most recent tag.+-- This speeds up most commands when run remotely, both because a+-- smaller file needs to be transfered (only the most recent+-- inventory). It also gives a guarantee that all the patches prior+-- to a given tag are included in that tag, so less commutation and+-- history traversal is needed. This latter issue can become very+-- important in large repositories.+reorderInventory :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wR+ -> Compression+ -> UpdateWorking+ -> Verbosity+ -> IO ()+reorderInventory repository@(Repo _ rf _ _) compr uw verb =+ decideHashedOrNormal rf HvsO {+ hashed = do+ debugMessage "Reordering the inventory."+ PatchSet ps _ <- misplacedPatches `fmap` readRepo repository+ tentativelyReplacePatches repository compr uw verb $ reverseRL ps+ HashedRepo.finalizeTentativeChanges repository compr+ debugMessage "Done reordering the inventory.",+ old = fail Old.oldRepoFailMsg }++-- | Returns the patches that make the most recent tag dirty.+misplacedPatches :: forall p wS wX . RepoPatch p+ => PatchSet p wS wX+ -> PatchSet p wS wX+misplacedPatches ps = + -- Filter the repository keeping only with the tags, ordered from the+ -- most recent.+ case filter isTag $ mapRL info $ newset2RL ps of+ [] -> ps+ (lt:_) -> + -- Take the most recent tag, and split the repository in,+ -- the clean PatchSet "up to" the tag (ts), and a RL of+ -- patches after the tag (r).+ case splitOnTag lt ps of+ Just (PatchSet xs ts :> r) -> PatchSet (r+<+xs) ts+ _ -> impossible -- Because the tag is in ps.++
src/Darcs/Repository/InternalTypes.hs view
@@ -16,15 +16,13 @@ {-# LANGUAGE CPP #-} -#include "gadts.h" -module Darcs.Repository.InternalTypes ( Repository(..), RepoType(..), Pristine(..)- , extractCache, extractOptions, modifyCache+module Darcs.Repository.InternalTypes ( Repository(..), Pristine(..)+ , extractCache, modifyCache ) where import Data.List ( nub, sortBy ) import Darcs.Repository.Cache ( Cache (..) , compareByLocality )-import Darcs.Flags ( DarcsFlag ) import Darcs.Repository.Format ( RepoFormat ) import Darcs.Patch ( RepoPatch ) @@ -34,20 +32,21 @@ | HashedPristine deriving ( Show, Eq ) -data Repository (p :: * C(-> * -> *)) C(recordedstate unrecordedstate tentativestate) =- Repo !String ![DarcsFlag] !RepoFormat !(RepoType p) deriving ( Show )--data RepoType (p :: * C(-> * -> *)) = DarcsRepository !Pristine Cache deriving ( Show )--extractCache :: Repository p C(r u t) -> Cache-extractCache (Repo _ _ _ (DarcsRepository _ c)) = c+-- |A @Repository@ is a token representing the state of a repository on disk.+-- It is parameterized by the patch type in the repository, and witnesses for+-- the recorded state of the repository (i.e. what darcs get would retrieve),+-- the unrecorded state (what's in the working directory now),+-- and the tentative state, which represents work in progress that will+-- eventually become the new recorded state unless something goes wrong.+data Repository (p :: * -> * -> *) wRecordedstate wUnrecordedstate wTentativestate =+ Repo !String !RepoFormat !Pristine Cache deriving ( Show ) -extractOptions :: Repository p C(r u t) -> [DarcsFlag]-extractOptions (Repo _ opts _ _) = opts+extractCache :: Repository p wR wU wT -> Cache+extractCache (Repo _ _ _ c) = c -- | 'modifyCache' @repository function@ modifies the cache of -- @repository@ with @function@, remove duplicates and sort the results with 'compareByLocality'.-modifyCache :: FORALL(p r u t) (RepoPatch p) => Repository p C(r u t) -> (Cache -> Cache) -> Repository p C(r u t)-modifyCache (Repo dir opts rf (DarcsRepository pristine cache)) f = Repo dir opts rf dr- where dr = DarcsRepository pristine . cmap ( sortBy compareByLocality . nub ) $ f cache- cmap g (Ca c) = Ca (g c)+modifyCache :: forall p wR wU wT . (RepoPatch p) => Repository p wR wU wT -> (Cache -> Cache) -> Repository p wR wU wT+modifyCache (Repo dir rf pristine cache) f+ = Repo dir rf pristine $ cmap ( sortBy compareByLocality . nub ) $ f cache+ where cmap g (Ca c) = Ca (g c)
+ src/Darcs/Repository/Job.hs view
@@ -0,0 +1,236 @@+-- Copyright (C) 2002-2004,2007-2008 David Roundy+-- Copyright (C) 2005 Juliusz Chroboczek+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes #-}+{-# LANGUAGE ForeignFunctionInterface #-}++module Darcs.Repository.Job+ ( RepoJob(..)+ , withRepoLock+ , withRepoLockCanFail+ , withRepository+ , withRepositoryDirectory+ ) where+++import Darcs.Util.Global ( darcsdir )++import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.V1 ( Patch )+import Darcs.Patch.V2 ( RealPatch )+import Darcs.Patch.Named ( Named )+import Darcs.Patch.Prim.V1 ( Prim )+import Darcs.Patch.Prim ( PrimOf )+import Darcs.Patch.Rebase ( Rebasing )+import Darcs.Patch.RepoPatch ( RepoPatch )++import Darcs.Repository.Flags+ ( UseCache(..), UpdateWorking(..), DryRun(..), UMask (..)+ , Compression, Verbosity )+import Darcs.Repository.Format+ ( RepoProperty( Darcs2+ , RebaseInProgress+ )+ , formatHas+ , writeProblem+ )+import Darcs.Repository.Internal+ ( identifyRepository+ , revertRepositoryChanges+ )+import Darcs.Repository.InternalTypes ( Repository(..) )+import Darcs.Repository.Rebase+ ( repoJobOnRebaseRepo+ , startRebaseJob+ , rebaseJob+ )+import Darcs.Repository.Lock ( withLock, withLockCanFail )++import Darcs.Util.Progress ( debugMessage )++import Control.Monad ( when )+import Control.Exception ( bracket_ )++import Foreign.C.String ( CString, withCString )+import Foreign.C.Error ( throwErrno )+import Foreign.C.Types ( CInt(..) )++import Storage.Hashed.Tree ( Tree )++#include "impossible.h"++getUMask :: UMask -> Maybe String+getUMask (YesUMask s) = Just s+getUMask NoUMask = Nothing++withUMaskFlag :: UMask -> IO a -> IO a+withUMaskFlag = maybe id withUMask . getUMask++foreign import ccall unsafe "umask.h set_umask" set_umask+ :: CString -> IO CInt+foreign import ccall unsafe "umask.h reset_umask" reset_umask+ :: CInt -> IO CInt++withUMask :: String+ -> IO a+ -> IO a+withUMask umask job =+ do rc <- withCString umask set_umask+ when (rc < 0) (throwErrno "Couldn't set umask")+ bracket_+ (return ())+ (reset_umask rc)+ job++-- |A @RepoJob@ wraps up an action to be performed with a repository. Because repositories+-- can contain different types of patches, such actions typically need to be polymorphic+-- in the kind of patch they work on. @RepoJob@ is used to wrap up the polymorphism,+-- and the various functions that act on a @RepoJob@ are responsible for instantiating+-- the underlying action with the appropriate patch type.+data RepoJob a+ -- = RepoJob (forall p wR wU . RepoPatch p => Repository p wR wU wR -> IO a)+ -- TODO: Unbind Tree from RepoJob, possibly renaming existing RepoJob+ =+ -- |The most common @RepoJob@; the underlying action can accept any patch type that+ -- a darcs repository may use.+ RepoJob (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)+ => Repository p wR wU wR -> IO a)+ -- |A job that only works on darcs 1 patches+ | V1Job (forall wR wU . Repository (Patch Prim) wR wU wR -> IO a)+ -- |A job that only works on darcs 2 patches+ | V2Job (forall wR wU . Repository (RealPatch Prim) wR wU wR -> IO a)+ -- |A job that works on any repository where the patch type @p@ has 'PrimOf' @p@ = 'Prim'.+ --+ -- This was added to support darcsden, which inspects the internals of V1 prim patches.+ --+ -- In future this should be replaced with a more abstract inspection API as part of 'PrimPatch'.+ | PrimV1Job (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim)+ => Repository p wR wU wR -> IO a)+ -- A job that works on normal darcs repositories, but will want access to the rebase patch if it exists.+ | RebaseAwareJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository p wR wU wR -> IO a)+ | RebaseJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a)+ | StartRebaseJob Compression Verbosity UpdateWorking (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, PrimOf (Named p) ~ PrimOf p) => Repository (Rebasing p) wR wU wR -> IO a)++onRepoJob :: RepoJob a+ -> (forall p wR wU . (RepoPatch p, ApplyState p ~ Tree) => (Repository p wR wU wR -> IO a) -> Repository p wR wU wR -> IO a)+ -> RepoJob a+onRepoJob (RepoJob job) f = RepoJob (f job)+-- onRepoJob (TreeJob job) f = TreeJob (f job)+onRepoJob (V1Job job) f = V1Job (f job)+onRepoJob (V2Job job) f = V2Job (f job)+onRepoJob (PrimV1Job job) f = PrimV1Job (f job)+onRepoJob (RebaseAwareJob compr verb uw job) f = RebaseAwareJob compr verb uw (f job)+onRepoJob (RebaseJob compr verb uw job) f = RebaseJob compr verb uw (f job)+onRepoJob (StartRebaseJob compr verb uw job) f = StartRebaseJob compr verb uw (f job)++-- | apply a given RepoJob to a repository in the current working directory+withRepository :: UseCache -> RepoJob a -> IO a+withRepository useCache = withRepositoryDirectory useCache "."++-- | apply a given RepoJob to a repository in a given url+withRepositoryDirectory :: UseCache -> String -> RepoJob a -> IO a+withRepositoryDirectory useCache url repojob = do+ Repo dir rf t c <- identifyRepository useCache url++ let+ startRebase =+ case repojob of+ StartRebaseJob {} -> True+ _ -> False++ case (formatHas Darcs2 rf, startRebase || formatHas RebaseInProgress rf) of++ (True, False) -> do+ debugMessage $ "Identified darcs-2 repo: " ++ dir+ let therepo = Repo dir rf t c :: Repository (RealPatch Prim) wR wU wR+ case repojob of+ RepoJob job -> job therepo+ PrimV1Job job -> job therepo+ -- TreeJob job -> job therepo+ V2Job job -> job therepo+ V1Job _ -> fail $ "This repository contains darcs v1 patches,"+ ++ " but the command requires darcs v2 patches."+ RebaseAwareJob _compr _verb _uw job -> job therepo+ RebaseJob {} -> fail "No rebase in progress. Try 'darcs rebase suspend' first."+ StartRebaseJob {} -> impossible++ (False, False) -> do+ debugMessage $ "Identified darcs-1 repo: " ++ dir+ let therepo = Repo dir rf t c :: Repository (Patch Prim) wR wU wR+ case repojob of+ RepoJob job -> job therepo+ PrimV1Job job -> job therepo+ V1Job job -> job therepo+ V2Job _ -> fail $ "This repository contains darcs v2 patches,"+ ++ " but the command requires darcs v1 patches."+ RebaseAwareJob _compr _verb _uw job -> job therepo+ RebaseJob {} -> fail "No rebase in progress. Try 'darcs rebase suspend' first."+ StartRebaseJob {} -> impossible++ (True, True ) -> do+ debugMessage $ "Identified darcs-2 rebase repo: " ++ dir+ let therepo = Repo dir rf t c :: Repository (Rebasing (RealPatch Prim)) wR wU wR+ case repojob of+ RepoJob job -> repoJobOnRebaseRepo job therepo+ PrimV1Job job -> repoJobOnRebaseRepo job therepo+ -- TreeJob job -> job therepo+ V2Job _ -> fail "This command is not supported while a rebase is in progress."+ V1Job _ -> fail $ "This repository contains darcs v1 patches,"+ ++ " but the command requires darcs v2 patches."+ RebaseAwareJob compr verb uw job -> rebaseJob job therepo compr verb uw+ RebaseJob compr verb uw job -> rebaseJob job therepo compr verb uw+ StartRebaseJob compr verb uw job -> startRebaseJob job therepo compr verb uw++ (False, True ) -> do+ debugMessage $ "Identified darcs-1 rebase repo: " ++ dir+ let therepo = Repo dir rf t c :: Repository (Rebasing (Patch Prim)) wR wU wR+ case repojob of+ RepoJob job -> repoJobOnRebaseRepo job therepo+ PrimV1Job job -> repoJobOnRebaseRepo job therepo+ V1Job _ -> fail "This command is not supported while a rebase is in progress."+ V2Job _ -> fail $ "This repository contains darcs v2 patches,"+ ++ " but the command requires darcs v1 patches."+ RebaseAwareJob compr verb uw job -> rebaseJob job therepo compr verb uw+ RebaseJob compr verb uw job -> rebaseJob job therepo compr verb uw+ StartRebaseJob compr verb uw job -> startRebaseJob job therepo compr verb uw++-- | apply a given RepoJob to a repository in the current working directory,+-- taking a lock+withRepoLock :: DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a+withRepoLock dry useCache uw um repojob =+ withRepository useCache $ onRepoJob repojob $ \job repository@(Repo _ rf _ _) ->+ do maybe (return ()) fail $ writeProblem rf+ let name = "./"++darcsdir++"/lock"+ withUMaskFlag um $+ if dry == YesDryRun+ then job repository+ else withLock name (revertRepositoryChanges repository uw >> job repository)++-- | apply a given RepoJob to a repository in the current working directory,+-- taking a lock. If lock not takeable, do nothing.+withRepoLockCanFail :: UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()+withRepoLockCanFail useCache uw um repojob =+ withRepository useCache $ onRepoJob repojob $ \job repository@(Repo _ rf _ _) ->+ do maybe (return ()) fail $ writeProblem rf+ let name = "./"++darcsdir++"/lock"+ withUMaskFlag um $ do+ eitherDone <- withLockCanFail name (revertRepositoryChanges repository uw >> job repository)+ case eitherDone of+ Left _ -> debugMessage "Lock could not be obtained, not doing the job."+ Right _ -> return ()+
+ src/Darcs/Repository/Lock.hs view
@@ -0,0 +1,382 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.Repository.Lock+ ( withLock+ , withLockCanFail+ , environmentHelpLocks+ , withTemp+ , withOpenTemp+ , withStdoutTemp+ , withTempDir+ , withPermDir+ , withDelayedDir+ , withNamedTemp+ , writeToFile+ , appendToFile+ , writeBinFile+ , writeLocaleFile+ , writeDocBinFile+ , appendBinFile+ , appendDocBinFile+ , readBinFile+ , readLocaleFile+ , readDocBinFile+ , writeAtomicFilePS+ , gzWriteAtomicFilePS+ , gzWriteAtomicFilePSs+ , gzWriteDocFile+ , rmRecursive+ , removeFileMayNotExist+ , canonFilename+ , maybeRelink+ , worldReadableTemp+ , tempdirLoc+ , environmentHelpTmpdir+ , environmentHelpKeepTmpdir+ , addToErrorLoc+ ) where++import Prelude hiding ( catch )+import Data.List ( inits )+import Data.Maybe ( isJust, listToMaybe )+import System.Exit ( exitWith, ExitCode(..) )+import System.IO ( withBinaryFile, openBinaryTempFile,+ hClose, hPutStr, Handle,+ IOMode(WriteMode, AppendMode), hFlush, stdout )+import System.IO.Error+ ( isAlreadyExistsError+ , annotateIOError+ )+import Control.Exception+ ( IOException+ , bracket+ , throwIO+ , catch+ , try+ , SomeException+ )+import System.Directory ( removeFile, removeDirectory,+ doesFileExist, doesDirectoryExist,+ getDirectoryContents, createDirectory,+ getTemporaryDirectory,+ )+import System.FilePath.Posix ( splitDirectories )+import Control.Concurrent ( threadDelay )+import Control.Monad ( unless, when, liftM )++import Darcs.Util.URL ( isRelative )+import Darcs.Util.Environment ( maybeGetEnv )+import Darcs.Util.Exception+ ( firstJustIO+ , catchall+ )+import Darcs.Util.File ( withCurrentDirectory+ , doesDirectoryReallyExist, removeFileMayNotExist )+import Darcs.Util.Path ( AbsolutePath, FilePathLike, toFilePath,+ getCurrentDirectory, setCurrentDirectory )++import Darcs.Util.ByteString ( gzWriteFilePSs, decodeLocale, encodeLocale )+import qualified Data.ByteString as B (null, readFile, hPut, ByteString)+import qualified Data.ByteString.Char8 as BC (unpack)++import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Util.Printer ( Doc, hPutDoc, packedString, empty, renderPSs, RenderMode(..) )+import Darcs.Util.AtExit ( atexit )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Workaround ( renameFile )+import Darcs.Repository.Compat+ ( mkStdoutTemp+ , canonFilename+ , maybeRelink+ , atomicCreate+ , sloppyAtomicCreate+ )+import System.Posix.Files ( fileMode, getFileStatus, setFileMode )+#include "impossible.h"++withLock :: String -> IO a -> IO a+withLock s job = bracket (getlock s 30) releaseLock (\_ -> job)++releaseLock :: String -> IO ()+releaseLock = removeFileMayNotExist++-- | Tries to perform some task if it can obtain the lock,+-- Otherwise, just gives up without doing the task+withLockCanFail :: String -> IO a -> IO (Either () a)+withLockCanFail s job =+ bracket (takeLock s)+ (\l -> when l $ releaseLock s)+ (\l -> if l then liftM Right job+ else return $ Left ())++getlock :: String -> Int -> IO String+getlock l 0 = do putStrLn $ "Couldn't get lock "++l+ exitWith $ ExitFailure 1+getlock lbad tl = do l <- canonFilename lbad+ gotit <- takeLock l+ if gotit then return l+ else do putStrLn $ "Waiting for lock "++l+ hFlush stdout -- for Windows+ threadDelay 2000000+ getlock l (tl - 1)+++takeLock :: FilePathLike p => p -> IO Bool+takeLock fp =+ do atomicCreate $ toFilePath fp+ return True+ `catch` \e -> if isAlreadyExistsError e+ then return False+ else do pwd <- getCurrentDirectory+ throwIO $ addToErrorLoc e+ ("takeLock "++toFilePath fp++" in "++toFilePath pwd)++takeFile :: FilePath -> IO Bool+takeFile fp =+ do sloppyAtomicCreate fp+ return True+ `catch` \e -> if isAlreadyExistsError e+ then return False+ else do pwd <- getCurrentDirectory+ throwIO $ addToErrorLoc e+ ("takeFile "++fp++" in "++toFilePath pwd)++environmentHelpLocks :: ([String],[String])+environmentHelpLocks = (["DARCS_SLOPPY_LOCKS"],[+ "If on some filesystems you get an error of the kind:",+ "",+ " darcs: takeLock [...]: atomic_create [...]: unsupported operation",+ "",+ "you may want to try to export DARCS_SLOPPY_LOCKS=True."])++-- |'withTemp' safely creates an empty file (not open for writing) and+-- returns its name.+--+-- The temp file operations are rather similar to the locking operations, in+-- that they both should always try to clean up, so exitWith causes trouble.+withTemp :: (String -> IO a) -> IO a+withTemp = bracket get_empty_file removeFileMayNotExist+ where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs"+ hClose h+ return f++-- |'withOpenTemp' creates a temporary file, and opens it.+-- Both of them run their argument and then delete the file. Also,+-- both of them (to my knowledge) are not susceptible to race conditions on+-- the temporary file (as long as you never delete the temporary file; that+-- would reintroduce a race condition).+withOpenTemp :: ((Handle, String) -> IO a) -> IO a+withOpenTemp = bracket get_empty_file cleanup+ where cleanup (h,f) = do _ <- try (hClose h) :: IO (Either SomeException ())+ removeFileMayNotExist f+ get_empty_file = invert `fmap` openBinaryTempFile "." "darcs"+ invert (a,b) = (b,a)++withStdoutTemp :: (String -> IO a) -> IO a+withStdoutTemp = bracket (mkStdoutTemp "stdout_") removeFileMayNotExist++tempdirLoc :: IO FilePath+tempdirLoc = liftM fromJust $+ firstJustIO [ liftM (Just . head . words) (readBinFile (darcsdir++"/prefs/tmpdir")) >>= chkdir,+ maybeGetEnv "DARCS_TMPDIR" >>= chkdir,+ getTemporaryDirectory >>= chkdir . Just,+ getCurrentDirectorySansDarcs,+ return $ Just "." -- always returns a Just+ ]+ where chkdir Nothing = return Nothing+ chkdir (Just d) = liftM (\e -> if e then Just (d++"/") else Nothing) $ doesDirectoryExist d++environmentHelpTmpdir :: ([String], [String])+environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [+ "Darcs often creates temporary directories. For example, the `darcs",+ "diff` command creates two for the working trees to be diffed. By",+ "default temporary directories are created in /tmp, or if that doesn't",+ "exist, in _darcs (within the current repo). This can be overridden by",+ "specifying some other directory in the file _darcs/prefs/tmpdir or the",+ "environment variable $DARCS_TMPDIR or $TMPDIR."])++getCurrentDirectorySansDarcs :: IO (Maybe FilePath)+getCurrentDirectorySansDarcs = do+ c <- getCurrentDirectory+ return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits $ toFilePath c+ where no_darcs x = darcsdir `notElem` splitDirectories x++data WithDirKind = Perm | Temp | Delayed++-- | Creates a directory based on the path parameter;+-- if a relative path is given the dir is created in the darcs temp dir.+-- If an absolute path is given this dir will be created if it doesn't exist.+-- If it is specified as a temporary dir, it is deleted after finishing the job.+withDir :: WithDirKind -- specifies if and when directory will be deleted+ -> String -- path parameter+ -> (AbsolutePath -> IO a) -> IO a+withDir _ "" _ = bug "withDir called with empty directory name"+withDir kind absoluteOrRelativeName job = do+ absoluteName <- if isRelative absoluteOrRelativeName+ then fmap (++ absoluteOrRelativeName) tempdirLoc+ else return absoluteOrRelativeName+ formerdir <- getCurrentDirectory+ bracket (createDir absoluteName 0)+ (\dir -> do setCurrentDirectory formerdir+ k <- keepTempDir+ unless k $ case kind of+ Perm -> return ()+ Temp -> rmRecursive (toFilePath dir)+ Delayed -> atexit $ rmRecursive (toFilePath dir))+ job+ where newname name 0 = name+ newname name n = name ++ "-" ++ show n+ createDir :: FilePath -> Int -> IO AbsolutePath+ createDir name n+ = do createDirectory $ newname name n+ setCurrentDirectory $ newname name n+ getCurrentDirectory+ `catch` (\e -> if isAlreadyExistsError e+ then createDir name (n+1)+ else throwIO e)+ keepTempDir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR"++environmentHelpKeepTmpdir :: ([String], [String])+environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[+ "If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will",+ "not remove the temporary directories it creates. This is intended",+ "primarily for debugging Darcs itself, but it can also be useful, for",+ "example, to determine why your test preference (see `darcs setpref`)",+ "is failing when you run `darcs record`, but working when run manually."])++-- |'withPermDir' is like 'withTempDir', except that it doesn't+-- delete the directory afterwards.+withPermDir :: String -> (AbsolutePath -> IO a) -> IO a+withPermDir = withDir Perm++-- |'withTempDir' creates an empty directory and then removes it when it+-- is no longer needed. withTempDir creates a temporary directory. The+-- location of that directory is determined by the contents of+-- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if+-- that doesn't exist then whatever your operating system considers to be a+-- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under+-- Windows).+--+-- If none of those exist it creates the temporary directory+-- in the current directory, unless the current directory is under a _darcs+-- directory, in which case the temporary directory in the parent of the highest+-- _darcs directory to avoid accidentally corrupting darcs's internals.+-- This should not fail, but if it does indeed fail, we go ahead and use the+-- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set+-- temporary directory is not removed, this can be useful for debugging.+withTempDir :: String -> (AbsolutePath -> IO a) -> IO a+withTempDir = withDir Temp++withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a+withDelayedDir = withDir Delayed++rmRecursive :: FilePath -> IO ()+rmRecursive d =+ do isd <- doesDirectoryReallyExist d+ if not isd+ then removeFile d+ else do conts <- actual_dir_contents+ withCurrentDirectory d $+ mapM_ rmRecursive conts+ removeDirectory d+ where actual_dir_contents = -- doesn't include . or ..+ do c <- getDirectoryContents d+ return $ filter (/=".") $ filter (/="..") c++worldReadableTemp :: String -> IO String+worldReadableTemp f = wrt 0+ where wrt :: Int -> IO String+ wrt 100 = fail $ "Failure creating temp named "++f+ wrt n = let f_new = f++"-"++show n+ in do ok <- takeFile f_new+ if ok then return f_new+ else wrt (n+1)++withNamedTemp :: String -> (String -> IO a) -> IO a+withNamedTemp n = bracket get_empty_file removeFileMayNotExist+ where get_empty_file = worldReadableTemp n++readBinFile :: FilePathLike p => p -> IO String+readBinFile = fmap BC.unpack . B.readFile . toFilePath++-- | Reads a file. Differs from readBinFile in that it interprets the file in+-- the current locale instead of as ISO-8859-1.+readLocaleFile :: FilePathLike p => p -> IO String+readLocaleFile f = decodeLocale `fmap` B.readFile (toFilePath f)++readDocBinFile :: FilePathLike p => p -> IO Doc+readDocBinFile fp = do ps <- B.readFile $ toFilePath fp+ return $ if B.null ps then empty else packedString ps++appendBinFile :: FilePathLike p => p -> String -> IO ()+appendBinFile f s = appendToFile f $ \h -> hPutStr h s++appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()+appendDocBinFile f d = appendToFile f $ \h -> hPutDoc Standard h d++writeBinFile :: FilePathLike p => p -> String -> IO ()+writeBinFile f s = writeToFile f $ \h -> hPutStr h s++-- | Writes a file. Differs from writeBinFile in that it writes the string+-- encoded with the current locale instead of what GHC thinks is right.+writeLocaleFile :: FilePathLike p => p -> String -> IO ()+writeLocaleFile f s = writeToFile f $ \h -> B.hPut h (encodeLocale s)++writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()+writeDocBinFile f d = writeToFile f $ \h -> hPutDoc Standard h d++writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()+writeAtomicFilePS f ps = writeToFile f $ \h -> B.hPut h ps++gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()+gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps]++gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO ()+gzWriteAtomicFilePSs f pss =+ withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do+ gzWriteFilePSs newf pss+ already_exists <- doesFileExist $ toFilePath f+ when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)+ setFileMode newf mode+ `catchall` return ()+ renameFile newf (toFilePath f)++gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()+gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs Standard d++writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()+writeToFile f job =+ withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do+ withBinaryFile newf WriteMode job+ already_exists <- doesFileExist (toFilePath f)+ when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)+ setFileMode newf mode+ `catchall` return ()+ renameFile newf (toFilePath f)++appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()+appendToFile f job = withSignalsBlocked $+ withBinaryFile (toFilePath f) AppendMode job+++addToErrorLoc :: IOException+ -> String+ -> IOException+addToErrorLoc ioe s = annotateIOError ioe s Nothing Nothing
src/Darcs/Repository/LowLevel.hs view
@@ -18,90 +18,109 @@ {-# LANGUAGE CPP #-} -#include "gadts.h"- module Darcs.Repository.LowLevel- ( readPending, readTentativePending+ ( readPending+ , readTentativePending , writeTentativePending -- deprecated interface:- , readNewPending, writeNewPending- , pendingName )- where+ , readNewPending+ , writeNewPending+ , pendingName+ ) where -import Darcs.Repository.InternalTypes ( RepoType(..), Repository(..) )-import Darcs.Patch ( readPatch, writePatch, RepoPatch, PrimOf )+import Control.Applicative+import qualified Data.ByteString as BS ( empty )++import Darcs.Util.Global ( darcsdir )+import Darcs.Repository.Lock ( writeDocBinFile )+import Darcs.Repository.InternalTypes ( Repository(..) )+import Darcs.Patch ( readPatch, RepoPatch, PrimOf ) import Darcs.Patch.Read ( ReadPatch(..), bracketedFL ) import Darcs.Patch.ReadMonads ( ParserM ) import Darcs.Patch.Show ( ShowPatchBasic(..) )-import Darcs.Global ( darcsdir )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), mapSeal )-import Darcs.Witnesses.Ordered ( FL(..), mapFL )-import Darcs.Utils ( catchall )-import ByteStringUtils ( gzReadFilePS )-import Printer ( Doc, ($$), text, vcat )+import Darcs.Util.Exception ( catchall )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), mapSeal )+import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL ) -import Control.Applicative-import qualified Data.ByteString as BS ( ByteString, empty )+import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Printer ( Doc, ($$), (<>), text, vcat ) -pendingName :: RepoType p -> String-pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending"+pendingName :: String+pendingName = darcsdir ++ "/patches/pending" --- | Read the contents of pending. CWD should be the repository directory.+newSuffix, tentativeSuffix :: String+newSuffix = ".new"+tentativeSuffix = ".tentative"++-- | Read the contents of pending. -- The return type is currently incorrect as it refers to the tentative -- state rather than the recorded state.-readPending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL (PrimOf p) C(t)))-readPending (Repo _ _ _ tp) =- readPendingFile (pendingName tp)+readPending :: RepoPatch p => Repository p wR wU wT+ -> IO (Sealed (FL (PrimOf p) wT))+readPending = readPendingFile "" --- |Read the contents of tentative pending. CWD should be the repository directory.-readTentativePending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL (PrimOf p) C(t)))-readTentativePending (Repo _ _ _ tp) =- readPendingFile (pendingName tp ++ ".tentative")+-- |Read the contents of tentative pending.+readTentativePending :: RepoPatch p => Repository p wR wU wT+ -> IO (Sealed (FL (PrimOf p) wT))+readTentativePending = readPendingFile tentativeSuffix --- |Read the contents of tentative pending. CWD should be the repository directory.-readNewPending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL (PrimOf p) C(t)))-readNewPending (Repo _ _ _ tp) =- readPendingFile (pendingName tp ++ ".new")+-- |Read the contents of tentative pending.+readNewPending :: RepoPatch p => Repository p wR wU wT+ -> IO (Sealed (FL (PrimOf p) wT))+readNewPending = readPendingFile newSuffix -readPendingFile :: ReadPatch prim => String -> IO (Sealed (FL prim C(x)))-readPendingFile name = do- pend <- gzReadFilePS name `catchall` return BS.empty- return $ readPendingContents pend+-- |Read the pending file with the given suffix. CWD should be the repository+-- directory.+readPendingFile :: ReadPatch prim => String -> Repository p wR wU wT+ -> IO (Sealed (FL prim wX))+readPendingFile suffix _ = do+ pend <- gzReadFilePS (pendingName ++ suffix) `catchall` return BS.empty+ return . maybe (Sealed NilFL) (mapSeal unFLM) . readPatch $ pend --- Wrapper around FL where printed format uses { } except around singletons--- Now that the Show behaviour of FL p can be customised (using showFLBehavior),--- we could instead change the general behaviour of FL Prim; but since the pending--- code can be kept nicely compartmentalised, it's nicer to do it this way.-newtype FLM p C(x y) = FLM { unFLM :: FL p C(x y) }+-- Wrapper around FL where printed format uses { } except around singletons.+-- Now that the Show behaviour of FL p can be customised (using+-- showFLBehavior), we could instead change the general behaviour of FL Prim;+-- but since the pending code can be kept nicely compartmentalised, it's nicer+-- to do it this way.+newtype FLM p wX wY = FLM { unFLM :: FL p wX wY } instance ReadPatch p => ReadPatch (FLM p) where- readPatch' = mapSeal FLM <$> readMaybeBracketedFL readPatch' '{' '}'+ readPatch' = mapSeal FLM <$> readMaybeBracketedFL readPatch' '{' '}' instance ShowPatchBasic p => ShowPatchBasic (FLM p) where- showPatch = showMaybeBracketedFL showPatch '{' '}' . unFLM+ showPatch = showMaybeBracketedFL showPatch '{' '}' . unFLM -readPendingContents :: ReadPatch prim => BS.ByteString -> Sealed (FL prim C(x))-readPendingContents = maybe (Sealed NilFL) (mapSeal unFLM) . readPatch+readMaybeBracketedFL :: forall m p wX . ParserM m+ => (forall wY . m (Sealed (p wY))) -> Char -> Char+ -> m (Sealed (FL p wX))+readMaybeBracketedFL parser pre post =+ bracketedFL parser pre post <|> (mapSeal (:>:NilFL) <$> parser) -writePendingFile :: ShowPatchBasic prim => String -> FL prim C(x y) -> IO ()-writePendingFile name = writePatch name . FLM+showMaybeBracketedFL :: (forall wX wY . p wX wY -> Doc) -> Char -> Char+ -> FL p wA wB -> Doc+showMaybeBracketedFL _ pre post NilFL = text [pre] $$ text [post]+showMaybeBracketedFL printer _ _ (p :>: NilFL) = printer p+showMaybeBracketedFL printer pre post ps = text [pre] $$+ vcat (mapFL printer ps) $$+ text [post] -readMaybeBracketedFL :: forall m p C(x) . ParserM m =>- (FORALL(y) m (Sealed (p C(y)))) -> Char -> Char -> m (Sealed (FL p C(x)))-readMaybeBracketedFL parser pre post =- bracketedFL parser pre post <|> (mapSeal (:>:NilFL) <$> parser)+-- |Write the contents of tentative pending.+writeTentativePending :: RepoPatch p => Repository p wR wU wT+ -> FL (PrimOf p) wT wY -> IO ()+writeTentativePending = writePendingFile tentativeSuffix -showMaybeBracketedFL :: (FORALL(x y) p C(x y) -> Doc) -> Char -> Char -> FL p C(a b) -> Doc-showMaybeBracketedFL _ pre post NilFL = text [pre] $$ text [post]-showMaybeBracketedFL printer _ _ (p :>: NilFL) = printer p-showMaybeBracketedFL printer pre post ps = text [pre] $$ vcat (mapFL printer ps) $$ text [post]+-- |Write the contents of new pending. CWD should be the repository directory.+writeNewPending :: RepoPatch p => Repository p wR wU wT+ -> FL (PrimOf p) wT wY -> IO ()+writeNewPending = writePendingFile newSuffix --- |Read the contents of tentative pending. CWD should be the repository directory.-writeTentativePending :: RepoPatch p => Repository p C(r u t) -> FL (PrimOf p) C(t y) -> IO ()-writeTentativePending (Repo _ _ _ tp) pend =- writePendingFile (pendingName tp ++ ".tentative") pend+-- Write a pending file, with the given suffix. CWD should be the repository+-- directory.+writePendingFile :: ShowPatchBasic prim => String -> Repository p wR wU wT+ -> FL prim wX wY -> IO ()+writePendingFile suffix _ = writePatch name . FLM+ where+ name = pendingName ++ suffix --- |Read the contents of new pending. CWD should be the repository directory.-writeNewPending :: RepoPatch p => Repository p C(r u t) -> FL (PrimOf p) C(t y) -> IO ()-writeNewPending (Repo _ _ _ tp) pend =- writePendingFile (pendingName tp ++ ".new") pend+writePatch :: ShowPatchBasic p => FilePath -> p wX wY -> IO ()+writePatch f p = writeDocBinFile f $ showPatch p <> text "\n"
+ src/Darcs/Repository/Match.hs view
@@ -0,0 +1,98 @@+-- Copyright (C) 2004-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, Rank2Types #-}++module Darcs.Repository.Match+ (+ getNonrangeMatch+ , getPartialNonrangeMatch+ , getFirstMatch+ , getOnePatchset+ ) where++import Darcs.Patch.Match+ ( getNonrangeMatchS+ , getFirstMatchS+ , nonrangeMatcherIsTag+ , getMatchingTag+ , matchAPatchset+ , nonrangeMatcher+ , MatchFlag(..)+ )++import Darcs.Patch.Bundle ( scanContextFile )+import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, Origin )+import Darcs.Patch.Witnesses.Sealed ( seal )++import Darcs.Repository.Flags+ ( WithWorkingDir (WithWorkingDir) )+import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault )+import Darcs.Repository.Internal+ ( Repository, readRepo, createPristineDirectoryTree )++import Storage.Hashed.Tree ( Tree )++import Darcs.Util.Path ( FileName, toFilePath )++#include "impossible.h"++getNonrangeMatch :: (ApplyMonad DefaultIO (ApplyState p), RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> [MatchFlag]+ -> IO ()+getNonrangeMatch r fs = withRecordedMatch r (getNonrangeMatchS fs)++getPartialNonrangeMatch :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> [MatchFlag]+ -> [FileName]+ -> IO ()+getPartialNonrangeMatch r fs _ =+ withRecordedMatch r (getNonrangeMatchS fs)++getFirstMatch :: (ApplyMonad DefaultIO (ApplyState p), RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> [MatchFlag]+ -> IO ()+getFirstMatch r fs = withRecordedMatch r (getFirstMatchS fs)++getOnePatchset :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> [MatchFlag]+ -> IO (SealedPatchSet p Origin)+getOnePatchset repository fs =+ case nonrangeMatcher fs of+ Just m -> do ps <- readRepo repository+ if nonrangeMatcherIsTag fs+ then return $ getMatchingTag m ps+ else return $ matchAPatchset m ps+ Nothing -> seal `fmap` (scanContextFile . toFilePath . context_f $ fs)+ where context_f [] = bug "Couldn't match_nonrange_patchset"+ context_f (Context f:_) = f+ context_f (_:xs) = context_f xs++withRecordedMatch :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> (PatchSet p Origin wR -> DefaultIO ())+ -> IO ()+withRecordedMatch r job+ = do createPristineDirectoryTree r "." WithWorkingDir+ readRepo r >>= runDefault . job
src/Darcs/Repository/Merge.hs view
@@ -17,102 +17,153 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -#include "gadts.h" -module Darcs.Repository.Merge ( tentativelyMergePatches, considerMergeToWorking ) where+module Darcs.Repository.Merge+ ( tentativelyMergePatches+ , considerMergeToWorking+ ) where -import Darcs.Resolution ( standardResolution, externalResolution )-import Darcs.External ( backupByCopying )-import Control.Monad ( when, unless )+import Control.Monad ( when )+import Storage.Hashed.Tree( Tree ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )-import Darcs.Flags- ( DarcsFlag( AllowConflicts, NoAllowConflicts ), wantExternalMerge, diffingOpts, compression )-import Darcs.Witnesses.Ordered- ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), mapFL_FL )-import Darcs.Patch- ( RepoPatch, PrimOf, merge, joinPatches, listTouchedFiles- , patchcontents, anonymous, fromPrims, effect )+import Darcs.Repository.External ( backupByCopying )+import Darcs.Repository.Flags+ ( UseIndex+ , ScanKnown+ , AllowConflicts (..)+ , Reorder (..)+ , UpdateWorking (..)+ , ExternalMerge (..)+ , Verbosity (..)+ , Compression (..)+ , WantGuiPause (..)+ , DiffAlgorithm (..)+ )+import Darcs.Patch ( RepoPatch, PrimOf, merge, listTouchedFiles, patchcontents,+ anonymous, fromPrims, effect ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Depends( merge2FL )-import Progress( debugMessage )-import Darcs.ProgressPatches( progressFL )-import Darcs.Witnesses.Sealed( Sealed(Sealed), seal )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )+import Darcs.Patch.Progress( progressFL )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), (:\/:)(..), (:/\:)(..), (+>+),+ mapFL_FL, concatFL )+import Darcs.Patch.Witnesses.Sealed( Sealed(Sealed), seal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd ) import Darcs.Repository.InternalTypes( Repository(..) )- import Darcs.Repository.State( unrecordedChanges, readUnrecorded )--import Darcs.Repository.Internal- ( announceMergeConflicts, checkUnrecordedConflicts- , MakeChanges(..), setTentativePending- , tentativelyAddPatch_, applyToTentativePristine, UpdatePristine(..) )--import Storage.Hashed.Tree( Tree )+import Darcs.Repository.Resolution ( standardResolution, externalResolution )+import Darcs.Repository.Internal ( announceMergeConflicts,+ checkUnrecordedConflicts, MakeChanges(..),+ setTentativePending, tentativelyAddPatch_,+ applyToTentativePristine,+ tentativelyReplacePatches,+ UpdatePristine(..) )+import Darcs.Util.Progress( debugMessage ) -tentativelyMergePatches_ :: forall p C(r u t y x). (RepoPatch p, ApplyState p ~ Tree)- => MakeChanges- -> Repository p C(r u t) -> String -> [DarcsFlag]- -> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y)- -> IO (Sealed (FL (PrimOf p) C(u)))-tentativelyMergePatches_ mc r cmd opts usi themi =- do let us = mapFL_FL hopefully usi- them = mapFL_FL hopefully themi- Sealed pc <- return $ merge2FL (progressFL "Merging us" usi) (progressFL "Merging them" themi)- pend <- unrecordedChanges (diffingOpts opts) r Nothing- anonpend <- n2pia `fmap` anonymous (fromPrims pend)- pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL)- let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $+tentativelyMergePatches_ :: forall p wR wU wT wY wX. (RepoPatch p,+ ApplyState p ~ Tree) => MakeChanges+ -> Repository p wR wU wT -> String+ -> AllowConflicts -> UpdateWorking+ -> ExternalMerge -> WantGuiPause+ -> Compression -> Verbosity -> Reorder+ -> ( UseIndex, ScanKnown, DiffAlgorithm )+ -> FL (PatchInfoAnd p) wX wT+ -> FL (PatchInfoAnd p) wX wY+ -> IO (Sealed (FL (PrimOf p) wU))+tentativelyMergePatches_ mc r cmd allowConflicts updateWorking externalMerge wantGuiPause compression verbosity reorder diffingOpts@(_, _, dflag) usi themi = do+ let us = mapFL_FL hopefully usi+ them = mapFL_FL hopefully themi+ ((pc :: FL (PatchInfoAnd p) wT wMerged) :/\: us_merged)+ <- return $ merge2FL (progressFL "Merging us" usi)+ (progressFL "Merging them" themi)+ pend <- unrecordedChanges diffingOpts r Nothing+ anonpend <- n2pia `fmap` anonymous (fromPrims pend)+ pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL)+ let pwprim = concatFL $ progressFL "Examining patches for conflicts" $ mapFL_FL (patchcontents . hopefully) pw- Sealed standard_resolved_pw <- return $ standardResolution pwprim- debugMessage "Checking for conflicts..."- unless (AllowConflicts `elem` opts || NoAllowConflicts `elem` opts) $- mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw- debugMessage "Announcing conflicts..."- have_conflicts <- announceMergeConflicts cmd opts standard_resolved_pw- debugMessage "Checking for unrecorded conflicts..."- have_unrecorded_conflicts <- checkUnrecordedConflicts opts $ mapFL_FL hopefully pc- debugMessage "Reading working directory..."- working <- readUnrecorded r Nothing- debugMessage "Working out conflicts in actual working directory..."- Sealed pw_resolution <-- case (wantExternalMerge opts, have_conflicts || have_unrecorded_conflicts) of- (Nothing,_) -> return $ if AllowConflicts `elem` opts- then seal NilFL- else seal standard_resolved_pw- (_,False) -> return $ seal standard_resolved_pw- (Just c, True) -> externalResolution working c opts- (effect us +>+ pend)- (effect them) pwprim- debugMessage "Applying patches to the local directories..."- when (mc == MakeChanges) $- do let doChanges :: FL (PatchInfoAnd p) C(x t) -> IO ()- doChanges NilFL = applyps r themi- doChanges _ = applyps r pc- doChanges usi- setTentativePending r (effect pend' +>+ pw_resolution)- return $ seal (effect pwprim +>+ pw_resolution)- where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j))- mapAdd repo NilFL = return repo- mapAdd repo (a:>:as) =- do repo' <- tentativelyAddPatch_ DontUpdatePristine repo (compression opts) a- mapAdd repo' as- applyps :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO ()- applyps repo ps = do debugMessage "Adding patches to inventory..."--- Warning: A do-notation statement discarded a result of type Repository p m l j.- _ <- mapAdd repo ps- debugMessage "Applying patches to pristine..."- applyToTentativePristine repo ps+ Sealed standard_resolved_pw <- return $ standardResolution pwprim+ debugMessage "Checking for conflicts..."+ when (allowConflicts == YesAllowConflictsAndMark) $+ mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw+ debugMessage "Announcing conflicts..."+ have_conflicts <- announceMergeConflicts cmd allowConflicts externalMerge standard_resolved_pw+ debugMessage "Checking for unrecorded conflicts..."+ have_unrecorded_conflicts <- checkUnrecordedConflicts updateWorking $+ mapFL_FL hopefully pc+ debugMessage "Reading working directory..."+ working <- readUnrecorded r Nothing+ debugMessage "Working out conflicts in actual working directory..."+ let haveConflicts = have_conflicts || have_unrecorded_conflicts+ Sealed pw_resolution <-+ case (externalMerge , haveConflicts) of+ (NoExternalMerge, _) -> return $ if allowConflicts == YesAllowConflicts+ then seal NilFL+ else seal standard_resolved_pw+ (_, False) -> return $ seal standard_resolved_pw+ (YesExternalMerge c, True) -> externalResolution dflag working c wantGuiPause+ (effect us +>+ pend) (effect them) pwprim+ debugMessage "Applying patches to the local directories..."+ when (mc == MakeChanges) $ do+ let doChanges :: FL (PatchInfoAnd p) wX wT -> IO (Repository p wR wU wMerged)+ -- This first case is a possible optimisation: if 'usi' is empty, then+ -- the merge2FL call above will return pc = themi, but the wMerged+ -- witness is quantified in the :/\: constructor so we lose the+ -- information that wX=wT => wMerged=wY so we have to coerce.+ -- TODO: it's not really clear why if this is an optimisation in+ -- practice, as pc would be trivial to calculate in this case and+ -- there aren't any obvious memory benefits.+ doChanges NilFL = applyps r (unsafeCoercePEnd themi)+ doChanges _ = applyps r pc+ r' <- doChanges usi+ setTentativePending r' updateWorking (effect pend' +>+ pw_resolution)+ when (reorder == Reorder) $+ -- TODO: we end up applying the merged remote patches on top of the unmerged+ -- local patches, then commuting out the unmerged local patches and finally+ -- adding the merged local patches.+ -- It would better to just remove the unmerged local patche, then apply the+ -- unmerged remote patches and then the merged local patches.+ -- The handling of 'unrecorded' might complicate this slightly so this+ -- refactoring may be better deferred until we have reliable witness tracking+ -- for repositories.+ tentativelyReplacePatches r' compression YesUpdateWorking verbosity us_merged+ return $ seal (effect pwprim +>+ pw_resolution)+ where+ mapAdd :: Repository p wM wL wI -> FL (PatchInfoAnd p) wI wJ+ -> IO (Repository p wM wL wJ)+ mapAdd repo NilFL = return repo+ mapAdd repo (a:>:as) = do+ repo' <- tentativelyAddPatch_ DontUpdatePristine repo+ compression verbosity updateWorking a+ mapAdd repo' as+ applyps :: Repository p wM wL wI -> FL (PatchInfoAnd p) wI wJ -> IO (Repository p wM wL wJ)+ applyps repo ps = do+ debugMessage "Adding patches to inventory..."+ repo' <- mapAdd repo ps+ debugMessage "Applying patches to pristine..."+ applyToTentativePristine repo verbosity ps+ return repo' tentativelyMergePatches :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> String -> [DarcsFlag]- -> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y)- -> IO (Sealed (FL (PrimOf p) C(u)))+ => Repository p wR wU wT -> String+ -> AllowConflicts -> UpdateWorking+ -> ExternalMerge -> WantGuiPause+ -> Compression -> Verbosity -> Reorder+ -> ( UseIndex, ScanKnown, DiffAlgorithm )+ -> FL (PatchInfoAnd p) wX wT+ -> FL (PatchInfoAnd p) wX wY+ -> IO (Sealed (FL (PrimOf p) wU)) tentativelyMergePatches = tentativelyMergePatches_ MakeChanges considerMergeToWorking :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> String -> [DarcsFlag]- -> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y)- -> IO (Sealed (FL (PrimOf p) C(u)))+ => Repository p wR wU wT -> String+ -> AllowConflicts -> UpdateWorking+ -> ExternalMerge -> WantGuiPause+ -> Compression -> Verbosity -> Reorder+ -> ( UseIndex, ScanKnown, DiffAlgorithm )+ -> FL (PatchInfoAnd p) wX wT+ -> FL (PatchInfoAnd p) wX wY+ -> IO (Sealed (FL (PrimOf p) wU)) considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges
src/Darcs/Repository/Motd.hs view
@@ -15,26 +15,29 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.Repository.Motd (getMotd, showMotd) where+module Darcs.Repository.Motd+ ( getMotd+ , showMotd+ ) where import Control.Monad ( unless )-import Darcs.Flags ( DarcsFlag( Quiet, XMLOutput ) )-import Darcs.External ( fetchFilePS, Cachable(..) )-import Darcs.Global ( darcsdir ) import qualified Data.ByteString as B (null, hPut, empty, ByteString)-import Darcs.Utils ( catchall ) import System.IO ( stdout ) +import Darcs.Repository.External ( fetchFilePS, Cachable(..) )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Exception ( catchall )+ -- | Fetch and return the message of the day for a given repository. getMotd :: String -> IO B.ByteString-getMotd repo = fetchFilePS (repo++"/"++darcsdir++"/prefs/motd") (MaxAge 600)- `catchall` return B.empty+getMotd repo = fetchFilePS motdPath (MaxAge 600) `catchall` return B.empty+ where+ motdPath = repo ++ "/" ++ darcsdir ++ "/prefs/motd" -- | Display the message of the day for a given repository,--- unless either the 'XMLOutput' or the 'Quiet' flags are passed in-showMotd :: [DarcsFlag] -> String -> IO ()-showMotd opts repo = unless (Quiet `elem` opts || XMLOutput `elem` opts) $ do- motd <- getMotd repo- unless (B.null motd)- $ do B.hPut stdout motd- putStrLn "**********************"+showMotd :: String -> IO ()+showMotd repo = do+ motd <- getMotd repo+ unless (B.null motd) $ do+ B.hPut stdout motd+ putStrLn $ replicate 22 '*'
src/Darcs/Repository/Old.hs view
@@ -17,15 +17,14 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-} -#include "gadts.h" module Darcs.Repository.Old ( readOldRepo, revertTentativeChanges, oldRepoFailMsg ) where import Prelude hiding ( catch ) -import Progress ( debugMessage, beginTedious, endTedious, finishedOneIO )-import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )+import Darcs.Util.Progress ( debugMessage, beginTedious, endTedious, finishedOneIO )+import Darcs.Util.Path ( ioAbsoluteOrRemote, toPath ) import System.IO ( hPutStrLn, stderr ) import System.IO.Unsafe ( unsafeInterleaveIO ) import System.FilePath.Posix ( (</>) )@@ -38,23 +37,24 @@ import Darcs.Patch ( RepoPatch, Named, readPatch ) -import Darcs.Witnesses.Ordered ( RL(..) )-import Darcs.Patch.Info ( PatchInfo, makeFilename, readPatchInfos )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.External ( gzFetchFilePS, Cachable(..),- cloneFile )-import Darcs.Lock ( writeBinFile )-import Darcs.Global ( darcsdir )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal )+import Darcs.Patch.Witnesses.Ordered ( RL(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal )+import Darcs.Patch.Info ( PatchInfo, makeFilename, readPatchInfos, showPatchInfo )+import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin )+import Darcs.Repository.External+ ( gzFetchFilePS+ , Cachable(..)+ , cloneFile+ )+import Darcs.Repository.Lock ( writeBinFile )+import Darcs.Util.Printer ( renderString, RenderMode(..) )+import Darcs.Util.Global ( darcsdir ) import Control.Exception ( catch, IOException ) #include "impossible.h" -readOldRepo :: RepoPatch p => String -> IO (SealedPatchSet p C(Origin))+readOldRepo :: RepoPatch p => String -> IO (SealedPatchSet p Origin) readOldRepo d = do realdir <- toPath `fmap` ioAbsoluteOrRemote d let k = "Reading inventory of repository "++d@@ -63,12 +63,12 @@ (\e -> do hPutStrLn stderr ("Invalid repository: " ++ realdir) ioError e) -readRepoPrivate :: RepoPatch p => String -> FilePath -> FilePath -> IO (SealedPatchSet p C(Origin))+readRepoPrivate :: RepoPatch p => String -> FilePath -> FilePath -> IO (SealedPatchSet p Origin) readRepoPrivate k d iname = do- i <- gzFetchFilePS (d </> "_darcs" </> iname) Uncachable+ i <- gzFetchFilePS (d </> darcsdir </> iname) Uncachable finishedOneIO k iname- let parse inf = parse2 inf $ d </> "_darcs/patches" </> makeFilename inf- (mt, is) = case BC.break ((==) '\n') i of+ let parse inf = parse2 inf $ d </> darcsdir </> "patches" </> makeFilename inf+ (mt, is) = case BC.break ('\n' ==) i of (swt,pistr) | swt == BC.pack "Starting with tag:" -> case readPatchInfos pistr of (t:ids) -> (Just t,reverse ids)@@ -78,17 +78,17 @@ Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is) return $ seal (PatchSet ps ts) where read_ts :: RepoPatch p =>- (FORALL(b) PatchInfo -> IO (Sealed (PatchInfoAnd p C(b))))- -> Maybe PatchInfo -> IO (Sealed (RL (Tagged p) C(Origin)))+ (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd p wB)))+ -> Maybe PatchInfo -> IO (Sealed (RL (Tagged p) Origin)) read_ts _ Nothing = do endTedious k return $ seal NilRL read_ts parse (Just tag0) =- do debugMessage $ "Looking for inventory for:\n"++ show tag0+ do debugMessage $ "Looking for inventory for:\n"++ renderString Encode (showPatchInfo tag0) i <- unsafeInterleaveIO $- do x <- gzFetchFilePS (d</>"_darcs/inventories"</>makeFilename tag0) Uncachable- finishedOneIO k (show tag0)+ do x <- gzFetchFilePS (d </> darcsdir </> "inventories" </> makeFilename tag0) Uncachable+ finishedOneIO k (renderString Encode (showPatchInfo tag0)) return x- let (mt, is) = case BC.break ((==) '\n') i of+ let (mt, is) = case BC.break ('\n' ==) i of (swt,pistr) | swt == BC.pack "Starting with tag:" -> case readPatchInfos pistr of (t:ids) -> (Just t,reverse ids)@@ -102,25 +102,25 @@ patchInfoAndPatch tag0 $ unavailable $ show e return $ seal $ Tagged tag00 Nothing ps :<: ts parse2 :: RepoPatch p => PatchInfo -> FilePath- -> IO (Sealed (PatchInfoAnd p C(x)))+ -> IO (Sealed (PatchInfoAnd p wX)) parse2 i fn = do ps <- unsafeInterleaveIO $ gzFetchFilePS fn Cachable return $ patchInfoAndPatch i `mapSeal` hopefullyNoParseError (toPath fn) (readPatch ps)- hopefullyNoParseError :: String -> Maybe (Sealed (Named a1dr C(x)))- -> Sealed (Hopefully (Named a1dr) C(x))+ hopefullyNoParseError :: String -> Maybe (Sealed (Named a1dr wX))+ -> Sealed (Hopefully (Named a1dr) wX) hopefullyNoParseError _ (Just (Sealed x)) = seal $ actually x hopefullyNoParseError s Nothing = seal $ unavailable $ "Couldn't parse file "++s read_patches :: RepoPatch p =>- (FORALL(b) PatchInfo -> IO (Sealed (PatchInfoAnd p C(b))))- -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd p) C(x)))+ (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd p wB)))+ -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd p) wX)) read_patches _ [] = return $ seal NilRL read_patches parse (i:is) = lift2Sealed (:<:) (read_patches parse is) (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)+ lift2Sealed :: (forall wY wZ . q wY wZ -> pp wY -> r wZ)+ -> IO (Sealed pp) -> (forall wB . IO (Sealed (q wB))) -> IO (Sealed r) lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` unsafeInterleaveIO iox Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy return $ seal $ f y x
+ src/Darcs/Repository/PatchIndex.hs view
@@ -0,0 +1,770 @@+{-# LANGUAGE CPP, NamedFieldPuns #-}++-- Copyright (C) 2009-2010 Benedikt Schmidt+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Repository.PatchIndex (+ doesPatchIndexExist,+ isPatchIndexDisabled,+ isPatchIndexInSync,+ canUsePatchIndex,+ canCreatePI,+ createPIWithInterrupt,+ createOrUpdatePatchIndexDisk,+ deletePatchIndex,+ dumpPatchIndex,+ dumpPatchIndexFiles,+ filterPatches,+ PatchFilter,+ maybeFilterPatches,+ getRelevantSubsequence,+ piTest,+ attemptCreatePatchIndex+) where++import Prelude hiding ( catch, pi )+import Data.Binary ( encodeFile, decodeFile )+import Data.Word ( Word32 )+import Data.Int ( Int8 )+import Data.List ( group, mapAccumL, sort, isPrefixOf, nub, (\\) )+import Data.Maybe ( fromMaybe, isJust )+import Data.Set (Set)+import Data.Map (Map)+import qualified Data.Map as M+import qualified Data.Set as S+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(..) )+import Darcs.Repository.Read ( readRepo )+import Darcs.Patch.Witnesses.Ordered ( mapFL, RL(..), FL(..), reverseRL )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal, seal2, unsafeUnseal )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd(..), info )+import Darcs.Repository.Lock ( withPermDir, rmRecursive )+import Darcs.Patch ( RepoPatch, listTouchedFiles )+import Darcs.Util.Path ( FileName, fp2fn, fn2fp, toFilePath )+import Darcs.Patch.Apply ( applyToFileMods, ApplyState(..) )+import Darcs.Patch.Set ( newset2FL, Origin, newset2FL )+import Darcs.Patch.Patchy ( Commute )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Patch.Index.Types+import System.FilePath( (</>) )+import System.IO (openFile, IOMode(WriteMode), hClose)+import qualified Data.ByteString as B+import Darcs.Util.Crypt.SHA256 (sha256sum )+import Darcs.Util.Crypt.SHA1 ( SHA1(..), showAsHex )+import Storage.Hashed.Tree ( Tree(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Util.SignalHandler ( catchInterrupt )+#include "impossible.h"++{- -----------------------------------------------------------------------------+ The patch index stores additional information that is extracted from+ the PatchSet for the repository to speed up certain commands.++ createPatchIndexDisk:+ Create the on-disk patch-index index from scratch.+ updatePatchIndexDisk:+ Update the on-disk patch-index index.+ ----------------------------------------------------------------------------- -}++-- ---------------------------------------------------------------------+-- Data structures for the patch-index++data FileIdSpan = FidSpan+ !FileId -- the fileid has some fixed name in the+ !PatchId -- span starting here+ !(Maybe PatchId) -- and (maybe) ending here+ deriving (Show,Eq,Ord)++data FilePathSpan = FpSpan+ !FileName -- the file path has some fixed fileid in the+ !PatchId -- span starting here+ !(Maybe PatchId) -- and (maybe) ending here+ deriving (Show,Eq,Ord)++-- | info about a given fileid, e.g.. is a file or a directory+data FileInfo = FileInfo { isFile::Bool,+ touching::Set Word32} -- first word of patch hash+ deriving (Show,Eq,Ord)++-- | timespans where a certain filename corresponds to a file with a given id+type FileIdSpans = Map FileName [FileIdSpan]++-- | timespans where a file with a certain id corresponds to given filenames+type FilePathSpans = Map FileId [FilePathSpan]++-- | information file with a given ID+type InfoMap = Map FileId FileInfo++-- | the patch-index+data PatchIndex =+ PatchIndex {+ -- |all the PatchIds tracked by this patch index, with the most+ -- recent patch at the head of the list (note, stored in the+ -- reverse order to this on disk for backwards compatibility+ -- with an older format).+ pids::[PatchId],+ fidspans::FileIdSpans,+ fpspans::FilePathSpans,+ infom::InfoMap+ }++-- | an empty patch-index+emptyPatchIndex :: PatchIndex+emptyPatchIndex = PatchIndex [] M.empty M.empty M.empty++-- | On-disk version of patch index+-- version 1 is the one introduced in darcs 2.10+-- 2 changes the pids order to newer-to-older+version :: Int8+version = 2++-- ---------------------------------------------------------------------+-- Query the patch-index++getInventoryHash :: FilePath -> IO String+getInventoryHash repodir = do+ inv <- B.readFile (repodir </> darcsdir </> "hashed_inventory")+ return $ sha256sum inv++-- ---------------------------------------------------------------------+-- create patch-index++-- | 'applyPatchMods pmods pindex' applies a list of PatchMods to the given+-- patch index pindex+applyPatchMods :: [(PatchId, [PatchMod FileName])] -> PatchIndex -> PatchIndex+applyPatchMods pmods pindex =+ flip execState pindex $ mapM_ goList pmods+ where goList :: (PatchId, [PatchMod FileName]) -> PIM ()+ -- nubSeq handles invalid patch in darcs repo:+ -- move with identical target name "rename darcs_patcher to darcs-patcher."+ goList (pid, mods) = do+ modify (\pind -> pind{pids = pid:pids pind})+ mapM_ (curry go pid) (nubSeq mods)++ go :: (PatchId, PatchMod FileName) -> PIM ()+ go (pid, PCreateFile fn) = do+ fid <- createFidStartSpan fn pid+ startFpSpan fid fn pid+ createInfo fid True+ insertTouch fid pid+ go (pid, PCreateDir fn) = do+ fid <- createFidStartSpan fn pid+ startFpSpan fid fn pid+ createInfo fid False+ insertTouch fid pid+ go (pid, PTouch fn) = do+ fid <- lookupFid fn+ insertTouch fid pid+ go (pid, PRename oldfn newfn) = do+ fid <- lookupFid oldfn+ stopFpSpan fid pid+ startFpSpan fid newfn pid+ insertTouch fid pid+ stopFidSpan oldfn pid+ startFidSpan newfn pid fid+ go (pid, PRemove fn) = do+ fid <- lookupFid fn+ insertTouch fid pid+ stopFidSpan fn pid+ stopFpSpan fid pid+ go (_, PInvalid _) = return () -- just ignore invalid changes+ go (pid, PDuplicateTouch fn) = do+ fidm <- gets fidspans+ case M.lookup fn fidm of+ Just (FidSpan fid _ _:_) -> insertTouch fid pid+ Nothing -> return ()+ Just [] -> error $ "applyPatchMods: impossible, no entry for "++show fn+ ++" in FileIdSpans in duplicate, empty list"++-- ---------------------------------------------------------------------+-- Update and query patch index++type PIM a = State PatchIndex a++-- | create new filespan for created file+createFidStartSpan :: FileName -> PatchId -> PIM FileId+createFidStartSpan fn pstart = do+ fidspans <- gets fidspans+ case M.lookup fn fidspans of+ Nothing -> do+ let fid = FileId fn 1+ modify (\pind -> pind {fidspans=M.insert fn [FidSpan fid pstart Nothing] fidspans})+ return fid+ Just fspans -> do+ let fid = FileId fn (length fspans+1)+ modify (\pind -> pind {fidspans=M.insert fn (FidSpan fid pstart Nothing:fspans) fidspans})+ return fid++-- | start new span for name fn for file fid starting with patch pid+startFpSpan :: FileId -> FileName -> PatchId -> PIM ()+startFpSpan fid fn pstart = modify (\pind -> pind {fpspans=M.alter alt fid (fpspans pind)})+ where alt Nothing = Just [FpSpan fn pstart Nothing]+ alt (Just spans) = Just (FpSpan fn pstart Nothing:spans)++-- | stop current span for file name fn+stopFpSpan :: FileId -> PatchId -> PIM ()+stopFpSpan fid pend = modify (\pind -> pind {fpspans=M.alter alt fid (fpspans pind)})+ where alt Nothing = error $ "impossible: no span for " ++ show fid+ alt (Just []) = error $ "impossible: no span for " ++ show fid++", empty list"+ alt (Just (FpSpan fp pstart Nothing:spans)) =+ Just (FpSpan fp pstart (Just pend):spans)+ alt _ = error $ "impossible: span already ended for " ++ show fid++-- | start new span for name fn for file fid starting with patch pid+startFidSpan :: FileName -> PatchId -> FileId -> PIM ()+startFidSpan fn pstart fid = modify (\pind -> pind {fidspans=M.alter alt fn (fidspans pind)})+ where alt Nothing = Just [FidSpan fid pstart Nothing]+ alt (Just spans) = Just (FidSpan fid pstart Nothing:spans)++-- | stop current span for file name fn+stopFidSpan :: FileName -> PatchId -> PIM ()+stopFidSpan fn pend = modify (\pind -> pind {fidspans=M.alter alt fn (fidspans pind)})+ where alt Nothing = error $ "impossible: no span for " ++ show fn+ alt (Just []) = error $ "impossible: no span for " ++ show fn++", empty list"+ alt (Just (FidSpan fid pstart Nothing:spans)) =+ Just (FidSpan fid pstart (Just pend):spans)+ alt _ = error $ "impossible: span already ended for " ++ show fn++-- | insert touching patchid for given file id+createInfo :: FileId -> Bool -> PIM ()+createInfo fid isF = modify (\pind -> pind {infom=M.alter alt fid (infom pind)})+ where alt Nothing = Just (FileInfo isF S.empty)+ alt (Just _) = Just (FileInfo isF S.empty) -- forget old false positives++-- | insert touching patchid for given file id+insertTouch :: FileId -> PatchId -> PIM ()+insertTouch fid pid = modify (\pind -> pind {infom=M.alter alt fid (infom pind)})+ where alt Nothing = impossible "Fileid does not exist"+ alt (Just (FileInfo isF pids)) = Just (FileInfo isF (S.insert (short pid) pids))++-- | lookup current fid of filepath+lookupFid :: FileName -> PIM FileId+lookupFid fn = do+ maybeFid <- lookupFid' fn+ case maybeFid of+ Nothing -> bug $ "couldn't find " ++ fn2fp fn ++ " in patch index"+ Just fid -> return fid++-- | lookup current fid of filepatch, returning a Maybe to allow failure+lookupFid' :: FileName -> PIM (Maybe FileId)+lookupFid' fn = do+ fidm <- gets fidspans+ case M.lookup fn fidm of+ Just (FidSpan fid _ _:_) -> return $ Just fid+ _ -> return Nothing+++-- | lookup all the file ids of a given path+lookupFidf' :: FileName -> PIM [FileId]+lookupFidf' fn = do+ fidm <- gets fidspans+ case M.lookup fn fidm of+ Just spans -> return $ map (\(FidSpan fid _ _) -> fid) spans+ Nothing ->+ error $ "lookupFidf': no entry for " ++ show fn ++ " in FileIdSpans"++-- | return all fids of matching subpaths+-- of the given filepath+lookupFids :: FileName -> PIM [FileId]+lookupFids fn = do+ fid_spans <- gets fidspans+ file_idss <- mapM (lookupFidf' . fp2fn) $ filter (isPrefixOf (fn2fp fn)) (fpSpans2filePaths' fid_spans)+ return $ nub $ concat file_idss++-- | returns a single file id if the given path is a file+-- if it is a directory, if returns all the file ids of all paths inside it,+-- at any point in repository history+lookupFids' :: FileName -> PIM [FileId]+lookupFids' fn = do+ info_map <- gets infom+ fps_spans <- gets fpspans+ a <- lookupFid' fn+ if isJust a then do+ let fid = fromJust a+ case M.lookup fid info_map of+ Just (FileInfo True _) -> return [fid]+ Just (FileInfo False _) ->+ let file_names = map (\(FpSpan x _ _) -> x) (fps_spans M.! fid)+ in nub . concat <$> mapM lookupFids file_names+ Nothing -> error "lookupFids' : could not find file"+ else return []++-- | remove sequential duplicates+nubSeq :: Eq a => [a] -> [a]+nubSeq = map head . group++-- ---------------------------------------------------------------------+-- Create/Update patch-index on disk++-- | create patch index that corresponds to all patches in repo+createPatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()+createPatchIndexDisk repository = do+ rawpatches <- newset2FL `fmap` readRepo repository+ let patches = mapFL Sealed2 rawpatches+ createPatchIndexFrom repository $ patches2patchMods patches S.empty++-- | convert patches to patchmods+patches2patchMods :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)+ => [Sealed2 (PatchInfoAnd p)] -> Set FileName -> [(PatchId, [PatchMod FileName])]+patches2patchMods patches fns = snd $ mapAccumL go fns patches+ where+ go filenames (Sealed2 p) = (filenames', (pid, pmods_effect ++ pmods_dup))+ where pid = makePatchID . info $ p+ (filenames', pmods_effect) = applyToFileMods p filenames+ -- applyToFileMods only returns patchmods that actually modify a file,+ -- i.e., never duplicate patches+ touched pm = case pm of {PTouch f -> [f]; PRename a b -> [a,b];+ PCreateDir f -> [f]; PCreateFile f -> [f];+ PRemove f -> [f]; _ -> []}+ touched_all = map fp2fn $ listTouchedFiles p+ touched_effect = concatMap touched pmods_effect+ touched_invalid = [ f | (PInvalid f) <- pmods_effect]+ -- listTouchedFiles returns all files that touched by these+ -- patches, even if they have no effect, e.g. by duplicate patches+ pmods_dup = map PDuplicateTouch . S.elems+ $ S.difference (S.fromList touched_all)+ (S.fromList touched_invalid+ `S.union`+ S.fromList touched_effect)++-- | return set of current filenames in patch index+fpSpans2fileNames :: FilePathSpans -> Set FileName+fpSpans2fileNames fpSpans =+ S.fromList [fn | (FpSpan fn _ Nothing:_)<- M.elems fpSpans]++-- | remove all patch effects of given patches from patch index.+-- assumes that the given list of patches is a suffix of the+-- patches tracked by the patch-index+removePidSuffix :: Map PatchId Int -> [PatchId] -> PatchIndex -> PatchIndex+removePidSuffix _ [] pindex = pindex+removePidSuffix pid2idx oldpids@(oldpid:_) (PatchIndex pids fidspans fpspans infom) =+ PatchIndex (pids \\ oldpids)+ (M.mapMaybe removefid fidspans)+ (M.mapMaybe removefp fpspans)+ infom -- leave hashes in infom, false positives are harmless+ where+ findIdx pid = fromMaybe (impossible "removePidSuffix") (M.lookup pid pid2idx)+ oldidx = findIdx oldpid+ from `after` idx = findIdx from > idx+ mto `afterM` idx | Just to <- mto, findIdx to > idx = True+ | otherwise = False+ removefid fidsps = if null fidsps' then Nothing else Just fidsps'+ where+ fidsps' = concatMap go fidsps+ go (FidSpan fid from mto)+ | from `after` oldidx && mto `afterM` oldidx = [FidSpan fid from mto]+ | from `after` oldidx = [FidSpan fid from Nothing]+ | otherwise = []+ removefp fpsps = if null fpsps' then Nothing else Just fpsps'+ where+ fpsps' = concatMap go fpsps+ go (FpSpan fn from mto)+ | from `after` oldidx && mto `afterM` oldidx = [FpSpan fn from mto]+ | from `after` oldidx = [FpSpan fn from Nothing]+ | otherwise = []++-- | update the patch index to the current state of the repository+updatePatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()+updatePatchIndexDisk repo@(Repo repodir _ _ _) = do+ (_,_,pid2idx,pindex) <- loadPatchIndex repodir+ -- check that patch index is up to date+ patches <- newset2FL `fmap` readRepo repo+ let pidsrepo = mapFL (makePatchID . info) patches+ (oldpids,_,len_common) = uncommon (reverse $ pids pindex) pidsrepo+ pindex' = removePidSuffix pid2idx oldpids pindex+ filenames = fpSpans2fileNames (fpspans pindex')+ cdir = repodir </> indexDir+ -- reread to prevent holding onto patches for too long+ rawpatches <- newset2FL `fmap` readRepo repo+ let newpatches = drop len_common $ mapFL seal2 rawpatches+ newpmods = patches2patchMods newpatches filenames+ inv_hash <- getInventoryHash repodir+ storePatchIndex repodir cdir inv_hash (applyPatchMods newpmods pindex')+ where+ -- return uncommon suffixes and length of common prefix of as and bs+ uncommon = uncommon' 0+ uncommon' x (a:as) (b:bs)+ | a == b = uncommon' (x+1) as bs+ | otherwise = (a:as,b:bs,x)+ uncommon' x as bs = (as,bs,x)++-- | 'createPatchIndexFrom repo pmods' creates a patch index from the given+-- patchmods.+createPatchIndexFrom :: RepoPatch p => Repository p wR wU wT+ -> [(PatchId, [PatchMod FileName])] -> IO ()+createPatchIndexFrom (Repo repodir _ _ _) pmods = do+ inv_hash <- getInventoryHash repodir+ storePatchIndex repodir cdir inv_hash (applyPatchMods pmods emptyPatchIndex)+ where cdir = repodir </> indexDir+++-- ---------------------------------------------------------------------+-- Load/Store patch-Index++-- | load patch-index from disk+loadPatchIndex :: FilePath -> IO (Int8, String, Map PatchId Int, PatchIndex)+loadPatchIndex repodir = do+ let pindex_dir = repodir </> indexDir+ (v,inv_hash) <- loadRepoState (pindex_dir </> repoStateFile)+ pids <- loadPatchIds (pindex_dir </> pidsFile)+ let pid2idx = M.fromList $ zip pids [(1::Int)..]+ infom <- loadInfoMap (pindex_dir </> touchMapFile)+ fidspans <- loadFidMap (pindex_dir </> fidMapFile)+ fpspans <- loadFpMap (pindex_dir </> fpMapFile)+ return (v, inv_hash, pid2idx, PatchIndex pids fidspans fpspans infom)++-- | load patch-index,+-- | ensuring that whenever loaded, the patch-index+-- | can actually be read by the current version of darcs,+-- | and up to date.+loadSafePatchIndex :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> IO (Map PatchId Int, PatchIndex)+loadSafePatchIndex repo@(Repo repodir _ _ _) = do+ can_use <- isPatchIndexInSync repo+ (_,_,pid2idx,pi) <-+ if can_use+ then loadPatchIndex repodir+ else do createOrUpdatePatchIndexDisk repo+ loadPatchIndex repodir+ return (pid2idx, pi)++-- | check if patch-index exits for this repository+doesPatchIndexExist :: FilePath -> IO Bool+doesPatchIndexExist repodir = do+ filesArePresent <- fmap and $ mapM (doesFileExist . (pindex_dir </>))+ [repoStateFile, pidsFile, touchMapFile, fidMapFile, fpMapFile]+ if filesArePresent+ then do (v, _, _, _) <- loadPatchIndex repodir+ return (v == version) -- consider PI only of on-disk format is the current one+ else return False+ where pindex_dir = repodir </> indexDir++-- | check if noPatchIndex exists+isPatchIndexDisabled :: FilePath -> IO Bool+isPatchIndexDisabled repodir = doesFileExist (repodir </> darcsdir </> noPatchIndex)++-- | create or update patch index+createOrUpdatePatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> IO ()+createOrUpdatePatchIndexDisk repo@(Repo repodir _ _ _)= do+ rmRecursive (repodir </> darcsdir </> noPatchIndex) `catch` \(_ :: IOError) -> return ()+ dpie <- doesPatchIndexExist repodir+ if dpie+ then updatePatchIndexDisk repo+ else createPatchIndexDisk repo++-- | Checks whether a patch index can (and should) be created. If we are not in+-- an old-fashioned repo, and if we haven't been told not to, then we should+-- create a patch index if it doesn't already exist.+canCreatePI :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT+ -> IO Bool+canCreatePI (Repo repodir format _ _) =+ (not . or) <$> sequence [ doesntHaveHashedInventory format+ , isPatchIndexDisabled repodir+ , doesPatchIndexExist repodir+ ]+ where+ doesntHaveHashedInventory = return . not . formatHas HashedInventory++-- | see if the default is to use patch index or not+-- | creates Patch index, if it does not exist, and noPatchIndex is not set+canUsePatchIndex :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> IO Bool+canUsePatchIndex (Repo repodir _ _ _) = do+ piExists <- doesPatchIndexExist repodir+ piDisabled <- isPatchIndexDisabled repodir+ case (piExists, piDisabled) of+ (True, False) -> return True+ (False, True) -> return False+ (True, True) -> error "patch index exists, and patch index is disabled. run optimize enable-patch-index or disable-patch-index to rectify."+ (False, False) -> return False++createPIWithInterrupt :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> IO ()+createPIWithInterrupt repo@(Repo repodir _ _ _) = do+ putStrLn "Creating a patch index, please wait. To stop press Ctrl-C"+ (do+ createPatchIndexDisk repo+ putStrLn "Created patch index.") `catchInterrupt` (putStrLn "Patch Index Disabled" >> deletePatchIndex repodir)++-- | check if patch-index is in sync with repository+isPatchIndexInSync :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> IO Bool+isPatchIndexInSync (Repo repodir _ _ _) = do+ dpie <- doesPatchIndexExist repodir+ if dpie+ then do+ (_, inv_hash_pindex, _, _) <- loadPatchIndex repodir+ inv_hash <- getInventoryHash repodir+ return (inv_hash == inv_hash_pindex)+ else return False++-- | store patch-index on disk+storePatchIndex :: FilePath -> FilePath -> String -> PatchIndex -> IO ()+storePatchIndex repodir cdir inv_hash (PatchIndex pids fidspans fpspans infom) = do+ createDirectory cdir `catch` \(_ :: IOError) -> return ()+ tmpdir <- withPermDir (repodir </> "filecache-tmp") $ \dir -> do+ debugMessage "About to create patch index..."+ let tmpdir = toFilePath dir+ storeRepoState (tmpdir </> repoStateFile) inv_hash+ storePatchIds (tmpdir </> pidsFile) pids+ storeInfoMap (tmpdir </> touchMapFile) infom+ storeFidMap (tmpdir </> fidMapFile) fidspans+ storeFpMap (tmpdir </> fpMapFile) fpspans+ debugMessage "Patch index created"+ return tmpdir+ rmRecursive cdir `catch` \(_ :: IOError) -> return ()+ renameDirectory tmpdir cdir++storeRepoState :: FilePath -> String -> IO ()+storeRepoState fp inv_hash = encodeFile fp (version,inv_hash)++loadRepoState :: FilePath -> IO (Int8, String)+loadRepoState = decodeFile++storePatchIds :: FilePath -> [PatchId] -> IO ()+storePatchIds = encodeFile++loadPatchIds :: FilePath -> IO [PatchId]+loadPatchIds = decodeFile++storeFidMap :: FilePath -> FileIdSpans -> IO ()+storeFidMap fp fidm =+ encodeFile fp $ M.map (map (\(FidSpan a b c) -> (a, b, toIdxM c))) fidm+ where toIdxM (Nothing) = zero+ toIdxM (Just pid) = pid++loadFidMap :: FilePath -> IO FileIdSpans+loadFidMap fp = M.map (map (\(a,b,c) -> FidSpan a b (toPidM c))) <$> decodeFile fp+ where toPidM pid | pid == zero = Nothing+ | otherwise = Just pid++storeFpMap :: FilePath -> FilePathSpans -> IO ()+storeFpMap fp fidm =+ encodeFile fp $ M.map (map (\(FpSpan a b c) -> (a, b, toIdxM c))) fidm+ where toIdxM (Nothing) = zero+ toIdxM (Just pid) = pid++loadFpMap :: FilePath -> IO FilePathSpans+loadFpMap fp = M.map (map (\(a,b,c) -> FpSpan a b (toPidM c))) <$> decodeFile fp+ where toPidM pid | pid == zero = Nothing+ | otherwise = Just pid++zero :: PatchId+zero = PID $ SHA1 0 0 0 0 0++storeInfoMap :: FilePath -> InfoMap -> IO ()+storeInfoMap fp infom =+ encodeFile fp $ M.map (\fi -> (isFile fi, touching fi)) infom++loadInfoMap :: FilePath -> IO InfoMap+loadInfoMap fp = M.map (\(isF,pids) -> FileInfo isF pids) <$> decodeFile fp++-- | Base directory for the patch index+indexDir :: String+indexDir = darcsdir </> "patch_index"++repoStateFile :: String+repoStateFile = "repo_state"++pidsFile :: String+pidsFile = "patch_ids"++fidMapFile :: String+fidMapFile = "fid_map"++fpMapFile :: String+fpMapFile = "fp_map"++touchMapFile :: String+touchMapFile = "touch_map"++noPatchIndex :: String+noPatchIndex = "no_patch_index"++-----------------------------------------------------------------------+-- Delete patch index+deletePatchIndex :: FilePath -> IO ()+deletePatchIndex repodir = do+ exists <- doesDirectoryExist indexDir+ when exists $+ rmRecursive indexDir+ `catch` \(e :: IOError) -> error $ "Error: Could not delete patch index\n" ++ show e+ (openFile (repodir </> darcsdir </> noPatchIndex) WriteMode >>= hClose)+ `catch` \(e :: IOError) -> error $ "Error: Could not disable patch index\n" ++ show e++-----------------------------------------------------------------------+-- Dump information in patch index++dumpRepoState :: [PatchId] -> String+dumpRepoState = unlines . map pid2string++dumpFileIdSpans :: FileIdSpans -> String+dumpFileIdSpans fidspans =+ unlines [fn2fp fn++" -> "++showFileId fid++" from "++pid2string from++" to "++maybe "-" pid2string mto+ | (fn, fids) <- M.toList fidspans, FidSpan fid from mto <- fids]++dumpFilePathSpans :: FilePathSpans -> String+dumpFilePathSpans fpspans =+ unlines [showFileId fid++" -> "++ fn2fp fn++" from "++pid2string from++" to "++maybe "-" pid2string mto+ | (fid, fns) <- M.toList fpspans, FpSpan fn from mto <- fns]++dumpTouchingMap :: InfoMap -> String+dumpTouchingMap infom = unlines [showFileId fid++(if isF then "" else "/")++" -> "++ showAsHex w32+ | (fid,FileInfo isF w32s) <- M.toList infom, w32 <- S.elems w32s]++-- | return set of current filepaths in patch index+fpSpans2filePaths :: FilePathSpans -> InfoMap -> [FilePath]+fpSpans2filePaths fpSpans infom =+ sort [fn2fp fn ++ (if isF then "" else "/") | (fid,FpSpan fn _ Nothing:_) <- M.toList fpSpans,+ let Just (FileInfo isF _) = M.lookup fid infom]++-- | return set of current filepaths in patch index, for internal use+fpSpans2filePaths' :: FileIdSpans -> [FilePath]+fpSpans2filePaths' fidSpans = [fn2fp fp | (fp, _) <- M.toList fidSpans]++dumpPatchIndex :: FilePath -> IO ()+dumpPatchIndex repodir = do+ (_,inv_hash,_,PatchIndex pids fidspans fpspans infom) <- loadPatchIndex repodir+ putStrLn $ "Inventory hash:" ++ inv_hash+ putStrLn "================="+ putStrLn "Repo state:"+ putStrLn "==========="+ putStrLn $ dumpRepoState pids+ putStrLn "Fileid spans:"+ putStrLn "============="+ putStrLn $ dumpFileIdSpans fidspans+ putStrLn "Filepath spans:"+ putStrLn "=============="+ putStrLn $ dumpFilePathSpans fpspans+ putStrLn "Info Map:"+ putStrLn "========="+ putStrLn $ dumpTouchingMap infom+ putStrLn "Files:"+ putStrLn "=============="+ putStrLn $ unlines $ fpSpans2filePaths fpspans infom+++dumpPatchIndexFiles :: FilePath -> IO ()+dumpPatchIndexFiles repodir = do+ (_,_,_,PatchIndex _ _ fpspans infom) <- loadPatchIndex repodir+ putStr $ unlines $ fpSpans2filePaths fpspans infom++-----------------------------------------------------------------------+-- Filtering functions based on FilePaths+-- returns an RL in which the order of patches matters, for annotate to use+getRelevantSubsequence :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p)+ => Sealed ((RL a) wK) -> Repository p wR wU wR -> [FileName] -> IO (Sealed ((RL a) Origin))+getRelevantSubsequence pxes repository fns = do+ (_, pi@(PatchIndex _ _ _ infom)) <- loadSafePatchIndex repository+ let fids = map (\fn -> evalState (lookupFid fn) pi) fns+ pidss = map ((\(FileInfo _ a) -> a).fromJust.(`M.lookup` infom)) fids+ pids = S.unions pidss+ let flpxes = reverseRL $ unsafeUnseal pxes+ return.seal $ keepElems flpxes NilRL pids++ where keepElems :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p)+ => FL a wX wY -> RL a wB wX -> S.Set Word32 -> RL a wP wQ+ keepElems NilFL acc _ = unsafeCoerceP acc+ keepElems (x:>:xs) acc pids+ | (short $ makePatchID $ info x) `S.member` pids = keepElems xs (x:<:acc) pids+ | otherwise = keepElems (unsafeCoerceP xs) acc pids++-- | filter given patches so as to keep only the patches that modify the given files+filterPatches :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p) => Repository p wR wU wT -> [FilePath] -> [Sealed2 a] -> IO [Sealed2 a]+filterPatches repository fps ops = do+ (_, pi@(PatchIndex _ _ _ infom)) <- loadSafePatchIndex repository+ let fids = concatMap ((\fn -> evalState (lookupFids' fn) pi). fp2fn) fps+ npids = S.unions $ map (touching.fromJust.(`M.lookup` infom)) fids+ return $ filter (flip S.member npids . (\(Sealed2 (PIAP pin _)) -> short $ makePatchID pin)) ops++type PatchFilter p = [FilePath] -> [Sealed2 (PatchInfoAnd p)] -> IO [Sealed2 (PatchInfoAnd p)]++-- | If a patch index is available, filter given patches so as to keep only the patches that+-- modify the given files. If none is available, return the original input.+maybeFilterPatches+ :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> PatchFilter p+maybeFilterPatches repo fps ops = do+ usePI <- canUsePatchIndex repo+ -- in theory we could change the type signature to make this function staged,+ -- but it doesn't seem worth it.+ if usePI then filterPatches repo fps ops else return ops+++-----------------------------------------------------------------------+-- Test patch index++piTest :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()+piTest repository = do+ (_, PatchIndex rpids fidspans fpspans infom) <- loadSafePatchIndex repository+ let pids = reverse rpids++ -- test fidspans+ putStrLn "fidspans"+ putStrLn "==========="+ forM_ (M.toList fidspans) $ \(fn, spans) -> do+ let g :: FileIdSpan -> [PatchId]+ g (FidSpan _ x (Just y)) = [y,x]+ g (FidSpan _ x _) = [x]+ ascTs = reverse . nub . concat $ map g spans+ unless (isInOrder ascTs pids) (error $ "In order test failed! filename: " ++ show fn)+ forM_ spans $ \(FidSpan fid _ _) -> unless (M.member fid fpspans) (error $ "Valid file id test failed! fid: " ++ show fid)+ putStrLn "fidspans tests passed"++ -- test fpspans+ putStrLn "fpspans"+ putStrLn "==========="+ forM_ (M.toList fpspans) $ \(fid, spans) -> do+ let g :: FilePathSpan -> [PatchId]+ g (FpSpan _ x (Just y)) = [y,x]+ g (FpSpan _ x _) = [x]+ ascTs = reverse . nub . concat $ map g spans+ unless (isInOrder ascTs pids) (error $ "In order test failed! fileid: " ++ show fid)+ forM_ spans $ \(FpSpan fn _ _) -> unless (M.member fn fidspans) (error $ "Valid file name test failed! file name: " ++ show fn)+ let f :: FilePathSpan -> FilePathSpan -> Bool+ f (FpSpan _ x _) (FpSpan _ _ (Just y)) = x == y+ f _ _ = error "adj test of fpspans fail"+ unless (and $ zipWith f spans (tail spans)) (error $ "Adjcency test failed! fid: " ++ show fid)+ putStrLn "fpspans tests passed"++ -- test infomap+ putStrLn "infom"+ putStrLn "==========="+ putStrLn $ "Valid fid test: " ++ (show.and $ map (`M.member` fpspans) (M.keys infom))+ putStrLn $ "Valid pid test: " ++ (show.flip S.isSubsetOf (S.fromList $ map short pids) . S.unions . map touching . M.elems $ infom)+ where+ isInOrder :: Eq a => [a] -> [a] -> Bool+ isInOrder (x:xs) (y:ys) | x == y = isInOrder xs ys+ | otherwise = isInOrder (x:xs) ys+ isInOrder [] _ = True+ isInOrder _ [] = False++-- | Check if patch index can be created and build it with interrupt.+attemptCreatePatchIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()+attemptCreatePatchIndex repo = do+ canCreate <- canCreatePI repo+ when canCreate $ createPIWithInterrupt repo
src/Darcs/Repository/Prefs.hs view
@@ -18,257 +18,310 @@ {-# LANGUAGE CPP #-} -#include "gadts.h"--module Darcs.Repository.Prefs ( addToPreflist, getPreflist, setPreflist,- getGlobal, environmentHelpHome,- defaultrepo, setDefaultrepo,- getPrefval, setPrefval, changePrefval,- defPrefval,- writeDefaultPrefs,- boringRegexps, boringFileFilter, darcsdirFilter,- FileType(..), filetypeFunction,- getCaches,- binariesFileHelp, boringFileHelp,- globalCacheDir,- globalPrefsDirDoc,- ) where---import Prelude hiding ( catch )+module Darcs.Repository.Prefs+ ( addToPreflist+ , deleteSources+ , getPreflist+ , setPreflist+ , getGlobal+ , environmentHelpHome+ , defaultrepo+ , getDefaultRepoPath+ , addRepoSource+ , getPrefval+ , setPrefval+ , changePrefval+ , defPrefval+ , writeDefaultPrefs+ , boringRegexps+ , boringFileFilter+ , darcsdirFilter+ , FileType(..)+ , filetypeFunction+ , getCaches+ , binariesFileHelp+ , boringFileHelp+ , globalCacheDir+ , globalPrefsDirDoc+ , globalPrefsDir+ , oldGlobalCacheDir+ ) where -import System.IO.Error ( isDoesNotExistError ) import Control.Exception ( catch )-import Control.Monad ( unless, when )-import Text.Regex ( Regex, mkRegex, matchRegex, )+import Control.Monad ( unless, when, liftM ) import Data.Char ( toUpper )-import Data.Maybe ( isJust, fromMaybe, mapMaybe ) import Data.List ( nub, isPrefixOf, union, sortBy )-import System.Directory ( getAppUserDataDirectory, doesDirectoryExist, createDirectory, doesFileExist )-import Darcs.Lock( readBinFile, writeBinFile )-import System.FilePath.Posix ( (</>) )+import Data.Maybe ( isJust, fromMaybe, mapMaybe, catMaybes, maybeToList )+import Prelude hiding ( catch )+import qualified Control.Exception as C+import qualified Data.ByteString as B ( empty )+import qualified Data.ByteString.Char8 as BC ( unpack )+import System.Directory ( getAppUserDataDirectory, doesDirectoryExist,+ createDirectory, doesFileExist ) import System.Environment ( getEnvironment )+import System.FilePath.Posix ( normalise, dropTrailingPathSeparator, (</>) )+import System.IO.Error ( isDoesNotExistError )+import System.IO ( stderr )+import System.Info ( os )+import Text.Regex ( Regex, mkRegex, matchRegex ) -import Darcs.Flags ( DarcsFlag( NoCache, NoSetDefault, DryRun, RemoteRepo ) )-import Darcs.RepoPath ( AbsolutePath, ioAbsolute, toFilePath, getCurrentDirectory )-import Darcs.Utils ( catchall, stripCr )-import Darcs.External ( gzFetchFilePS, Cachable( Cachable ) )-import qualified Data.ByteString.Char8 as BC ( unpack )-import qualified Data.ByteString as B ( empty )-import Darcs.Global ( darcsdir ) import Darcs.Repository.Cache ( Cache(..), CacheType(..), CacheLoc(..), WritableOrNot(..), compareByLocality )-import Darcs.URL ( isFile )+import Darcs.Repository.External ( gzFetchFilePS , Cachable( Cachable ))+import Darcs.Repository.Flags( UseCache (..), DryRun (..), SetDefault (..),+ RemoteRepos (..) )+import Darcs.Repository.Lock( readBinFile, writeBinFile )+import Darcs.Util.Exception ( catchall )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Path ( AbsolutePath, ioAbsolute, toFilePath,+ getCurrentDirectory )+import Darcs.Util.Printer( hPutDocLn, text, RenderMode(..) )+import Darcs.Util.URL ( isValidLocalPath )+import Darcs.Util.File ( osxCacheDir, xdgCacheDir, removeFileMayNotExist ) +windows,osx :: Bool+windows = "mingw" `isPrefixOf` os -- GHC under Windows is compiled with mingw+osx = os == "darwin" writeDefaultPrefs :: IO ()-writeDefaultPrefs = do setPreflist "boring" defaultBoring- setPreflist "binaries" defaultBinaries- setPreflist "motd" []+writeDefaultPrefs = do+ setPreflist "boring" defaultBoring+ setPreflist "binaries" defaultBinaries+ setPreflist "motd" [] {-# NOINLINE defaultBoring #-} defaultBoring :: [String]-defaultBoring = help ++- [ "",- "### compiler and interpreter intermediate files",- "# haskell (ghc) interfaces",- "\\.hi$", "\\.hi-boot$", "\\.o-boot$",- "# object files",- "\\.o$","\\.o\\.cmd$",- "# profiling haskell",- "\\.p_hi$", "\\.p_o$",- "# haskell program coverage resp. profiling info",- "\\.tix$", "\\.prof$",- "# fortran module files",- "\\.mod$",- "# linux kernel",- "\\.ko\\.cmd$","\\.mod\\.c$",- "(^|/)\\.tmp_versions($|/)",- "# *.ko files aren't boring by default because they might",- "# be Korean translations rather than kernel modules",- "# \\.ko$",- "# python, emacs, java byte code",- "\\.py[co]$", "\\.elc$","\\.class$",- "# objects and libraries; lo and la are libtool things",- "\\.(obj|a|exe|so|lo|la)$",- "# compiled zsh configuration files",- "\\.zwc$",- "# Common LISP output files for CLISP and CMUCL",- "\\.(fas|fasl|sparcf|x86f)$",- "",- "### build and packaging systems",- "# cabal intermediates",- "\\.installed-pkg-config",- "\\.setup-config",- "# standard cabal build dir, might not be boring for everybody",- "# ^dist(/|$)",- "# autotools",- "(^|/)autom4te\\.cache($|/)", "(^|/)config\\.(log|status)$",- "# microsoft web expression, visual studio metadata directories",- "\\_vti_cnf$",- "\\_vti_pvt$",- "# gentoo tools",- "\\.revdep-rebuild.*",- "# generated dependencies",- "^\\.depend$",- "",- "### version control systems",- "# cvs",- "(^|/)CVS($|/)","\\.cvsignore$",- "# cvs, emacs locks",- "^\\.#",- "# rcs",- "(^|/)RCS($|/)", ",v$",- "# subversion",- "(^|/)\\.svn($|/)",- "# mercurial",- "(^|/)\\.hg($|/)",- "# git",- "(^|/)\\.git($|/)",- "# bzr",- "\\.bzr$",- "# sccs",- "(^|/)SCCS($|/)",- "# darcs",- "(^|/)"++darcsdir++"($|/)", "(^|/)\\.darcsrepo($|/)",- "^\\.darcs-temp-mail$",- "-darcs-backup[[:digit:]]+$",- "# gnu arch",- "(^|/)(\\+|,)",- "(^|/)vssver\\.scc$",- "\\.swp$","(^|/)MT($|/)",- "(^|/)\\{arch\\}($|/)","(^|/).arch-ids($|/)",- "# bitkeeper",- "(^|/)BitKeeper($|/)","(^|/)ChangeSet($|/)",- "",- "### miscellaneous",- "# backup files",- "~$","\\.bak$","\\.BAK$",- "# patch originals and rejects",- "\\.orig$", "\\.rej$",- "# X server",- "\\..serverauth.*",- "# image spam",- "\\#", "(^|/)Thumbs\\.db$",- "# vi, emacs tags",- "(^|/)(tags|TAGS)$",- "#(^|/)\\.[^/]",- "# core dumps",- "(^|/|\\.)core$",- "# partial broken files (KIO copy operations)",- "\\.part$",- "# waf files, see http://code.google.com/p/waf/",- "(^|/)\\.waf-[[:digit:].]+-[[:digit:]]+($|/)",- "(^|/)\\.lock-wscript$",- "# mac os finder",- "(^|/)\\.DS_Store$" ]- where- help = map ("# "++) boringFileHelp+defaultBoring = map ("# " ++) boringFileHelp +++ [ ""+ , "### compiler and interpreter intermediate files"+ , "# haskell (ghc) interfaces"+ , "\\.hi$", "\\.hi-boot$", "\\.o-boot$"+ , "# object files"+ , "\\.o$","\\.o\\.cmd$"+ , "# profiling haskell"+ , "\\.p_hi$", "\\.p_o$"+ , "# haskell program coverage resp. profiling info"+ , "\\.tix$", "\\.prof$"+ , "# fortran module files"+ , "\\.mod$"+ , "# linux kernel"+ , "\\.ko\\.cmd$","\\.mod\\.c$"+ , "(^|/)\\.tmp_versions($|/)"+ , "# *.ko files aren't boring by default because they might"+ , "# be Korean translations rather than kernel modules"+ , "# \\.ko$"+ , "# python, emacs, java byte code"+ , "\\.py[co]$", "\\.elc$","\\.class$"+ , "# objects and libraries; lo and la are libtool things"+ , "\\.(obj|a|exe|so|lo|la)$"+ , "# compiled zsh configuration files"+ , "\\.zwc$"+ , "# Common LISP output files for CLISP and CMUCL"+ , "\\.(fas|fasl|sparcf|x86f)$"+ , ""+ , "### build and packaging systems"+ , "# cabal intermediates"+ , "\\.installed-pkg-config"+ , "\\.setup-config"+ , "# standard cabal build dir, might not be boring for everybody"+ , "# ^dist(/|$)"+ , "# autotools"+ , "(^|/)autom4te\\.cache($|/)", "(^|/)config\\.(log|status)$"+ , "# microsoft web expression, visual studio metadata directories"+ , "\\_vti_cnf$"+ , "\\_vti_pvt$"+ , "# gentoo tools"+ , "\\.revdep-rebuild.*"+ , "# generated dependencies"+ , "^\\.depend$"+ , ""+ , "### version control systems"+ , "# cvs"+ , "(^|/)CVS($|/)","\\.cvsignore$"+ , "# cvs, emacs locks"+ , "^\\.#"+ , "# rcs"+ , "(^|/)RCS($|/)", ",v$"+ , "# subversion"+ , "(^|/)\\.svn($|/)"+ , "# mercurial"+ , "(^|/)\\.hg($|/)"+ , "# git"+ , "(^|/)\\.git($|/)"+ , "# bzr"+ , "\\.bzr$"+ , "# sccs"+ , "(^|/)SCCS($|/)"+ , "# darcs"+ , "(^|/)"++darcsdir++"($|/)", "(^|/)\\.darcsrepo($|/)"+ , "^\\.darcs-temp-mail$"+ , "-darcs-backup[[:digit:]]+$"+ , "# gnu arch"+ , "(^|/)(\\+|,)"+ , "(^|/)vssver\\.scc$"+ , "\\.swp$","(^|/)MT($|/)"+ , "(^|/)\\{arch\\}($|/)","(^|/).arch-ids($|/)"+ , "# bitkeeper"+ , "(^|/)BitKeeper($|/)","(^|/)ChangeSet($|/)"+ , ""+ , "### miscellaneous"+ , "# backup files"+ , "~$","\\.bak$","\\.BAK$"+ , "# patch originals and rejects"+ , "\\.orig$", "\\.rej$"+ , "# X server"+ , "\\..serverauth.*"+ , "# image spam"+ , "\\#", "(^|/)Thumbs\\.db$"+ , "# vi, emacs tags"+ , "(^|/)(tags|TAGS)$"+ , "#(^|/)\\.[^/]"+ , "# core dumps"+ , "(^|/|\\.)core$"+ , "# partial broken files (KIO copy operations)"+ , "\\.part$"+ , "# waf files, see http://code.google.com/p/waf/"+ , "(^|/)\\.waf-[[:digit:].]+-[[:digit:]]+($|/)"+ , "(^|/)\\.lock-wscript$"+ , "# mac os finder"+ , "(^|/)\\.DS_Store$"+ , "# emacs saved sessions (desktops)"+ , "(^|.*/)\\.emacs\\.desktop(\\.lock)?$"+ ] boringFileHelp :: [String] boringFileHelp =- [ "This file contains a list of extended regular expressions, one per"- , "line. A file path matching any of these expressions will be filtered"- , "out during `darcs add', or when the `--look-for-adds' flag is passed"- , "to `darcs whatsnew' and `record'. The entries in " ++ globalPrefsDirDoc ++ "boring (if"- , "it exists) supplement those in this file."- , ""- , "Blank lines, and lines beginning with an octothorpe (#) are ignored."- , "See regex(7) for a description of extended regular expressions."- ]+ [ "This file contains a list of extended regular expressions, one per"+ , "line. A file path matching any of these expressions will be filtered"+ , "out during `darcs add', or when the `--look-for-adds' flag is passed"+ , "to `darcs whatsnew' and `record'. The entries in "+ ++ globalPrefsDirDoc ++ "boring (if"+ , "it exists) supplement those in this file."+ , ""+ , "Blank lines, and lines beginning with an octothorpe (#) are ignored."+ , "See regex(7) for a description of extended regular expressions."+ ] darcsdirFilter :: [FilePath] -> [FilePath]-darcsdirFilter = filter (not.isDarcsdir)+darcsdirFilter = filter (not . isDarcsdir)+ isDarcsdir :: FilePath -> Bool-isDarcsdir ('.':'/':f) = isDarcsdir f+isDarcsdir ('.' : '/' : f) = isDarcsdir f isDarcsdir "." = True isDarcsdir "" = True isDarcsdir ".." = True isDarcsdir "../" = True-isDarcsdir "_darcs" = True-isDarcsdir fp = "_darcs/" `isPrefixOf` fp+isDarcsdir fp = (darcsdir ++ "/") `isPrefixOf` fp || fp == darcsdir -- | The path of the global preference directory; @~/.darcs@ on Unix, -- and @%APPDATA%/darcs@ on Windows. globalPrefsDir :: IO (Maybe FilePath) globalPrefsDir = do- env <- getEnvironment- case lookup "DARCS_TESTING_PREFS_DIR" env of- Just d -> return (Just d)- Nothing -> fmap Just (getAppUserDataDirectory "darcs")- `catchall` (return Nothing)+ env <- getEnvironment+ case lookup "DARCS_TESTING_PREFS_DIR" env of+ Just d -> return (Just d)+ Nothing -> Just `fmap` getAppUserDataDirectory "darcs"+ `catchall` return Nothing -- | The relative path of the global preference directory; @~/.darcs@ on Unix, -- and @%APPDATA%/darcs@ on Windows. This is used for online documentation. globalPrefsDirDoc :: String-globalPrefsDirDoc =-#ifndef WIN32- "~/.darcs/"-#else- "%APPDATA%\\darcs\\"-#endif+globalPrefsDirDoc | windows = "%APPDATA%\\darcs\\"+ | otherwise = "~/.darcs/" environmentHelpHome :: ([String], [String])-environmentHelpHome = (["HOME", "APPDATA"], [- "Per-user preferences are set in $HOME/.darcs (on Unix) or",- "%APPDATA%/darcs (on Windows). This is also the default location of",- "the cache."])+environmentHelpHome =+ ( ["HOME", "APPDATA"]+ , [ "Per-user preferences are set in $HOME/.darcs (on Unix) or"+ , "%APPDATA%/darcs (on Windows). This is also the default location of"+ , "the cache."+ ]+ ) getGlobal :: String -> IO [String] getGlobal f = do- dir <- globalPrefsDir- case dir of- (Just d) -> getPreffile $ d </> f- Nothing -> return []+ dir <- globalPrefsDir+ case dir of+ (Just d) -> getPreffile $ d </> f+ Nothing -> return [] globalCacheDir :: IO (Maybe FilePath)-globalCacheDir = slash_cache `fmap` globalPrefsDir- where slash_cache = fmap (</> "cache")+globalCacheDir | windows = ((</> "cache2") `fmap`) `fmap` globalPrefsDir+ | osx = ((</> "darcs") `fmap`) `fmap` osxCacheDir+ | otherwise = ((</> "darcs") `fmap`) `fmap` xdgCacheDir +-- |oldGlobalCacheDir is the old cache path @~/.darcs/cache@+-- now ony used with read-only access.+oldGlobalCacheDir :: IO (Maybe FilePath)+oldGlobalCacheDir+ = do dir <- ((</> "cache") `fmap`) `fmap` globalPrefsDir+ case dir of+ Nothing -> return Nothing+ Just d -> do exists <- doesDirectoryExist d+ if exists+ then return $ Just d+ else return Nothing++-- |tryMakeBoringRegexp attempts to create a Regex from a given String. The+-- evaluation is forced, to ensure any malformed exceptions are thrown here,+-- and not later.+tryMakeBoringRegexp :: String -> IO (Maybe Regex)+tryMakeBoringRegexp input = regex `C.catch` handleBadRegex+ where+ regex = C.evaluate (Just $! mkRegex input)++ handleBadRegex :: C.SomeException -> IO (Maybe Regex)+ handleBadRegex _ = hPutDocLn Encode stderr warning >> return Nothing++ warning = text $ "Warning: Ignored invalid boring regex: " ++ input++-- |boringRegexps returns a list of the boring regexps, from the local and+-- global prefs/boring files. Any invalid regexps are filtered, preventing an+-- exception in (potentially) pure code, when the regexps are used. boringRegexps :: IO [Regex] boringRegexps = do borefile <- defPrefval "boringfile" (darcsdir ++ "/prefs/boring")- bores <- getPrefLines borefile `catchall` return []- gbs <- getGlobal "boring"- return $ map mkRegex $ bores ++ gbs+ localBores <- getPrefLines borefile `catchall` return []+ globalBores <- getGlobal "boring"+ liftM catMaybes $ mapM tryMakeBoringRegexp $ localBores ++ globalBores boringFileFilter :: IO ([FilePath] -> [FilePath])-boringFileFilter = fmap actualBoringFileFilter boringRegexps+boringFileFilter = filterBoringAndDarcsdir `fmap` boringRegexps+ where+ filterBoringAndDarcsdir regexps = filter (notBoring regexps . doNormalise)+ notBoring regexps file = not $+ isDarcsdir file || any (\r -> isJust $ matchRegex r file) regexps noncomments :: [String] -> [String]-noncomments ss = filter is_ok ss- where is_ok "" = False- is_ok ('#':_) = False- is_ok _ = True+noncomments = filter nonComment+ where+ nonComment "" = False+ nonComment ('#' : _) = False+ nonComment _ = True getPrefLines :: FilePath -> IO [String]-getPrefLines f = (notconflicts . noncomments . map stripCr . lines)- `fmap` readBinFile f- where notconflicts = filter nc- startswith [] _ = True- startswith (x:xs) (y:ys) | x == y = startswith xs ys- startswith _ _ = False- nc l | startswith "v v v v v v v" l = False- nc l | startswith "*************" l = False- nc l | startswith "^ ^ ^ ^ ^ ^ ^" l = False- nc _ = True---- | From a list of paths, filter out any that are within @_darcs@ or--- match a boring regexp.-actualBoringFileFilter :: [Regex] -> [FilePath] -> [FilePath]-actualBoringFileFilter regexps files = filter (not . boring . normalize) files- where boring file = isDarcsdir file ||- any (\regexp -> isJust $ matchRegex regexp file) regexps+getPrefLines f = removeCRsCommentsAndConflicts `fmap` readBinFile f+ where+ removeCRsCommentsAndConflicts =+ filter notconflict . noncomments . map stripCr . lines+ startswith [] _ = True+ startswith (x : xs) (y : ys) = x == y && startswith xs ys+ startswith _ _ = False+ notconflict l+ | startswith "v v v v v v v" l = False+ | startswith "*************" l = False+ | startswith "^ ^ ^ ^ ^ ^ ^" l = False+ | otherwise = True+ stripCr "" = ""+ stripCr "\r" = ""+ stripCr (c : cs) = c : stripCr cs -normalize :: FilePath -> FilePath-normalize ('.':'/':f) = normalize f-normalize f = normalize_helper $ reverse f- where- normalize_helper ('/':rf) = normalize_helper rf- normalize_helper rf = reverse rf+doNormalise :: FilePath -> FilePath+doNormalise = dropTrailingPathSeparator . normalise -data FileType = BinaryFile | TextFile- deriving (Eq)+data FileType = BinaryFile+ | TextFile+ deriving (Eq) {-# NOINLINE defaultBinaries #-} -- | The lines that will be inserted into @_darcs/prefs/binaries@ when@@ -278,159 +331,221 @@ -- Note that while this matches .gz and .GZ, it will not match .gZ, -- i.e. it is not truly case insensitive. defaultBinaries :: [String]-defaultBinaries = help ++- ["\\.(" ++ e ++ "|" ++ map toUpper e ++ ")$" | e <- extensions ]- where extensions = ["a","bmp","bz2","doc","elc","exe","gif","gz","iso",- "jar","jpe?g","mng","mpe?g","p[nbgp]m","pdf","png",- "pyc","so","tar","tgz","tiff?","z","zip"]- help = map ("# "++) binariesFileHelp+defaultBinaries = map ("# "++) binariesFileHelp +++ [ "\\." ++ regexToMatchOrigOrUpper e ++ "$" | e <- extensions ]+ where+ regexToMatchOrigOrUpper e = "(" ++ e ++ "|" ++ map toUpper e ++ ")"+ extensions =+ [ "a"+ , "bmp"+ , "bz2"+ , "doc"+ , "elc"+ , "exe"+ , "gif"+ , "gz"+ , "iso"+ , "jar"+ , "jpe?g"+ , "mng"+ , "mpe?g"+ , "p[nbgp]m"+ , "pdf"+ , "png"+ , "pyc"+ , "so"+ , "tar"+ , "tgz"+ , "tiff?"+ , "z"+ , "zip"+ ] binariesFileHelp :: [String] binariesFileHelp =- ["This file contains a list of extended regular expressions, one per",- "line. A file path matching any of these expressions is assumed to",- "contain binary data (not text). The entries in " ++ globalPrefsDirDoc ++ "binaries (if",- "it exists) supplement those in this file.",- "",- "Blank lines, and lines beginning with an octothorpe (#) are ignored.",- "See regex(7) for a description of extended regular expressions."]+ [ "This file contains a list of extended regular expressions, one per"+ , "line. A file path matching any of these expressions is assumed to"+ , "contain binary data (not text). The entries in "+ ++ globalPrefsDirDoc ++ "binaries (if"+ , "it exists) supplement those in this file."+ , ""+ , "Blank lines, and lines beginning with an octothorpe (#) are ignored."+ , "See regex(7) for a description of extended regular expressions."+ ] filetypeFunction :: IO (FilePath -> FileType) filetypeFunction = do binsfile <- defPrefval "binariesfile" (darcsdir ++ "/prefs/binaries")- bins <- getPrefLines binsfile `catch`- (\e-> if isDoesNotExistError e then return [] else ioError e)+ bins <- getPrefLines binsfile+ `catch`+ (\e -> if isDoesNotExistError e then return [] else ioError e) gbs <- getGlobal "binaries"- let regexes = map mkRegex (bins ++ gbs)- let isbin f = any (\r -> isJust $ matchRegex r f) regexes- ftf f = if isbin $ normalize f then BinaryFile else TextFile- in- return ftf+ let binaryRegexes = map mkRegex (bins ++ gbs)+ isBinary f = any (\r -> isJust $ matchRegex r f) binaryRegexes+ ftf f = if isBinary $ doNormalise f then BinaryFile else TextFile+ return ftf --- this avoids a circular dependency with Repository-prefsDirectory :: IO (Maybe String)-prefsDirectory =- do darcs <- doesDirectoryExist darcsdir- return $ if darcs- then Just $ darcsdir ++ "/prefs/"- else Nothing+findPrefsDirectory :: IO (Maybe String)+findPrefsDirectory = do+ inDarcsRepo <- doesDirectoryExist darcsdir+ return $ if inDarcsRepo+ then Just $ darcsdir ++ "/prefs/"+ else Nothing withPrefsDirectory :: (String -> IO ()) -> IO ()-withPrefsDirectory j = prefsDirectory >>= maybe (return ()) j+withPrefsDirectory job = findPrefsDirectory >>= maybe (return ()) job addToPreflist :: String -> String -> IO ()-addToPreflist p s = withPrefsDirectory $ \prefs -> do- hasprefs <- doesDirectoryExist prefs- unless hasprefs $ createDirectory prefs- pl <- getPreflist p- writeBinFile (prefs ++ p) $ unlines $ union [s] pl+addToPreflist pref value = withPrefsDirectory $ \prefs -> do+ hasprefs <- doesDirectoryExist prefs+ unless hasprefs $ createDirectory prefs+ pl <- getPreflist pref+ writeBinFile (prefs ++ pref) . unlines $ union [value] pl getPreflist :: String -> IO [String]-getPreflist p = prefsDirectory >>= maybe (return []) (\prefs -> getPreffile $ prefs ++ p)+getPreflist p = findPrefsDirectory >>=+ maybe (return []) (\prefs -> getPreffile $ prefs ++ p) getPreffile :: FilePath -> IO [String] getPreffile f = do- hasprefs <- doesFileExist f- if hasprefs- then getPrefLines f- else return []+ hasprefs <- doesFileExist f+ if hasprefs then getPrefLines f else return [] setPreflist :: String -> [String] -> IO () setPreflist p ls = withPrefsDirectory $ \prefs -> do- haspref <- doesDirectoryExist prefs- when haspref $ writeBinFile (prefs ++ p) (unlines ls)+ haspref <- doesDirectoryExist prefs+ when haspref $+ writeBinFile (prefs ++ p) (unlines ls) defPrefval :: String -> String -> IO String defPrefval p d = fromMaybe d `fmap` getPrefval p getPrefval :: String -> IO (Maybe String)-getPrefval p =- do pl <- getPreflist "prefs"- return $- case map snd $ filter ((==p).fst) $ map (break (==' ')) pl of- [val] ->- case words val of+getPrefval p = do+ pl <- getPreflist "prefs"+ return $ case map snd $ filter ((== p) . fst) $ map (break (== ' ')) pl of+ [val] -> case words val of [] -> Nothing _ -> Just $ tail val- _ -> Nothing+ _ -> Nothing setPrefval :: String -> String -> IO ()-setPrefval p v = do pl <- getPreflist "prefs"- setPreflist "prefs" $- filter ((/=p) . fst . break (==' ')) pl ++ [p++" "++v]+setPrefval p v = do+ pl <- getPreflist "prefs"+ setPreflist "prefs" $ updatePrefVal pl p v +updatePrefVal :: [String] -> String -> String -> [String]+updatePrefVal prefList p newVal =+ filter ((/= p) . fst . break (== ' ')) prefList ++ [p ++ " " ++ newVal]+ changePrefval :: String -> String -> String -> IO ()-changePrefval p f t =- do pl <- getPreflist "prefs"- ov <- getPrefval p- let newval = case ov of- Nothing -> t- Just old -> if old == f then t else old- setPreflist "prefs" $- filter ((/=p) . fst . break(==' ')) pl ++ [p++" "++newval]+changePrefval p f t = do+ pl <- getPreflist "prefs"+ ov <- getPrefval p+ let newval = maybe t (\old -> if old == f then t else old) ov+ setPreflist "prefs" $ updatePrefVal pl p newval -defaultrepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]-defaultrepo opts _ [] =- do let fixR r | isFile r = toFilePath `fmap` ioAbsolute r- | otherwise = return r- case [r | RemoteRepo r <- opts] of- [] -> do defrepo <- getPreflist "defaultrepo"- case defrepo of- [r] -> (:[]) `fmap` fixR r- _ -> return []- rs -> mapM fixR rs+fixRepoPath :: String -> IO FilePath+fixRepoPath p+ | isValidLocalPath p = toFilePath `fmap` ioAbsolute p+ | otherwise = return p++defaultrepo :: RemoteRepos -> AbsolutePath -> [String] -> IO [String]+defaultrepo (RemoteRepos rrepos) _ [] =+ do case rrepos of+ [] -> maybeToList `fmap` getDefaultRepoPath+ rs -> mapM fixRepoPath rs defaultrepo _ _ r = return r -setDefaultrepo :: String -> [DarcsFlag] -> IO ()-setDefaultrepo r opts = do olddef <- getPreflist "defaultrepo"- let doit = null noSetDefault && greenLight- greenLight = wetRun- && not rIsTmp- && (olddef /= [r] || olddef == [])- if doit- then setPreflist "defaultrepo" [r]- else when (True `notElem` noSetDefault && greenLight) $ putStr . unlines $- -- the nuance here is that we should only notify when the- -- reason we're not setting default is the --no-set-default- -- flag, not the various automatic show stoppers- [ "HINT: if you want to change the default remote repository to"- , " " ++ r ++ ","- , " quit now and issue the same command with the --set-default flag."- ]- addToPreflist "repos" r- `catchall` return () -- we don't care if this fails!- where- wetRun = DryRun `notElem` opts- rIsTmp = r `elem` [x | RemoteRepo x <- opts]- noSetDefault = [x | NoSetDefault x <- opts]+getDefaultRepoPath :: IO (Maybe String)+getDefaultRepoPath = do+ defaults <- getPreflist defaultRepoPref+ case defaults of+ [] -> return Nothing+ (d : _) -> Just `fmap` fixRepoPath d -getCaches :: [DarcsFlag] -> String -> IO Cache-getCaches opts repodir =- do here <- parsehs `fmap` getPreffile (darcsdir ++ "/prefs/sources")- there <- (parsehs . lines . BC.unpack) `fmap`- (gzFetchFilePS (repodir </> darcsdir </> "prefs/sources") Cachable- `catchall` return B.empty)- globalcachedir <- globalCacheDir- let globalcache = case (nocache,globalcachedir) of- (True,_) -> []- (_,Just d) -> [Cache Directory Writable d]- _ -> []- globalsources <- parsehs `fmap` getGlobal "sources"- thisdir <- getCurrentDirectory- let thisrepo = [Cache Repo Writable $ toFilePath thisdir]- let tempCache = nub $ thisrepo ++ globalcache ++ globalsources ++- here ++ [Cache Repo NotWritable repodir] ++ filterExternalSources there- return $ Ca $ sortBy compareByLocality tempCache- where- parsehs = mapMaybe readln . noncomments- readln l | "repo:" `isPrefixOf` l = Just (Cache Repo NotWritable (drop 5 l))- | nocache = Nothing- | "cache:" `isPrefixOf` l = Just (Cache Directory Writable (drop 6 l))- | "readonly:" `isPrefixOf` l = Just (Cache Directory NotWritable (drop 9 l))- | otherwise = Nothing- nocache = NoCache `elem` opts- filterExternalSources there = if isFile repodir- then- there- else- filter (not . isFile . cacheSource) there+defaultRepoPref :: String+defaultRepoPref = "defaultrepo"++-- | addRepoSource adds a new entry to _darcs/prefs/repos and sets it as default+-- in _darcs/prefs/defaultrepo, unless --no-set-default or --dry-run is passed,+-- or it is the same repository as the current one.+addRepoSource :: String -> DryRun -> RemoteRepos -> SetDefault -> IO ()+addRepoSource r isDryRun (RemoteRepos rrepos) setDefault = (do+ olddef <- getPreflist defaultRepoPref+ let shouldDoIt = null noSetDefault && greenLight+ greenLight = shouldAct && not rIsTmp && (olddef /= [r] || olddef == [])+ -- the nuance here is that we should only notify when the reason we're not+ -- setting default is the --no-set-default flag, not the various automatic+ -- show stoppers+ if shouldDoIt+ then setPreflist defaultRepoPref [r]+ else when (True `notElem` noSetDefault && greenLight) $+ putStr . unlines $ setDefaultMsg+ addToPreflist "repos" r) `catchall` return ()+ where+ shouldAct = isDryRun == NoDryRun+ rIsTmp = r `elem` rrepos+ noSetDefault = case setDefault of+ NoSetDefault x -> [x]+ _ -> []+ setDefaultMsg =+ [ "HINT: if you want to change the default remote repository to"+ , " " ++ r ++ ","+ , " quit now and issue the same command with the --set-default "+ ++ "flag."+ ]++-- | delete references to other repositories.+-- Used when cloning to a ssh destination.+-- Assume the current working dir is the repository.+deleteSources :: IO ()+deleteSources = do let prefsdir = darcsdir ++ "/prefs/"+ removeFileMayNotExist (prefsdir ++ "sources")+ removeFileMayNotExist (prefsdir ++ "repos")++getCaches :: UseCache -> String -> IO Cache+getCaches useCache repodir = do+ here <- parsehs `fmap` getPreffile sourcesFile+ there <- (parsehs . lines . BC.unpack)+ `fmap`+ (gzFetchFilePS (repodir </> sourcesFile) Cachable+ `catchall` return B.empty)+ oldGlobalcachedir <- oldGlobalCacheDir+ globalcachedir <- globalCacheDir+ let oldGlobalcache = if nocache then []+ else case oldGlobalcachedir of+ Nothing -> []+ Just d -> [Cache Directory NotWritable d]+ let globalcache = if nocache+ then []+ else case globalcachedir of+ Nothing -> []+ Just d -> [Cache Directory Writable d]+ globalsources <- parsehs `fmap` getGlobal "sources"+ thisdir <- getCurrentDirectory+ let thisrepo = [Cache Repo Writable $ toFilePath thisdir]+ thatrepo = [Cache Repo NotWritable repodir]+ tempCache = nub $ thisrepo ++ globalcache ++ globalsources ++ here+ ++ thatrepo ++ filterExternalSources there+ ++ oldGlobalcache+ return $ Ca $ sortBy compareByLocality tempCache+ where+ sourcesFile = darcsdir ++ "/prefs/sources"++ parsehs = mapMaybe readln . noncomments++ readln l+ | "repo:" `isPrefixOf` l = Just (Cache Repo NotWritable (drop 5 l))+ | nocache = Nothing+ | "cache:" `isPrefixOf` l = Just (Cache Directory Writable (drop 6 l))+ | "readonly:" `isPrefixOf` l =+ Just (Cache Directory NotWritable (drop 9 l))+ | otherwise = Nothing++ nocache = useCache == NoUseCache++ filterExternalSources there =+ if isValidLocalPath repodir+ then there+ else filter (not . isValidLocalPath . cacheSource) there
+ src/Darcs/Repository/Read.hs view
@@ -0,0 +1,25 @@+module Darcs.Repository.Read ( readRepo ) where++import Darcs.Patch (RepoPatch)+import Darcs.Patch.Apply ( ApplyState )+import Storage.Hashed.Tree ( Tree )+import Darcs.Repository.InternalTypes ( Repository(Repo) )+import Darcs.Patch.Set ( PatchSet, Origin )+import Darcs.Repository.Format ( formatHas, RepoProperty(HashedInventory) )+import qualified Darcs.Repository.HashedRepo as HashedRepo ( readRepo )+import qualified Darcs.Repository.Old as Old ( readOldRepo )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )++ +-- @todo: we should not have to open the result of HashedRepo and+-- seal it. Instead, update this function to work with type witnesses+-- by fixing DarcsRepo to match HashedRepo in the handling of+-- Repository state.+readRepo :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> IO (PatchSet p Origin wR)+readRepo repo@(Repo r rf _ _)+ | formatHas HashedInventory rf = HashedRepo.readRepo repo r+ | otherwise = do Sealed ps <- Old.readOldRepo r+ return $ unsafeCoerceP ps
+ src/Darcs/Repository/Rebase.hs view
@@ -0,0 +1,223 @@+-- Copyright (C) 2009-2012 Ganesh Sittampalam+--+-- BSD3+{-# LANGUAGE CPP #-}+module Darcs.Repository.Rebase+ (+ withManualRebaseUpdate+ , rebaseJob+ , startRebaseJob+ , repoJobOnRebaseRepo+ ) where++import Darcs.Util.Global ( darcsdir )++import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.CommuteFn ( commuterIdRL )+import Darcs.Patch.Commute ( selfCommuter )+import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully )+import Darcs.Patch.Rebase ( RebaseFixup+ , Rebasing+ , mkSuspended+ , takeHeadRebase+ , takeAnyRebase+ , takeAnyRebaseAndTrailingPatches+ , countToEdit+ )+import Darcs.Patch.Rebase.Recontext ( RecontextRebase(..)+ , RecontextRebase1(..)+ , RecontextRebase2(..)+ )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Set ( PatchSet(..) )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), (:>)(..), RL(..), reverseRL+ )+import Darcs.Patch.Witnesses.Sealed+ ( Sealed2(..), FlippedSeal(..) )+++import Darcs.Repository.Flags+ ( Compression+ , UpdateWorking(..)+ , Verbosity+ )+import Darcs.Repository.Format+ ( RepoProperty ( RebaseInProgress )+ , formatHas+ , addToFormat+ , removeFromFormat+ , writeRepoFormat+ )+import Darcs.Repository.Internal+ ( tentativelyAddPatch+ , tentativelyAddPatch_+ , tentativelyAddPatches_+ , tentativelyRemovePatches+ , tentativelyRemovePatches_+ , finalizeRepositoryChanges+ , revertRepositoryChanges+ , readTentativeRepo+ , readRepo+ , UpdatePristine(..)+ )+import Darcs.Repository.InternalTypes ( Repository(..) )++import Darcs.Util.Progress ( debugMessage )++import Storage.Hashed.Tree ( Tree )++import Control.Applicative ( (<$>) )+import Control.Exception ( finally )++import System.FilePath.Posix ( (</>) )++#include "impossible.h"++withManualRebaseUpdate+ :: forall p x wR wU wT1 wT2+ . (RepoPatch p, ApplyState p ~ Tree)+ => Compression+ -> Verbosity+ -> UpdateWorking+ -> Repository p wR wU wT1+ -> (Repository p wR wU wT1 -> IO (Repository p wR wU wT2, FL (RebaseFixup p) wT2 wT1, x))+ -> IO (Repository p wR wU wT2, x)+withManualRebaseUpdate compr verb uw r subFunc+ | Just (RecontextRebase1 recontext1) <- recontextRebase :: Maybe (RecontextRebase1 p)+ = do patches <- readTentativeRepo r+ let go :: PatchSet p wS wT1 -> IO (Repository p wR wU wT2, x)+ go (PatchSet NilRL _) = bug "trying to recontext rebase without rebase patch at head (tag)"+ go (PatchSet (q :<: _) _) =+ case recontext1 (hopefully q) of+ (NotEq, _) -> bug "trying to recontext rebase without rebase patch at head (not match)"+ (IsEq, recontext2) -> do+ r' <- tentativelyRemovePatches r compr uw (q :>: NilFL)+ (r'', fixups, x) <- subFunc r'+ q' <- n2pia <$> recontextFunc2 recontext2 fixups+ r''' <- tentativelyAddPatch r'' compr verb uw q'+ return (r''', x)+ go patches+withManualRebaseUpdate _compr _verb _uw r subFunc+ = do (r', _, x) <- subFunc r+ return (r', x)+++-- got a normal darcs operation to run on a repo that happens to have a rebase in progress+repoJobOnRebaseRepo :: (RepoPatch p, ApplyState p ~ Tree)+ => (Repository (Rebasing p) wR wU wR -> IO a)+ -> Repository (Rebasing p) wR wU wR+ -> IO a+repoJobOnRebaseRepo job repo = do+ res <- job repo -- TODO can we munge the repo here to hide the rebase patch?+ displaySuspendedStatus repo+ return res++-- got a rebase operation to run where it is required that a rebase is already in progress+rebaseJob :: (RepoPatch p, ApplyState p ~ Tree)+ => (Repository (Rebasing p) wR wU wR -> IO a)+ -> Repository (Rebasing p) wR wU wR+ -> Compression+ -> Verbosity+ -> UpdateWorking+ -> IO a+rebaseJob job repo compr verb uw = do+ repo' <- moveRebaseToEnd repo compr verb uw+ job repo'+ -- the use of finally here is because various things in job+ -- might cause an "expected" early exit leaving us needing+ -- to remove the rebase-in-progress state (e.g. when suspending,+ -- conflicts with recorded, user didn't specify any patches).+ -- It's a bit questionable/non-standard as it's doing quite a bit+ -- of cleanup and if there was an unexpected error then this+ -- may may things worse.+ -- The better fix would be to standardise expected early exits+ -- e.g. using a layer on top of IO or a common Exception type+ -- and then just catch those.+ `finally` checkSuspendedStatus repo' compr verb uw++-- got a rebase operation to run where we may need to initialise the rebase state first+startRebaseJob :: (RepoPatch p, ApplyState p ~ Tree)+ => (Repository (Rebasing p) wR wU wR -> IO a)+ -> Repository (Rebasing p) wR wU wR+ -> Compression+ -> Verbosity+ -> UpdateWorking+ -> IO a+startRebaseJob job repo compr verb uw = do+ repo' <- startRebaseIfNecessary repo compr verb uw+ rebaseJob job repo' compr verb uw++checkSuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository (Rebasing p) wR wU wR+ -> Compression+ -> Verbosity+ -> UpdateWorking+ -> IO ()+checkSuspendedStatus repo@(Repo _ rf _ _) compr verb uw = do+ allpatches <- readRepo repo+ (_, Sealed2 ps) <- return $ takeAnyRebase allpatches+ case countToEdit ps of+ 0 -> do+ debugMessage "Removing the rebase patch file..."+ -- this shouldn't actually be necessary since the count should+ -- only go to zero after an actual rebase operation which would+ -- leave the patch at the end anyway, but be defensive.+ repo' <- moveRebaseToEnd repo compr verb uw+ revertRepositoryChanges repo' uw+ -- in theory moveRebaseToEnd could just return the commuted one,+ -- but since the repository has been committed and re-opened+ -- best to just do things carefully+ (rebase, _, _) <- takeHeadRebase <$> readRepo repo'+ repo'' <- tentativelyRemovePatches repo' compr uw (rebase :>: NilFL)+ finalizeRepositoryChanges repo'' uw compr+ writeRepoFormat (removeFromFormat RebaseInProgress rf) (darcsdir </> "format")+ putStrLn "Rebase finished!"+ n -> putStrLn $ "Rebase in progress: " ++ show n ++ " suspended patches"++moveRebaseToEnd :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository (Rebasing p) wR wU wR+ -> Compression+ -> Verbosity+ -> UpdateWorking+ -> IO (Repository (Rebasing p) wR wU wR)+moveRebaseToEnd repo compr verb uw = do+ allpatches <- readRepo repo+ case takeAnyRebaseAndTrailingPatches allpatches of+ FlippedSeal (_ :> NilRL) -> return repo -- already at head+ FlippedSeal (r :> ps) -> do+ Just (ps' :> r') <- return $ commuterIdRL selfCommuter (r :> ps)+ debugMessage "Moving rebase patch to head..."+ revertRepositoryChanges repo uw+ repo' <- tentativelyRemovePatches_ DontUpdatePristine repo compr uw (reverseRL ps)+ repo'' <- tentativelyRemovePatches_ DontUpdatePristine repo' compr uw (r :>: NilFL)+ repo''' <- tentativelyAddPatches_ DontUpdatePristine repo'' compr verb uw (reverseRL ps')+ repo'''' <- tentativelyAddPatch_ DontUpdatePristine repo''' compr verb uw r'+ finalizeRepositoryChanges repo'''' uw compr+ return repo''''++displaySuspendedStatus :: (RepoPatch p, ApplyState p ~ Tree) => Repository (Rebasing p) wR wU wR -> IO ()+displaySuspendedStatus repo = do+ allpatches <- readRepo repo+ (_, Sealed2 ps) <- return $ takeAnyRebase allpatches+ putStrLn $ "Rebase in progress: " ++ show (countToEdit ps) ++ " suspended patches"++startRebaseIfNecessary :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository (Rebasing p) wR wU wT+ -> Compression+ -> Verbosity+ -> UpdateWorking+ -> IO (Repository (Rebasing p) wR wU wT)+startRebaseIfNecessary repo@(Repo _ rf _ _) compr verb uw =+ if formatHas RebaseInProgress rf+ then return repo+ else do -- TODO this isn't under the repo lock, and it should be+ writeRepoFormat (addToFormat RebaseInProgress rf) (darcsdir </> "format")+ debugMessage "Writing the rebase patch file..."+ revertRepositoryChanges repo uw+ mypatch <- mkSuspended NilFL+ repo' <- tentativelyAddPatch_ UpdatePristine repo compr verb uw $ n2pia mypatch+ finalizeRepositoryChanges repo' uw compr+ return repo'+
src/Darcs/Repository/Repair.hs view
@@ -15,72 +15,72 @@ import Data.List ( sort, (\\) ) import System.Directory ( createDirectoryIfMissing, getCurrentDirectory, setCurrentDirectory )-import Darcs.Lock( rmRecursive )-import Darcs.RepoPath( AbsolutePath, ioAbsolute, toFilePath )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, winfo, WPatchInfo, unWPatchInfo, compareWPatchInfo )+import System.FilePath ( (</>) )+import Darcs.Util.Path( anchorPath, AbsolutePath, ioAbsolute, toFilePath )+import Darcs.Patch.PatchInfoAnd ( hopefully, PatchInfoAnd, info, winfo, WPatchInfo, unWPatchInfo, compareWPatchInfo ) -import Darcs.Witnesses.Eq ( EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthFL, reverseFL,- mapRL, nullFL, (:||:)(..) )-import Darcs.Witnesses.Sealed ( Sealed2(..), Sealed(..), unFreeLeft )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), RL(..), lengthFL, reverseFL,+ mapRL, nullFL, (:||:)(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), unFreeLeft ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Repair ( Repair(applyAndTryToFix) )-import Darcs.Patch.PatchInfoAnd( hopefully )-import Darcs.Patch.Info ( humanFriendly )-import Darcs.Patch.Set ( PatchSet(..), newset2FL, newset2RL )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif+import Darcs.Patch.Info ( showPatchInfoUI )+import Darcs.Patch.Set ( Origin, PatchSet(..), newset2FL, newset2RL ) import Darcs.Patch ( RepoPatch, PrimOf, isInconsistent ) import Darcs.Patch.Named ( patchcontents ) +import Darcs.Repository.Flags+ ( Verbosity(..), Compression, DiffAlgorithm ) import Darcs.Repository.Format ( identifyRepoFormat, RepoProperty ( HashedInventory ), formatHas ) import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) ) import Darcs.Repository.HashedIO ( cleanHashdir )-import Darcs.Repository.HashedRepo ( readHashedPristineRoot )-import Darcs.Repository.InternalTypes ( extractCache )+import Darcs.Repository.HashedRepo ( readHashedPristineRoot, writeAndReadPatch )+import Darcs.Repository.InternalTypes ( Repository(..), extractCache ) import Darcs.Repository.Prefs ( filetypeFunction )-import Darcs.Repository ( Repository, readRepo, makePatchLazy- , readRecorded, readIndex, readRecordedAndPending )+import Darcs.Repository.Internal ( readRepo )+import Darcs.Repository.State+ ( readRecorded+ , readIndex+ , readRecordedAndPending+ )+import Darcs.Repository.Diff( treeDiff ) -import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )-import Darcs.Utils ( catchall )-import Darcs.Global ( darcsdir )-import Darcs.Lock( withTempDir )-import Printer ( Doc, putDocLn, text )-import Darcs.Arguments ( DarcsFlag( Verbose, Quiet ) )+import Darcs.Util.Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )+import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Exception ( catchall )+import Darcs.Util.Global ( darcsdir )+import Darcs.Repository.Lock( rmRecursive, withTempDir )+import Darcs.Util.Printer ( Doc, putDocLn, text, RenderMode(..) )+import Darcs.Util.Printer.Color ( showDoc ) -import Darcs.Diff( treeDiff ) import Storage.Hashed.Monad( TreeIO )-import Storage.Hashed.Darcs( hashedTreeIO )-import Storage.Hashed.Tree( Tree, emptyTree )-import Storage.Hashed.AnchoredPath( anchorPath )+import Storage.Hashed.Darcs( darcsUpdateHashes, hashedTreeIO ) import Storage.Hashed.Hash( Hash(NoHash), encodeBase16 )-import Storage.Hashed.Tree( list, restrict, expand, itemHash, zipTrees )-import Storage.Hashed.Darcs( darcsUpdateHashes )+import Storage.Hashed.Tree( Tree, emptyTree, list, restrict, expand, itemHash, zipTrees ) import Storage.Hashed.Index( updateIndex ) import Storage.Hashed( readPlainTree ) import qualified Data.ByteString.Char8 as BS #include "impossible.h"-#include "gadts.h" -replaceInFL :: FL (PatchInfoAnd a) C(x y)+replaceInFL :: FL (PatchInfoAnd a) wX wY -> [Sealed2 (WPatchInfo :||: PatchInfoAnd a)]- -> FL (PatchInfoAnd a) C(x y)+ -> FL (PatchInfoAnd a) wX wY replaceInFL orig [] = orig replaceInFL NilFL _ = impossible replaceInFL (o:>:orig) ch@(Sealed2 (o':||:c):ch_rest) | IsEq <- winfo o `compareWPatchInfo` o' = c:>:replaceInFL orig ch_rest | otherwise = o:>:replaceInFL orig ch -applyAndFix :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> FL (PatchInfoAnd p) C(Origin r)- -> TreeIO (FL (PatchInfoAnd p) C(Origin r), Bool)-applyAndFix _ NilFL = return (NilFL, True)-applyAndFix r psin =+applyAndFix :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> Compression -> FL (PatchInfoAnd p) Origin wR+ -> TreeIO (FL (PatchInfoAnd p) Origin wR, Bool)+applyAndFix _ _ NilFL = return (NilFL, True)+applyAndFix r@(Repo r' _ _ c) compr psin = do liftIO $ beginTedious k liftIO $ tediousSize k $ lengthFL psin (repaired, ok) <- aaf psin@@ -88,7 +88,7 @@ orig <- liftIO $ newset2FL `fmap` readRepo r return (replaceInFL orig repaired, ok) where k = "Replaying patch"- aaf :: FL (PatchInfoAnd p) C(w z) -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd p)], Bool)+ aaf :: FL (PatchInfoAnd p) wW wZ -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd p)], Bool) aaf NilFL = return ([], True) aaf (p:>:ps) = do mp' <- applyAndTryToFix p@@ -96,28 +96,28 @@ Just err -> liftIO $ putDocLn err Nothing -> return () let !winfp = winfo p -- assure that 'p' can be garbage collected.- liftIO $ finishedOneIO k $ show $ humanFriendly $ unWPatchInfo winfp+ liftIO $ finishedOneIO k $ showDoc Encode $ showPatchInfoUI $ unWPatchInfo winfp (ps', restok) <- aaf ps case mp' of Nothing -> return (ps', restok) Just (e,pp) -> liftIO $ do putStrLn e- p' <- makePatchLazy r pp+ p' <- withCurrentDirectory r' $ writeAndReadPatch c compr pp return (Sealed2 (winfp :||: p'):ps', False) -data RepositoryConsistency p C(x) =+data RepositoryConsistency p wX = RepositoryConsistent | BrokenPristine (Tree IO)- | BrokenPatches (Tree IO) (PatchSet p C(Origin x))+ | BrokenPatches (Tree IO) (PatchSet p Origin wX) checkUniqueness :: (RepoPatch p, ApplyState p ~ Tree)- => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p C(r u t) -> IO ()+ => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p wR wU wT -> IO () checkUniqueness putVerbose putInfo repository = do putVerbose $ text "Checking that patch names are unique..." r <- readRepo repository case hasDuplicate $ mapRL info $ newset2RL r of Nothing -> return () Just pinf -> do putInfo $ text "Error! Duplicate patch name:"- putInfo $ humanFriendly pinf+ putInfo $ showPatchInfoUI pinf fail "Duplicate patches found." hasDuplicate :: Ord a => [a] -> Maybe a@@ -127,12 +127,12 @@ hd (x1:x2:xs) | x1 == x2 = Just x1 | otherwise = hd (x2:xs) replayRepository' ::- forall p C(r u t) . (RepoPatch p, ApplyState p ~ Tree)- => AbsolutePath -> Repository p C(r u t) -> [DarcsFlag] -> IO (RepositoryConsistency p C(r))-replayRepository' whereToReplay' repo opts = do+ forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree)+ => DiffAlgorithm -> AbsolutePath -> Repository p wR wU wT -> Compression -> Verbosity -> IO (RepositoryConsistency p wR)+replayRepository' dflag whereToReplay' repo compr verbosity = do let whereToReplay = toFilePath whereToReplay'- putVerbose s = when (Verbose `elem` opts) $ putDocLn s- putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s+ putVerbose s = when (verbosity == Verbose) $ putDocLn s+ putInfo s = unless (verbosity == Quiet) $ putDocLn s checkUniqueness putVerbose putInfo repo createDirectoryIfMissing False whereToReplay putVerbose $ text "Reading recorded state..."@@ -141,7 +141,7 @@ patches <- readRepo repo debugMessage "Fixing any broken patches..." let psin = newset2FL patches- repair = applyAndFix repo psin+ repair = applyAndFix repo compr psin ((ps, patches_ok), newpris) <- hashedTreeIO repair emptyTree whereToReplay debugMessage "Done fixing broken patches..."@@ -149,7 +149,7 @@ debugMessage "Checking pristine against slurpy" ftf <- filetypeFunction- is_same <- do Sealed diff <- unFreeLeft `fmap` treeDiff ftf pris newpris :: IO (Sealed (FL (PrimOf p) C(r)))+ is_same <- do Sealed diff <- unFreeLeft `fmap` treeDiff dflag ftf pris newpris :: IO (Sealed (FL (PrimOf p) wR)) return $ nullFL diff `catchall` return False -- TODO is the latter condition needed? Does a broken patch imply pristine@@ -160,7 +160,7 @@ then BrokenPristine newpris else BrokenPatches newpris newpatches) -cleanupRepositoryReplay :: Repository p C(r u t) -> IO ()+cleanupRepositoryReplay :: Repository p wR wU wT -> IO () cleanupRepositoryReplay r = do let c = extractCache r rf <- identifyRepoFormat "."@@ -170,26 +170,27 @@ current <- readHashedPristineRoot r cleanHashdir c HashedPristineDir $ catMaybes [current] -replayRepositoryInTemp :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> [DarcsFlag]- -> IO (RepositoryConsistency p C(r))-replayRepositoryInTemp r opt = do+replayRepositoryInTemp :: (RepoPatch p, ApplyState p ~ Tree)+ => DiffAlgorithm -> Repository p wR wU wT -> Compression -> Verbosity+ -> IO (RepositoryConsistency p wR)+replayRepositoryInTemp dflag r compr verb = do repodir <- getCurrentDirectory withTempDir "darcs-check" $ \tmpDir -> do setCurrentDirectory repodir- replayRepository' tmpDir r opt+ replayRepository' dflag tmpDir r compr verb replayRepository :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> [DarcsFlag]- -> (RepositoryConsistency p C(r) -> IO a) -> IO a-replayRepository r opt f = do+ => DiffAlgorithm -> Repository p wR wU wT -> Compression -> Verbosity+ -> (RepositoryConsistency p wR -> IO a) -> IO a+replayRepository dflag r compr verb f = run `finally` cleanupRepositoryReplay r where run = do- createDirectoryIfMissing False "_darcs/pristine.hashed"- hashedPristine <- ioAbsolute "_darcs/pristine.hashed"- st <- replayRepository' hashedPristine r opt+ createDirectoryIfMissing False $ darcsdir </> "pristine.hashed"+ hashedPristine <- ioAbsolute $ darcsdir </> "pristine.hashed"+ st <- replayRepository' dflag hashedPristine r compr verb f st -checkIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> Bool -> IO Bool+checkIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> Bool -> IO Bool checkIndex repo quiet = do index <- updateIndex =<< readIndex repo pristine <- expand =<< readRecordedAndPending repo@@ -205,7 +206,7 @@ gethashes p Nothing Nothing = error $ "Bad case at " ++ show p mismatches = [ miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2 ] - format paths = unlines $ (map $ ((" " ++) . anchorPath "")) paths+ format paths = unlines $ map ((" " ++) . anchorPath "") paths mismatches_disp = unlines [ anchorPath "" p ++ "\n index: " ++ BS.unpack (encodeBase16 h1) ++ "\n working: " ++ BS.unpack (encodeBase16 h2)
+ src/Darcs/Repository/Resolution.hs view
@@ -0,0 +1,165 @@+-- Copyright (C) 2003,2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+++module Darcs.Repository.Resolution+ ( standardResolution+ , externalResolution+ , patchsetConflictResolutions+ ) where++import System.FilePath.Posix ( (</>) )+import System.Exit ( ExitCode( ExitSuccess ) )+import System.Directory ( setCurrentDirectory, getCurrentDirectory )+import Data.List ( zip4 )+import Control.Monad ( when )++import Darcs.Repository.Diff( treeDiff )+import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch, resolveConflicts,+ effectOnFilePaths, patchcontents,+ invert, listConflictedFiles, commute, applyToTree, fromPrim )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )+import Darcs.Patch.Prim ( PrimPatchBase )+import Darcs.Util.Path ( toFilePath, filterFilePaths )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), RL(..), (:>)(..), (+>+),+ mapFL_FL, concatFL, reverseRL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft )++import Darcs.Util.CommandLine ( parseCmd )+import Darcs.Patch.PatchInfoAnd ( hopefully )+import Darcs.Util.Prompt ( askEnter )+import Darcs.Patch.Set ( PatchSet(..), Origin )+import Darcs.Repository.Prefs ( filetypeFunction )+import Darcs.Util.Exec ( exec, Redirect(..) )+import Darcs.Repository.Lock ( withTempDir )+import Darcs.Repository.External ( cloneTree )+import Darcs.Repository.Flags ( WantGuiPause(..), DiffAlgorithm(..) )++import qualified Storage.Hashed.Tree as Tree+import Storage.Hashed ( writePlainTree, readPlainTree )++--import Darcs.Util.Printer.Color ( traceDoc )+--import Darcs.Util.Printer ( greenText, ($$), Doc )+--import Darcs.Patch ( showPatch )++standardResolution :: (PrimPatchBase p, Conflict p, CommuteNoConflicts p)+ => FL p wX wY -> Sealed (FL (PrimOf p) wY)+standardResolution p = mergeList $ map head $ resolveConflicts p++mergeList :: forall prim wX . PrimPatch prim => [Sealed (FL prim wX)] -> Sealed (FL prim wX)+mergeList = doml NilFL+ where doml :: FL prim wX wY -> [Sealed (FL prim wX)] -> Sealed (FL prim wX)+ doml mp (Sealed p:ps) =+ case commute (invert p :> mp) of+ Just (mp' :> _) -> doml (p +>+ mp') ps+ Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions.+ doml mp [] = Sealed mp++externalResolution :: forall p wX wY wZ wA. (RepoPatch p, ApplyState p ~ Tree.Tree)+ => DiffAlgorithm+ -> Tree.Tree IO+ -> String -- ^ external merge tool command+ -> WantGuiPause -- ^ tell whether we want GUI pause+ -> FL (PrimOf p) wX wY+ -> FL (PrimOf p) wX wZ+ -> FL p wY wA+ -> IO (Sealed (FL (PrimOf p) wA))+externalResolution diffa s1 c wantGuiPause p1_prim p2_prim pmerged = do+ -- TODO: remove the following two once we can rely on GHC 7.2 / superclass equality+ let p1 :: FL p wX wY = mapFL_FL fromPrim p1_prim+ p2 :: FL p wX wZ = mapFL_FL fromPrim p2_prim+ sa <- applyToTree (invert p1) s1+ sm <- applyToTree pmerged s1+ s2 <- applyToTree p2 sa+ let nms = listConflictedFiles pmerged+ nas = effectOnFilePaths (invert pmerged) nms+ n1s = effectOnFilePaths p1 nas+ n2s = effectOnFilePaths p2 nas+ ns = zip4 nas n1s n2s nms+ write_files tree fs = writePlainTree (Tree.filter (filterFilePaths fs) tree) "."+ in do+ former_dir <- getCurrentDirectory+ withTempDir "version1" $ \absd1 -> do+ let d1 = toFilePath absd1+ write_files s1 n1s+ setCurrentDirectory former_dir+ withTempDir "ancestor" $ \absda -> do+ let da = toFilePath absda+ write_files sa nas+ setCurrentDirectory former_dir+ withTempDir "merged" $ \absdm -> do+ let dm = toFilePath absdm+ write_files sm nms+ setCurrentDirectory former_dir+ withTempDir "cleanmerged" $ \absdc -> do+ let dc = toFilePath absdc+ cloneTree dm "."+ setCurrentDirectory former_dir+ withTempDir "version2" $ \absd2 -> do+ let d2 = toFilePath absd2+ write_files s2 n2s+ mapM_ (externallyResolveFile c wantGuiPause da d1 d2 dm) ns+ sc <- readPlainTree dc+ sfixed <- readPlainTree dm+ ftf <- filetypeFunction+ unFreeLeft `fmap` treeDiff diffa ftf sc sfixed++externallyResolveFile :: String -- ^ external merge tool command+ -> WantGuiPause -- ^ tell whether we want GUI pause+ -> String -- ^ path to merge base+ -> String -- ^ path to side 1 of the merge+ -> String -- ^ path to side 2 of the merge+ -> String -- ^ path where resolved content should go+ -> (FilePath, FilePath, FilePath, FilePath)+ -> IO ()+externallyResolveFile c wantGuiPause da d1 d2 dm (fa, f1, f2, fm) = do+ putStrLn $ "Merging file "++fm++" by hand."+ ec <- run c [('1', d1</>f1), ('2', d2</>f2), ('a', da</>fa), ('o', dm</>fm), ('%', "%")]+ when (ec /= ExitSuccess) $+ putStrLn $ "External merge command exited with " ++ show ec+ when (wantGuiPause == YesWantGuiPause) $+ askEnter "Hit return to move on, ^C to abort the whole operation..."++run :: String -> [(Char,String)] -> IO ExitCode+run c replacements =+ case parseCmd replacements c of+ Left err -> fail $ show err+ Right (c2,_) -> rr c2+ where rr (command:args) = do putStrLn $ "Running command '" +++ unwords (command:args) ++ "'"+ exec command args (Null,Null,Null)+ rr [] = return ExitSuccess++patchsetConflictResolutions :: RepoPatch p => PatchSet p Origin wX -> Sealed (FL (PrimOf p) wX)+patchsetConflictResolutions (PatchSet NilRL _) = Sealed NilFL+patchsetConflictResolutions (PatchSet xs _)+ = --traceDoc (greenText "looking at resolutions" $$+ -- (sh $ resolveConflicts $ joinPatches $+ -- mapFL_FL (patchcontents . hopefully) $ reverseRL xs )) $+ mergeList $ map head $ resolveConflicts $ concatFL $+ mapFL_FL (patchcontents . hopefully) $ reverseRL xs+ --where sh :: [[Sealed (FL Prim)]] -> Doc+ -- sh [] = greenText "no more conflicts"+ -- sh (x:ps) = greenText "one conflict" $$ sh1 x $$ sh ps+ -- sh1 :: [Sealed (FL Prim)] -> Doc+ -- sh1 [] = greenText "end of unravellings"+ -- sh1 (Sealed x:ps) = greenText "one unravelling:" $$ showPatch x $$+ -- sh1 ps
+ src/Darcs/Repository/Ssh.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE CPP #-}++-- |+-- Module : Darcs.Repository.Ssh+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++module Darcs.Repository.Ssh+ (+ copySSH+ , SSHCmd(..)+ , getSSH+ , environmentHelpSsh+ , environmentHelpScp+ , environmentHelpSshPort+ , remoteDarcs+ ) where+++import Prelude hiding ( lookup, catch )++import System.Environment ( getEnv )+import System.Exit ( ExitCode(..) )++import Control.Exception ( throwIO )+import Control.Monad ( unless, (>=>) )+import Control.Monad.IO.Class ( liftIO )++import qualified Data.ByteString as B (ByteString, hGet, writeFile )++import Data.Map ( Map, empty, insert, lookup )+import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )++import System.IO ( Handle, hSetBinaryMode, hPutStrLn, hGetLine, hFlush )+import System.IO.Unsafe ( unsafePerformIO )+import System.Process ( runInteractiveProcess )++import Darcs.Util.SignalHandler ( catchNonSignal )+import Darcs.Repository.Flags( RemoteDarcs(..) )+import Darcs.Util.Ssh ( defaultSsh, SshSettings)+import Darcs.Util.URL (SshFilePath(..), urlOf)+import Darcs.Util.Text ( breakCommand )+import Darcs.Util.Exception ( prettyException, catchall )+import Darcs.Util.Exec ( readInteractiveProcess, ExecException(..), Redirect(AsIs) )+import Darcs.Util.Progress ( withoutProgress, debugMessage, debugFail )++import qualified Darcs.Util.Ssh as Settings+import qualified Darcs.Util.Ratified as Ratified ( hGetContents )++sshConnections :: IORef (Map String (Maybe Connection))+sshConnections = unsafePerformIO $ newIORef empty+{-# NOINLINE sshConnections #-}+++data Connection = C+ { inp :: !Handle+ , out :: !Handle+ , err :: !Handle+ , deb :: String+ }+++-- | @withSSHConnection rdarcs repoid withconnection withoutconnection@+-- performs an action on a remote host. If we are already connected to @repoid @,+-- then it does @withconnection@, else @withoutconnection@.+withSSHConnection :: String -- ^ rdarcs+ -> SshFilePath -- ^ Destination repo id+ -> (Connection -> IO a) -- ^ withconnection+ -> IO a -- ^ withoutconnection+ -> IO a+withSSHConnection rdarcs repoid withconnection withoutconnection =+ withoutProgress $+ do cs <- liftIO $ readIORef sshConnections+ case lookup (sshUhost repoid) (cs :: Map String (Maybe Connection)) of+ Just Nothing -> withoutconnection+ Just (Just c) -> withconnection c+ Nothing ->+ do mc <- do (ssh,sshargs_) <- liftIO $ getSSH SSH+ let sshargs = sshargs_ ++ [sshUhost repoid, rdarcs,+ "transfer-mode","--repodir",sshRepo repoid]+ liftIO $ debugMessage $ unwords (ssh : sshargs)+ (i,o,e,_) <- liftIO $ runInteractiveProcess ssh sshargs Nothing Nothing+ liftIO $ (do+ hSetBinaryMode i True+ hSetBinaryMode o True+ l <- hGetLine o+ unless (l == "Hello user, I am darcs transfer mode") $+ debugFail "Couldn't start darcs transfer-mode on server"+ let c = C { inp = i, out = o, err = e,+ deb = "with ssh (transfer-mode) " ++ sshUhost repoid }+ modifyIORef sshConnections (insert (sshUhost repoid) (Just c))+ return $ Just c) `catchNonSignal`+ \exn -> do+ debugMessage $ "Failed to start ssh connection:\n "+++ prettyException exn+ severSSHConnection repoid+ debugMessage $ unlines+ [ "NOTE: the server may be running a version of darcs prior to 2.0.0."+ , ""+ , "Installing darcs 2 on the server will speed up ssh-based commands."+ ]+ return Nothing+ maybe withoutconnection withconnection mc++severSSHConnection :: SshFilePath+ -> IO ()+severSSHConnection x = do+ debugMessage $ "Severing ssh failed connection to " ++ sshUhost x+ modifyIORef sshConnections (insert (urlOf x) Nothing)+++grabSSH :: SshFilePath -> Connection -> IO B.ByteString+grabSSH dest c = do+ debugMessage $ "grabSSH dest=" ++ urlOf dest+ let failwith e = do severSSHConnection dest+ -- hGetContents is ok here because we're+ -- only grabbing stderr, and we're also+ -- about to throw the contents.+ eee <- Ratified.hGetContents (err c)+ debugFail $ e ++ " grabbing ssh file "+++ urlOf dest++"/"++ file ++"\n"++eee+ file = sshFile dest+ debugMessage (deb c ++ " get "++ file)+ hPutStrLn (inp c) $ "get " ++ file+ hFlush (inp c)+ l2 <- hGetLine (out c)+ if l2 == "got "++file+ then do showlen <- hGetLine (out c)+ case reads showlen of+ [(len,"")] -> B.hGet (out c) len+ _ -> failwith "Couldn't get length"+ else if l2 == "error "++file+ then do e <- hGetLine (out c)+ case reads e of+ (msg,_):_ -> debugFail $ "Error reading file remotely:\n"++msg+ [] -> failwith "An error occurred"+ else failwith "Error"++remoteDarcs :: RemoteDarcs+ -> String+remoteDarcs DefaultRemoteDarcs = "darcs"+remoteDarcs (RemoteDarcs x) = x+++copySSH :: RemoteDarcs+ -> SshFilePath+ -> FilePath+ -> IO ()+copySSH remote dest to | rdarcs <- remoteDarcs remote = do+ debugMessage $ "copySSH file: " ++ urlOf dest+ withSSHConnection rdarcs dest (grabSSH dest >=> B.writeFile to) $ do+ let u = escape_dollar $ urlOf dest+ (scp, args) <- getSSH SCP+ let scp_args = filter (/="-q") args ++ [u, to]+ (r, scp_err) <- readInteractiveProcess scp scp_args+ unless (r == ExitSuccess) $+ throwIO $ ExecException scp scp_args (AsIs,AsIs,AsIs) scp_err+ where+ -- '$' in filenames is troublesome for scp, for some reason.+ escape_dollar :: String -> String+ escape_dollar = concatMap tr+ where+ tr '$' = "\\$"+ tr c = [c]+++-- ---------------------------------------------------------------------+-- older ssh helper functions+-- ---------------------------------------------------------------------++data SSHCmd = SSH+ | SCP+ | SFTP+++fromSshCmd :: SshSettings+ -> SSHCmd+ -> String+fromSshCmd s SSH = Settings.ssh s+fromSshCmd s SCP = Settings.scp s+fromSshCmd s SFTP = Settings.sftp s+++-- | Return the command and arguments needed to run an ssh command+-- First try the appropriate darcs environment variable and SSH_PORT+-- defaulting to "ssh" and no specified port.+getSSH :: SSHCmd+ -> IO (String, [String])+getSSH cmd = do+ port <- (portFlag cmd `fmap` getEnv "SSH_PORT") `catchall` return []+ let (ssh, ssh_args) = breakCommand command+ return (ssh, ssh_args ++ port)+ where+ command = fromSshCmd defaultSsh cmd+ portFlag SSH x = ["-p", x]+ portFlag SCP x = ["-P", x]+ portFlag SFTP x = ["-oPort=" ++ x]+++environmentHelpSsh :: ([String], [String])+environmentHelpSsh = (["DARCS_SSH"], [+ "Repositories of the form [user@]host:[dir] are taken to be remote",+ "repositories, which Darcs accesses with the external program ssh(1).",+ "",+ "The environment variable $DARCS_SSH can be used to specify an",+ "alternative SSH client. Arguments may be included, separated by",+ "whitespace. The value is not interpreted by a shell, so shell",+ "constructs cannot be used; in particular, it is not possible for the",+ "program name to contain whitespace by using quoting or escaping."])+++environmentHelpScp :: ([String], [String])+environmentHelpScp = (["DARCS_SCP", "DARCS_SFTP"], [+ "When reading from a remote repository, Darcs will attempt to run",+ "`darcs transfer-mode` on the remote host. This will fail if the",+ "remote host only has Darcs 1 installed, doesn't have Darcs installed",+ "at all, or only allows SFTP.",+ "",+ "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).",+ "The commands invoked can be customized with the environment variables",+ "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.",+ "If the remote end allows only sftp, try setting DARCS_SCP=sftp."])+++environmentHelpSshPort :: ([String], [String])+environmentHelpSshPort = (["SSH_PORT"], [+ "If this environment variable is set, it will be used as the port",+ "number for all SSH calls made by Darcs (when accessing remote",+ "repositories over SSH). This is useful if your SSH server does not",+ "run on the default port, and your SSH client does not support",+ "ssh_config(5). OpenSSH users will probably prefer to put something",+ "like `Host *.example.net Port 443` into their ~/.ssh/config file."])
src/Darcs/Repository/State.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-} {-# LANGUAGE CPP #-} -- Copyright (C) 2009 Petr Rockai@@ -24,13 +24,16 @@ -- SOFTWARE. module Darcs.Repository.State- ( restrictSubpaths, restrictBoring, TreeFilter(..)+ ( restrictSubpaths, restrictBoring, TreeFilter(..), restrictDarcsdir -- * Diffs.- , unrecordedChanges, readPending+ , unrecordedChanges, unrecordedChangesWithPatches, readPending -- * Trees. , readRecorded, readUnrecorded, readRecordedAndPending, readWorking+ , readPendingAndWorking -- * Index.- , readIndex, invalidateIndex, UseIndex(..), ScanKnown(..) ) where+ , readIndex, updateIndex, invalidateIndex, UseIndex(..), ScanKnown(..)+ -- * Utilities+ , filterOutConflicts ) where import Prelude hiding ( filter, catch ) import Control.Monad( when )@@ -43,28 +46,34 @@ import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile ) import System.FilePath ( (</>) ) import qualified Data.ByteString as BS+ ( readFile, drop, writeFile, empty ) import qualified Data.ByteString.Char8 as BSC+ ( pack, split ) -import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL, fromPrim, effect )+import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL, fromPrim, fromPrims+ , effect, anonymous ) import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnFilePaths )-import Darcs.Witnesses.Ordered ( FL(..), (+>+), mapFL_FL )-import Darcs.Witnesses.Eq ( EqCheck(IsEq, NotEq) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal )-import Darcs.Diff ( treeDiff )-import Darcs.Flags ( UseIndex(..), ScanKnown(..) )-import Darcs.Global ( darcsdir )-import Darcs.Utils ( filterPaths )+import Darcs.Patch.Witnesses.Ordered ( RL(..), FL(..), (+>+), mapFL_FL+ , (:>)(..) )+import Darcs.Patch.Witnesses.Eq ( EqCheck(IsEq, NotEq) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal )+import Darcs.Patch.Commute ( selfCommuter )+import Darcs.Patch.CommuteFn ( commuterIdRL )+import Darcs.Patch.Permutations ( partitionConflictingFL )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia ) +import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(..) )+import Darcs.Util.Global ( darcsdir )+ import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Repository.Format(formatHas, RepoProperty(NoWorkingDir)) import qualified Darcs.Repository.LowLevel as LowLevel import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps )--import Darcs.Patch.FileName ( fn2fp )-import Darcs.RepoPath ( SubPath, sp2fn )+import Darcs.Repository.Diff ( treeDiff ) -import Storage.Hashed.AnchoredPath( AnchoredPath(..), anchorPath, floatPath, Name(..) )+import Darcs.Util.Path( AnchoredPath(..), anchorPath, floatPath, Name(..), fn2fp,+ SubPath, sp2fn, filterPaths ) import Storage.Hashed.Tree( Tree, restrict, FilterTree, expand, filter, emptyTree, overlay, find ) import Storage.Hashed.Plain( readPlainTree ) import Storage.Hashed.Darcs( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize )@@ -72,7 +81,6 @@ import qualified Storage.Hashed.Index as I import qualified Storage.Hashed.Tree as Tree -#include "gadts.h" newtype TreeFilter m = TreeFilter { applyTreeFilter :: forall tr . FilterTree tr m => tr m -> tr m } @@ -81,20 +89,20 @@ -- constraint everywhere. When we have GHC 7.2 as a minimum requirement, we can -- lift this constraint into RepoPatch superclass context and remove this hack. readPendingLL :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> IO (Sealed ((FL p) C(t)))+ => Repository p wR wU wT -> IO (Sealed ((FL p) wT)) readPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` LowLevel.readPending repo -- | From a repository and a list of SubPath's, construct a filter that can be -- used on a Tree (recorded or unrecorded state) of this repository. This -- constructed filter will take pending into account, so the subpaths will be -- translated correctly relative to pending move patches.-restrictSubpaths :: forall p m C(r u t). (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> [SubPath]+restrictSubpaths :: forall p m wR wU wT. (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> [SubPath] -> IO (TreeFilter m) restrictSubpaths repo subpaths = do Sealed pending <- readPendingLL repo let paths = map (fn2fp . sp2fn) subpaths- paths' = paths `union` (effectOnFilePaths pending paths)+ paths' = paths `union` effectOnFilePaths pending paths anchored = map floatPath paths' restrictPaths :: FilterTree tree m => tree m -> tree m restrictPaths = filter (filterPaths anchored)@@ -153,17 +161,85 @@ -- is very inefficient, although in extremely rare cases, the index could go -- out of sync (file is modified, index is updated and file is modified again -- within a single second).-unrecordedChanges :: forall p C(r u t) . (RepoPatch p, ApplyState p ~ Tree)- => (UseIndex, ScanKnown) -> Repository p C(r u t)- -> Maybe [SubPath] -> IO (FL (PrimOf p) C(t u))-unrecordedChanges _ r@(Repo _ _ rf _) _- | (formatHas NoWorkingDir rf) = do+unrecordedChanges :: forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree)+ => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT+ -> Maybe [SubPath] -> IO (FL (PrimOf p) wT wU)+unrecordedChanges opts r paths = do+ (pending :> working) <- readPendingAndWorking opts r paths+ return $ sortCoalesceFL (pending +>+ working)++unrecordedChangesWithPatches :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)+ => (UseIndex, ScanKnown, DiffAlgorithm) -> Repository p wR wU wT+ -> Maybe [SubPath]+ -> FL (PrimOf p) wX wT -- look-for-moves patches+ -> FL (PrimOf p) wT wT -- look-for-replaces patches+ -> IO (FL (PrimOf p) wT wU)+unrecordedChangesWithPatches opts r paths movesPs replacesPs = do+ (pending :> working) <- readPendingAndWorkingWithPatches opts r paths movesPs replacesPs+ return $ sortCoalesceFL (pending +>+ unsafeCoerceP (movesPs +>+ replacesPs) +>+ working)++-- | Mostly a helper function to 'unrecordedChangesWithPatches', returning the pending+-- patch plus `patches` and the subsequent diff from working as two different patches+readPendingAndWorkingWithPatches :: forall p wR wU wT wZ. (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)+ => (UseIndex, ScanKnown, DiffAlgorithm)+ -> Repository p wR wU wT+ -> Maybe [SubPath]+ -> FL (PrimOf p) wZ wT -- look-for-moves patches+ -> FL (PrimOf p) wT wT -- look-for-replaces patches+ -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU)+readPendingAndWorkingWithPatches _ r@(Repo _ rf _ _) _ _ _ | (formatHas NoWorkingDir rf) = do IsEq <- return $ workDirLessRepoWitness r- return NilFL-unrecordedChanges (useidx, scan) repo mbpaths = do- (all_current, Sealed (pending :: FL p C(t x))) <- readPending repo+ return (NilFL :> NilFL)+readPendingAndWorkingWithPatches (useidx', scan, dflag) repo mbpaths movesPs replacesPs = do+ let allPatches = movesPs +>+ replacesPs+ let useidx = case allPatches of+ NilFL -> useidx'+ _ -> IgnoreIndex+ (all_current, Sealed (pending :: FL p wT wX)) <- readPending repo+ all_current_with_patches <- applyToTree allPatches all_current relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths+ let getIndex = applyToTree movesPs =<< I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo)+ current = applyTreeFilter relevant all_current_with_patches++ index <- getIndex+ working <- applyTreeFilter restrictDarcsdir <$> case scan of+ ScanKnown -> case useidx of+ UseIndex -> getIndex+ IgnoreIndex -> do+ guide <- expand current+ applyTreeFilter relevant <$> restrict guide <$> readPlainTree "."+ ScanAll -> do+ nonboring <- restrictBoring index+ plain <- applyTreeFilter relevant <$> applyTreeFilter nonboring <$> readPlainTree "."+ return $ case useidx of+ UseIndex -> plain `overlay` index+ IgnoreIndex -> plain+ ScanBoring -> do+ plain <- applyTreeFilter relevant <$> readPlainTree "."+ return $ case useidx of+ UseIndex -> plain `overlay` index+ IgnoreIndex -> plain++ ft <- filetypeFunction+ Sealed (diff :: FL (PrimOf p) wX wY) <- (unFreeLeft `fmap` treeDiff dflag ft current working) :: IO (Sealed (FL (PrimOf p) wX))+ IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck wY wU)+ return (effect pending :> diff)++-- | Mostly a helper function to 'unrecordedChanges', returning the pending+-- patch and the subsequent diff from working as two different patches+readPendingAndWorking :: forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree)+ => (UseIndex, ScanKnown, DiffAlgorithm)+ -> Repository p wR wU wT+ -> Maybe [SubPath]+ -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wT wU)+readPendingAndWorking _ r@(Repo _ rf _ _) _ | (formatHas NoWorkingDir rf) = do+ IsEq <- return $ workDirLessRepoWitness r+ return (NilFL :> NilFL)+readPendingAndWorking (useidx, scan, dflag) repo mbpaths = do+ (all_current, Sealed (pending :: FL p wT wX)) <- readPending repo++ relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths let getIndex = I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo) current = applyTreeFilter relevant all_current @@ -187,17 +263,16 @@ IgnoreIndex -> plain ft <- filetypeFunction- Sealed (diff :: FL (PrimOf p) C(x y)) <- (unFreeLeft `fmap` treeDiff ft current working) :: IO (Sealed (FL (PrimOf p) C(x)))- IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck C(y u))- return $ sortCoalesceFL (effect pending +>+ diff)+ Sealed (diff :: FL (PrimOf p) wX wY) <- (unFreeLeft `fmap` treeDiff dflag ft current working) :: IO (Sealed (FL (PrimOf p) wX))+ IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck wY wU)+ return (effect pending :> diff) -- | Witnesses the fact that in the absence of a working directory, we -- pretend that the working dir updates magically to the tentative state.-workDirLessRepoWitness :: Repository p C(r u t)- -> (EqCheck C(u t))-workDirLessRepoWitness (Repo _ _ rf _) | formatHas NoWorkingDir rf =- unsafeCoerceP IsEq- | otherwise = NotEq+workDirLessRepoWitness :: Repository p wR wU wT -> EqCheck wU wT+workDirLessRepoWitness (Repo _ rf _ _)+ | formatHas NoWorkingDir rf = unsafeCoerceP IsEq+ | otherwise = NotEq -- | Obtains a Tree corresponding to the "recorded" state of the repository: -- this is the same as the pristine cache, which is the same as the result of@@ -207,7 +282,7 @@ -- no-pristine case, as that requires replaying patches. Cf. 'readDarcsHashed' -- and 'readPlainTree' in hashed-storage that are used to do the actual 'Tree' -- construction.-readRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO (Tree IO)+readRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO (Tree IO) readRecorded _repo = do let h_inventory = darcsdir </> "hashed_inventory" hashed <- doesFileExist h_inventory@@ -236,7 +311,7 @@ -- parts of the index do not need to go through an up-to-date check (which -- involves a relatively expensive lstat(2) per file. readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> Maybe [SubPath] -> IO (Tree IO)+ => Repository p wR wU wT -> Maybe [SubPath] -> IO (Tree IO) readUnrecorded repo mbpaths = do relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths readIndex repo >>= I.updateIndex . applyTreeFilter relevant@@ -247,22 +322,22 @@ -- repositories. readWorking :: IO (Tree IO) readWorking = expand =<< (nodarcs `fmap` readPlainTree ".")- where nodarcs = Tree.filter (\(AnchoredPath (Name x:_)) _ -> x /= BSC.pack "_darcs")+ where nodarcs = Tree.filter (\(AnchoredPath (Name x:_)) _ -> x /= BSC.pack darcsdir) readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> IO (Tree IO)+ => Repository p wR wU wT -> IO (Tree IO) readRecordedAndPending repo = fst `fmap` readPending repo readPending :: (RepoPatch p, ApplyState p ~ Tree)- => Repository p C(r u t) -> IO (Tree IO, Sealed (FL p C(t)))+ => Repository p wR wU wT -> IO (Tree IO, Sealed (FL p wT)) readPending repo = do Sealed pending <- readPendingLL repo pristine <- readRecorded repo 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"- "_darcs/patches/pending_buggy"+ putStrLn "Stashing the buggy pending as _darcs/patches/pending_buggy"+ renameFile (darcsdir </> "patches" </> "pending")+ (darcsdir </> "patches" </> "pending_buggy") return (pristine, seal NilFL) -- | Mark the existing index as invalid. This has to be called whenever the@@ -271,25 +346,59 @@ -- pristine: changes to file content in either pristine or working are handled -- transparently by the index reading code.) invalidateIndex :: t -> IO ()-invalidateIndex _ = do- BS.writeFile "_darcs/index_invalid" BS.empty+invalidateIndex _ = BS.writeFile (darcsdir </> "index_invalid") BS.empty -readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO I.Index+readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO I.Index readIndex repo = do- invalid <- doesFileExist "_darcs/index_invalid"- exist <- doesFileExist "_darcs/index"- format_valid <- if exist- then I.indexFormatValid "_darcs/index"+ invalid <- doesFileExist $ darcsdir </> "index_invalid"+ exists <- doesFileExist $ darcsdir </> "index"+ formatValid <- if exists+ then I.indexFormatValid $ darcsdir </> "index" else return True- when (exist && not format_valid) $+ when (exists && not formatValid) $ #if mingw32_HOST_OS- renameFile "_darcs/index" "_darcs/index.old"+ renameFile (darcsdir </> "index") (darcsdir </> "index.old") #else- removeFile "_darcs/index"+ removeFile $ darcsdir </> "index" #endif- if (not exist || invalid || not format_valid)+ if not exists || invalid || not formatValid then do pris <- readRecordedAndPending repo- idx <- I.updateIndexFrom "_darcs/index" darcsTreeHash pris- when invalid $ removeFile "_darcs/index_invalid"+ idx <- I.updateIndexFrom (darcsdir </> "index") darcsTreeHash pris+ when invalid $ removeFile $ darcsdir </> "index_invalid" return idx- else I.readIndex "_darcs/index" darcsTreeHash+ else I.readIndex (darcsdir </> "index") darcsTreeHash++updateIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()+updateIndex repo = do+ invalid <- doesFileExist $ darcsdir </> "index_invalid"+ exists <- doesFileExist $ darcsdir </> "index"+ formatValid <- if exists+ then I.indexFormatValid $ darcsdir </> "index"+ else return True+ when (exists && not formatValid) $+#if mingw32_HOST_OS+ renameFile (darcsdir </> "index") (darcsdir </> "index.old")+#else+ removeFile $ darcsdir </> "index"+#endif+ pris <- readRecordedAndPending repo+ _ <- I.updateIndexFrom (darcsdir </> "index") darcsTreeHash pris+ when invalid $ removeFile $ darcsdir </> "index_invalid"++-- |Remove any patches (+dependencies) from a sequence that+-- conflict with the recorded or unrecorded changes in a repo+filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree)+ => RL (PatchInfoAnd p) wX wT -- ^Recorded patches from repository, starting from+ -- same context as the patches to filter+ -> Repository p wR wU wT -- ^Repository itself, used for grabbing unrecorded changes+ -> FL (PatchInfoAnd p) wX wZ -- ^Patches to filter+ -> IO (Bool, Sealed (FL (PatchInfoAnd p) wX)) -- ^(True iff any patches were removed, possibly filtered patches)+filterOutConflicts us repository them+ = do let commuter = commuterIdRL selfCommuter+ unrec <- fmap n2pia . anonymous . fromPrims+ =<< unrecordedChanges (UseIndex, ScanKnown, MyersDiff) repository Nothing+ them' :> rest <- return $ partitionConflictingFL commuter them (unrec :<: us)+ return (check rest, Sealed them')+ where check :: FL p wA wB -> Bool+ check NilFL = False+ check _ = True
+ src/Darcs/Repository/Test.hs view
@@ -0,0 +1,163 @@+-- Copyright (C) 2002-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Repository.Test+ ( getTest+ , runPosthook+ , runPrehook+ , testTentative+ )+where++import System.Exit ( ExitCode(..) )+import System.Process ( system )+import System.IO ( hPutStrLn, stderr )+import Control.Monad ( when )++import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Prompt ( askUser )+import Darcs.Repository.Prefs ( getPrefval )+import Darcs.Patch+ ( RepoPatch )++import Darcs.Repository.Internal+ ( setScriptsExecutable+ , withTentative+ )+import Darcs.Repository.Flags+ ( LeaveTestDir(..)+ , Verbosity(..)+ , SetScriptsExecutable(..)+ , RunTest (..)+ )+import Darcs.Repository.InternalTypes+ ( Repository(..) )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Repository.Lock+ ( withTempDir+ , withPermDir+ )+import Darcs.Patch.Apply ( ApplyState )+import Storage.Hashed.Tree ( Tree )+++getTest :: Verbosity -> IO (IO ExitCode)+getTest verb =+ let putInfo s = when (verb /= Quiet) $ putStr s+ in do+ testline <- getPrefval "test"+ return $+ case testline of+ Nothing -> return ExitSuccess+ Just testcode -> do+ putInfo "Running test...\n"+ runTest testcode putInfo++runPosthook :: Maybe String -> Bool -> Verbosity -> AbsolutePath -> IO ExitCode+runPosthook mPostHook askPostHook verb repodir+ = do ph <- getPosthook mPostHook askPostHook+ withCurrentDirectory repodir $ runHook verb "Posthook" ph++getPosthook :: Maybe String -> Bool -> IO (Maybe String)+getPosthook mPostHookCmd askPostHook =+ case mPostHookCmd of+ Nothing -> return Nothing+ Just command ->+ if askPostHook+ then do putStr ("\nThe following command is set to execute.\n"+++ "Execute the following command now (yes or no)?\n"+++ command++"\n")+ yorn <- askUser ""+ case yorn of+ ('y':_) -> return $ Just command+ _ -> putStrLn "Posthook cancelled..." >> return Nothing+ else return $ Just command++runPrehook :: Maybe String -> Bool -> Verbosity -> AbsolutePath -> IO ExitCode+runPrehook mPreHookCmd askPreHook verb repodir =+ do ph <- getPrehook mPreHookCmd askPreHook+ withCurrentDirectory repodir $ runHook verb "Prehook" ph++getPrehook :: Maybe String -> Bool -> IO (Maybe String)+getPrehook mPreHookCmd askPreHook=+ case mPreHookCmd of+ Nothing -> return Nothing+ Just command ->+ if askPreHook+ then do putStr ("\nThe following command is set to execute.\n"+++ "Execute the following command now (yes or no)?\n"+++ command++"\n")+ yorn <- askUser ""+ case yorn of+ ('y':_) -> return $ Just command+ _ -> putStrLn "Prehook cancelled..." >> return Nothing+ else return $ Just command++runHook :: Verbosity -> String -> Maybe String -> IO ExitCode+runHook _ _ Nothing = return ExitSuccess+runHook verb cname (Just command) =+ do ec <- system command+ when (verb /= Quiet) $+ if ec == ExitSuccess+ then putStrLn $ cname++" ran successfully."+ else hPutStrLn stderr $ cname++" failed!"+ return ec++testTentative :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> RunTest+ -> LeaveTestDir+ -> SetScriptsExecutable+ -> Verbosity+ -> IO ExitCode+testTentative = testAny withTentative++runTest :: String -> (String -> IO ()) -> IO ExitCode+runTest testcode putInfo = do+ ec <- system testcode+ if ec == ExitSuccess+ then putInfo "Test ran successfully.\n"+ else putInfo "Test failed!\n"+ return ec+++testAny :: RepoPatch p+ => (Repository p wR wU wT+ -> ((AbsolutePath -> IO ExitCode) -> IO ExitCode)+ -> (AbsolutePath -> IO ExitCode) -> IO ExitCode+ )+ -> Repository p wR wU wT+ -> RunTest+ -> LeaveTestDir+ -> SetScriptsExecutable+ -> Verbosity+ -> IO ExitCode+testAny withD repository@(Repo dir _ _ _) doRunTest ltd sse verb =+ debugMessage "Considering whether to test..." >>+ if doRunTest == NoRunTest then return ExitSuccess else withCurrentDirectory dir $+ do let putInfo = if verb == Quiet then const (return ()) else putStrLn+ debugMessage "About to run test if it exists."+ testline <- getPrefval "test"+ case testline of+ Nothing -> return ExitSuccess+ Just testcode ->+ withD repository (wd "testing") $ \_ ->+ do putInfo "Running test...\n"+ when (sse == YesSetScriptsExecutable) setScriptsExecutable+ runTest testcode putInfo+ where wd = if ltd == YesLeaveTestDir then withPermDir else withTempDir
+ src/Darcs/Repository/Util.hs view
@@ -0,0 +1,340 @@+-- Copyright (C) 2013 Jose Neder+--+-- 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.++{-# LANGUAGE CPP #-}+module Darcs.Repository.Util+ ( getReplaces+ , floatSubPath+ , maybeApplyToTree+ , defaultToks+ , getMovesPs+ , patchSetfMap+ , getRecursiveDarcsRepos+ ) where++import Prelude hiding ( catch )+import Control.Applicative ( (<$>) )+import Control.Monad ( foldM, forM )+import Control.Exception ( catch, IOException )+import qualified Data.ByteString as B ( null, concat )+import qualified Data.ByteString.Char8 as BC ( unpack, pack )+import qualified Data.ByteString.Lazy as BL ( toChunks )+import Data.Maybe ( isJust, fromJust, catMaybes )+import Data.Ord ( comparing )+import Data.List ( sortBy )+#ifdef USE_LOCAL_DATA_MAP_STRICT+import qualified Darcs.Data.Map.Strict as M ( Map, lookup, fromList, insert, map,+ empty, assocs, size, findWithDefault, delete )+#else+import qualified Data.Map.Strict as M ( Map, lookup, fromList, insert, map,+ empty, assocs, size, findWithDefault, delete )+#endif++import Storage.Hashed( floatPath, readPlainTree )+import Storage.Hashed.Tree ( Tree, emptyTree, expand, ItemType(..), itemType,+ readBlob, modifyTree, findFile, TreeItem(..),+ makeBlobBS, expandPath )+import Storage.Hashed.AnchoredPath ( AnchoredPath, anchorPath, parents,+ replacePrefixPath, anchoredRoot )+import qualified Storage.Hashed.Tree as T ( list )+import Storage.Hashed.Index ( listFileIDs, getFileID )+import System.Posix.Types ( FileID )+import System.Directory ( getDirectoryContents, doesDirectoryExist )+import System.FilePath.Posix ( (</>) )+import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf, primIsHunk, applyToTree,+ tokreplace, forceTokReplace, move )+import Darcs.Patch.Set ( newset2RL, PatchSet(..) )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Patchy ( Apply )+import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ), Prim(..) )+import Darcs.Patch.Prim.Class ( PrimConstruct, PrimCanonize )+import Darcs.Patch.Permutations ( partitionRL )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )+import Darcs.Patch.TokenReplace ( breakOutToken )+import Darcs.Patch.Witnesses.Ordered ( FL(..), reverseRL, reverseFL, (:>)(..),+ foldlFL, concatFL, toFL, (+>+), mapRL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft, mapSeal, freeGap,+ emptyGap, joinGap, FreeLeft, Gap(..) )+import Darcs.Repository+ ( Repository+ , readUnrecorded+ , readRecordedAndPending+ , maybeIdentifyRepository+ )+import Darcs.Repository.Internal ( IdentifyRepo(..) )+import Darcs.Repository.InternalTypes ( Repository(..), Pristine(..) )+import Darcs.Repository.Diff( treeDiff )+import Darcs.Repository.Flags ( UseIndex(..), ScanKnown, DiffAlgorithm(..), UseCache(..) )+import Darcs.Repository.Prefs ( filetypeFunction )+import Darcs.Repository.State ( TreeFilter(..), applyTreeFilter,+ restrictSubpaths, readWorking, restrictBoring,+ readIndex )+import Darcs.Util.Path( fn2fp, SubPath, toFilePath, simpleSubPath, normPath,+ floatSubPath )++getMovesPs :: forall p wR wU wB prim.+ (PrimConstruct prim, PrimCanonize prim, RepoPatch p,+ ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)+ => Repository p wR wU wR+ -> Maybe [SubPath]+ -> IO (FL prim wB wB)+getMovesPs repository files = mkMovesFL <$> getMovedFiles repository files+ where+ mkMovesFL [] = NilFL+ mkMovesFL ((a,b,_):xs) = move (anchorPath "" a) (anchorPath "" b) :>: mkMovesFL xs++ getMovedFiles :: (RepoPatch p, ApplyState p ~ Tree,+ ApplyState (PrimOf p) ~ Tree) =>+ Repository p wR wU wR ->+ Maybe [SubPath] ->+ IO [(AnchoredPath, AnchoredPath, ItemType)]+ getMovedFiles repo fs = do+ old <- sortBy (comparing snd) <$> (listFileIDs =<< readIndex repo)+ nonboring <- restrictBoring emptyTree+ new <- sortBy (comparing snd) <$>+ (addFileIDs . (map (\(a,b) -> (a, itemType b)) . T.list) =<<+ expand =<<+ applyTreeFilter nonboring <$> readPlainTree ".")+ let movedfiles = matchFileLists old new+ fmovedfiles = case fs of+ Nothing -> movedfiles+ Just subpath -> filter (\(old',new',_) -> old' `elem` selfiles+ || new' `elem` selfiles) movedfiles+ where selfiles = map (floatPath . toFilePath) subpath+ return (resolveMoves fmovedfiles)++ resolveMoves :: [(AnchoredPath, AnchoredPath, ItemType)]+ -> [(AnchoredPath, AnchoredPath, ItemType)]+ resolveMoves xs = changePaths $ resolveDeps 0 (M.size movesMap) visited movesMap movesDepsMap+ where+ changePaths [] = []+ changePaths (y:ys) | fst' y == snd' y = changePaths $ map replacepp ys+ | isPath y = y:changePaths (map replacepp ys)+ | otherwise = y:changePaths ys+ where replacepp i | nfst == anchoredRoot = i+ | otherwise = (nfst, snd' i, thd' i)+ where nfst = replacePrefixPath (fst' y) (snd' y) (fst' i)++ -- sort and index moves+ movesMap = M.fromList $ zip [0..] $ sortBy (comparing thd') xs++ movesIDMap :: M.Map (AnchoredPath,AnchoredPath,ItemType) Int+ movesIDMap = M.fromList $ zip (sortBy (comparing thd') $ xs) [0..]++ -- establish a relation of dependencies between moves (destination or parent of destination is moved again)+ movesDepsMap :: M.Map Int [Int]+ movesDepsMap = M.map (getMoveDeps (M.fromList (map (\x -> (fst' x,x)) xs))+ (M.fromList (map (\x -> (snd' x,x)) xs))) movesMap++ getMoveDeps :: M.Map AnchoredPath (AnchoredPath, AnchoredPath, ItemType) -- source to move+ -> M.Map AnchoredPath (AnchoredPath, AnchoredPath, ItemType) -- destin to move+ -> (AnchoredPath, AnchoredPath, ItemType) -- some move+ -> [Int]+ getMoveDeps am bm y = catMaybes $+ map (`M.lookup` movesIDMap) $ -- retrieve mode ID of deps+ catMaybes $+ byname ++ map (`M.lookup` bm) (parents $ snd' y) -- see if current move is moved to moved dir+ where byname | fst' y == snd' y = []+ | otherwise = [M.lookup (snd' y) am] -- see if current move is moved again++ fst' (a,_,_) = a+ snd' (_,a,_) = a+ thd' (_,_,a) = a++ resolveDeps :: Int -> Int -> M.Map Int (Int,Bool)+ -> M.Map Int (AnchoredPath, AnchoredPath, ItemType)+ -> M.Map Int [Int]+ -> [(AnchoredPath, AnchoredPath, ItemType)]+ resolveDeps n end v mm mdm+ | n == end = reverse $+ catMaybes $+ map (flip M.lookup mm . abs) $+ getMoves (map fst (filter (\(_,(_,f)) -> f) $+ sortBy (comparing (fst . snd)) (M.assocs v))) mdm+ | M.lookup n v /= Nothing = resolveDeps (n+1) end v mm mdm+ | otherwise = resolveDeps (n+1) end nv nmm nmdm+ where (nv, nmm, nmdm) = walk True n n v mm mdm++ getMoves [] _ = []+ getMoves (r:roots) mdm = [r]++bds r++getMoves roots mdm+ where bds r' = lookupList r' mdm ++ concatMap bds (map abs $ lookupList r' mdm)++ lookupList x mdm = M.findWithDefault [] x mdm++ walk b n x v mm mdm+ | x < 0 = (v, mm, mdm)+ | Just n == (fst <$> M.lookup x v) = resolveClashName n x v mm mdm+ | otherwise = foldl (\(v',mm', mdm') dep ->+ walk False n dep v' mm' mdm')+ (M.insert x (n,b) v, mm, mdm)+ (lookupList x mdm)++ -- Ignore swap moves+ -- Currently, handling them would involve introducing intermediate file names.+ -- When darcs has swapmove primitive hunk we may fix this.+ resolveClashName n x v mm mdm = (v', mm', mdm')+ where v' = M.insert x (n,False) $+ foldl addvisited v (lookupList x mdm)+ mm' = M.delete x mm -- forget about x+ mdm' = M.insert x [] mdm -- remove dependencies for x+ addvisited nv k | (fst <$> M.lookup k nv) /= Just n = foldl addvisited (M.insert k (n, False) nv) (lookupList k mdm)+ | otherwise = nv++ visited = M.empty :: M.Map Int (Int, Bool)++ isPath (_, _, TreeType) = True+ isPath _ = False++ addFileIDs :: [(AnchoredPath, ItemType)] -> IO [((AnchoredPath, ItemType),FileID)]+ addFileIDs = foldM (\xs (apath, it)-> do fid <- getFileID apath+ return $ case fid of+ Nothing -> xs+ Just fileid -> ((apath, it), fileid):xs) []++ matchFileLists :: [((AnchoredPath, ItemType),FileID)]+ -> [((AnchoredPath, ItemType),FileID)]+ -> [(AnchoredPath, AnchoredPath, ItemType)]+ matchFileLists [] _ = []+ matchFileLists _ [] = []+ matchFileLists (x:xs) (y:ys) | snd x > snd y = matchFileLists (x:xs) ys+ | snd x < snd y = matchFileLists xs (y:ys)+ | snd (fst x) /= snd (fst y) = matchFileLists xs ys+ | otherwise = (fst (fst x), fst (fst y), snd (fst x)):matchFileLists xs ys+++-- | Search for possible replaces between the recordedAndPending state+-- and the unrecorded (or working) state. Return a Sealed FL list of+-- replace patches to be applied to the recordedAndPending state.+getReplaces :: forall p wR wU wT wX. (RepoPatch p, ApplyState p ~ Tree,+ ApplyState (PrimOf p) ~ Tree, wX ~ wR)+ => (UseIndex, ScanKnown, DiffAlgorithm)+ -> Repository p wR wU wT+ -> Maybe [SubPath]+ -> IO (Sealed (FL (PrimOf p) wX))+getReplaces (useindex, _, dopts) repo files = do+ relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) files+ working <- applyTreeFilter relevant <$> case useindex of+ UseIndex -> readUnrecorded repo Nothing+ IgnoreIndex -> readWorking+ pending <- applyTreeFilter relevant <$> readRecordedAndPending repo+ ftf <- filetypeFunction++ Sealed changes <- unFreeLeft <$> treeDiff dopts ftf pending working+ _ :> hunks <- return $ partitionRL primIsHunk $ reverseFL changes+ let unfilteredReplaces = foldlFL modifiedTokens [] (reverseRL hunks)+ replaces = filterInvalidReplaces unfilteredReplaces+ mapSeal concatFL . toFL <$>+ mapM (\(f,a,b) -> doReplace defaultToks pending+ (fromJust $ simpleSubPath $ fn2fp $ normPath f)+ (BC.unpack a) (BC.unpack b)) replaces+ where -- get individual tokens that have been modified+ modifiedTokens xs (FP f (Hunk _ old new)) =+ (map (\(a,b) -> (f, a, b)) $ concatMap checkForReplaces $+ filter (\(a,b) -> length a == length b)+ $ zip (map breakToTokens old) (map breakToTokens new)) ++xs+ modifiedTokens _ _ = error "modifiedTokens: Not Hunk patch"++ -- from a pair of token lists, create a pair of modified token lists+ checkForReplaces ([],[]) = []+ checkForReplaces ((a:as),(b:bs)) | a == b = checkForReplaces (as,bs)+ | otherwise = (a,b):checkForReplaces (as,bs)+ checkForReplaces _ = error "checkForReplaces: Lists are not of the same length"++ -- keep tokens that have been consistently replaced+ filterInvalidReplaces [] = []+ filterInvalidReplaces ((f,old,new):rs)+ | any (\(f',a,b) -> f' == f && old == a && b /= new) rs =+ filterInvalidReplaces $ filter (\(f'',a',_) -> f'' == f && a' /= old) rs+ filterInvalidReplaces (r:rs) = r:filterInvalidReplaces (filter (/=r) rs)++ -- break a single bytestring into tokens+ breakToTokens input | B.null input = []+ breakToTokens input =+ let (_, tok, remaining) = breakOutToken defaultToks input in+ tok : breakToTokens remaining++ doReplace toks pend f old new = do+ let maybeReplace p = isJust <$> maybeApplyToTree replacePatch p+ pendReplaced <- maybeReplace pend+ if pendReplaced+ then return $ joinGap (:>:) (freeGap replacePatch) gapNilFL+ else getForceReplace f toks pend old new+ where+ gapNilFL = emptyGap NilFL+ fp = toFilePath f+ replacePatch = tokreplace fp toks old new++ getForceReplace :: PrimPatch prim => SubPath -> String -> Tree IO -> String -> String+ -> IO (FreeLeft (FL prim))+ getForceReplace f toks tree old new = do+ let path = floatSubPath f+ -- It would be nice if we could fuse the two traversals here, that is,+ -- expandPath and findFile. OTOH it is debatable whether adding a new+ -- effectful version of findFile to Storage.Hashed.Tree is justified.+ expandedTree <- expandPath tree path+ content <- case findFile expandedTree path of+ Just blob -> readBlob blob+ Nothing -> do+ error $ "getForceReplace: not in tree: " ++ show path+ let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old)+ (B.concat $ BL.toChunks content)+ tree' = modifyTree expandedTree path . Just . File $ makeBlobBS newcontent+ ftf <- filetypeFunction+ normaliseNewTokPatch <- treeDiff dopts ftf expandedTree tree'+ return . joinGap (+>+) normaliseNewTokPatch $ freeGap $+ tokreplace (toFilePath f) toks old new :>: NilFL+++maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Tree IO+ -> IO (Maybe (Tree IO))+maybeApplyToTree patch tree =+ (Just `fmap` applyToTree patch tree) `catch` (\(_ :: IOException) -> return Nothing)++patchSetfMap:: (forall wW wZ . PatchInfoAnd p wW wZ -> IO a) -> PatchSet p wW' wZ' -> IO [a]+patchSetfMap f = sequence . mapRL f . newset2RL++defaultToks :: String+defaultToks = "A-Za-z_0-9"++-- |getRecursiveDarcsRepos returns all paths to repositories under topdir.+getRecursiveDarcsRepos :: FilePath -> IO [FilePath]+getRecursiveDarcsRepos topdir = do+ isDir <- doesDirectoryExist topdir+ if isDir+ then do+ status <- maybeIdentifyRepository NoUseCache topdir+ case status of+ GoodRepository (Repo _ _ pris _) ->+ case pris of+ HashedPristine -> return [topdir]+ _ -> return [] -- old fashioned or broken repo+ _ -> getRecursiveDarcsRepos' topdir+ else return []++ where+ getRecursiveDarcsRepos' d = do+ names <- getDirectoryContents d+ let properNames = filter (\x -> head x /= '.') names+ paths <- forM properNames $ \name -> do+ let path = d </> name+ getRecursiveDarcsRepos path+ return (concat paths)
− src/Darcs/Resolution.hs
@@ -1,164 +0,0 @@--- Copyright (C) 2003,2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Resolution ( standardResolution,- externalResolution,- patchsetConflictResolutions,- ) where--import System.FilePath.Posix ( (</>) )-import System.Exit ( ExitCode( ExitSuccess ) )-import System.Directory ( setCurrentDirectory, getCurrentDirectory )-import Data.List ( zip4 )-import Control.Monad ( when )--import Darcs.Diff( treeDiff )-import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch, joinPatches, resolveConflicts,- effectOnFilePaths, patchcontents,- invert, listConflictedFiles, commute, applyToTree, fromPrim )-import Darcs.Patch.Apply( ApplyState )-import Darcs.RepoPath ( toFilePath )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+),- mapFL_FL, reverseRL )--import CommandLine ( parseCmd )-import Darcs.Patch.PatchInfoAnd ( hopefully )-import Darcs.Utils ( askEnter, filterFilePaths )-import Darcs.Patch.Set ( PatchSet(..) )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft )-import Darcs.Repository.Prefs ( filetypeFunction )-import Exec ( exec, Redirect(..) )-import Darcs.Lock ( withTempDir )-import Darcs.External ( cloneTree )-import Darcs.Flags ( DarcsFlag, wantGuiPause )--import qualified Storage.Hashed.Tree as Tree-import Storage.Hashed ( writePlainTree, readPlainTree )----import Darcs.ColorPrinter ( traceDoc )---import Printer ( greenText, ($$), Doc )---import Darcs.Patch ( showPatch )--standardResolution :: RepoPatch p => FL p C(x y) -> Sealed (FL (PrimOf p) C(y))-standardResolution p = mergeList $ map head $ resolveConflicts p--mergeList :: forall prim C(x) . PrimPatch prim => [Sealed (FL prim C(x))] -> Sealed (FL prim C(x))-mergeList patches = doml NilFL patches- where doml :: FL prim C(x y) -> [Sealed (FL prim C(x))] -> Sealed (FL prim C(x))- doml mp (Sealed p:ps) =- case commute (invert p :> mp) of- Just (mp' :> _) -> doml (p +>+ mp') ps- Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions.- doml mp [] = Sealed mp--externalResolution :: forall p C(x y z a). (RepoPatch p, ApplyState p ~ Tree.Tree)- => Tree.Tree IO- -> String -- ^ external merge tool command- -> [DarcsFlag] -- ^ command line arguments- -> FL (PrimOf p) C(x y)- -> FL (PrimOf p) C(x z)- -> FL p C(y a)- -> IO (Sealed (FL (PrimOf p) C(a)))-externalResolution s1 c opts p1_prim p2_prim pmerged = do- -- TODO: remove the following two once we can rely on GHC 7.2 / superclass equality- let p1 :: FL p C(x y) = mapFL_FL fromPrim p1_prim- p2 :: FL p C(x z) = mapFL_FL fromPrim p2_prim- sa <- applyToTree (invert p1) s1- sm <- applyToTree pmerged s1- s2 <- applyToTree p2 sa- let effectOnFPs ps fps = effectOnFilePaths ps fps- nms = listConflictedFiles pmerged- nas = effectOnFPs (invert pmerged) nms- n1s = effectOnFPs p1 nas- n2s = effectOnFPs p2 nas- ns = zip4 nas n1s n2s nms- write_files tree fs = writePlainTree (Tree.filter (filterFilePaths fs) tree) "."- in do- former_dir <- getCurrentDirectory- withTempDir "version1" $ \absd1 -> do- let d1 = toFilePath absd1- write_files s1 n1s- setCurrentDirectory former_dir- withTempDir "ancestor" $ \absda -> do- let da = toFilePath absda- write_files sa nas- setCurrentDirectory former_dir- withTempDir "merged" $ \absdm -> do- let dm = toFilePath absdm- write_files sm nms- setCurrentDirectory former_dir- withTempDir "cleanmerged" $ \absdc -> do- let dc = toFilePath absdc- cloneTree dm "."- setCurrentDirectory former_dir- withTempDir "version2" $ \absd2 -> do- let d2 = toFilePath absd2- write_files s2 n2s- mapM_ (externallyResolveFile c opts da d1 d2 dm) ns- sc <- readPlainTree dc- sfixed <- readPlainTree dm- ftf <- filetypeFunction- unFreeLeft `fmap` treeDiff ftf sc sfixed--externallyResolveFile :: String -- ^ external merge tool command- -> [DarcsFlag] -- ^ command line arguments- -> String -- ^ path to merge base- -> String -- ^ path to side 1 of the merge- -> String -- ^ path to side 2 of the merge- -> String -- ^ path where resolved content should go- -> (FilePath, FilePath, FilePath, FilePath)- -> IO ()-externallyResolveFile c opts da d1 d2 dm (fa, f1, f2, fm) = do- putStrLn $ "Merging file "++fm++" by hand."- ec <- run c [('1', d1</>f1), ('2', d2</>f2), ('a', da</>fa), ('o', dm</>fm), ('%', "%")]- when (ec /= ExitSuccess) $- putStrLn $ "External merge command exited with " ++ show ec- when (wantGuiPause opts) $- askEnter "Hit return to move on, ^C to abort the whole operation..."--run :: String -> [(Char,String)] -> IO ExitCode-run c replacements =- case parseCmd replacements c of- Left err -> fail $ show err- Right (c2,_) -> rr c2- where rr (command:args) = do putStrLn $ "Running command '" ++- unwords (command:args) ++ "'"- exec command args (Null,Null,Null)- rr [] = return ExitSuccess--patchsetConflictResolutions :: RepoPatch p => PatchSet p C(Origin x) -> Sealed (FL (PrimOf p) C(x))-patchsetConflictResolutions (PatchSet NilRL _) = Sealed NilFL-patchsetConflictResolutions (PatchSet xs _)- = --traceDoc (greenText "looking at resolutions" $$- -- (sh $ resolveConflicts $ joinPatches $- -- mapFL_FL (patchcontents . hopefully) $ reverseRL xs )) $- mergeList $ map head $ resolveConflicts $ joinPatches $- mapFL_FL (patchcontents . hopefully) $ reverseRL xs- --where sh :: [[Sealed (FL Prim)]] -> Doc- -- sh [] = greenText "no more conflicts"- -- sh (x:ps) = greenText "one conflict" $$ sh1 x $$ sh ps- -- sh1 :: [Sealed (FL Prim)] -> Doc- -- sh1 [] = greenText "end of unravellings"- -- sh1 (Sealed x:ps) = greenText "one unravelling:" $$ showPatch x $$- -- sh1 ps
− src/Darcs/RunCommand.hs
@@ -1,192 +0,0 @@--- Copyright (C) 2002,2003,2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}-module Darcs.RunCommand ( runTheCommand ) where--import Control.Monad ( unless, when )-import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ),- OptDescr( Option ),- getOpt )-import System.Exit ( ExitCode ( ExitSuccess ), exitWith )--import Darcs.Arguments ( DarcsFlag(..),- help,- fixUrlFlag,- optionFromDarcsOption,- listOptions, nubOptions )-import Darcs.ArgumentDefaults ( getDefaultFlags )-import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ),- CommandControl,- DarcsCommand,- commandName,- commandCommand,- commandPrereq,- commandExtraArgHelp,- commandExtraArgs,- commandArgdefaults,- commandGetArgPossibilities,- commandOptions, commandAlloptions,- disambiguateCommands,- getCommandHelp, getCommandMiniHelp,- getSubcommands,- extractCommands,- superName,- subusage, chompNewline )-import Darcs.Commands.GZCRCs ( doCRCWarnings )-import Darcs.Global ( atexit )-import Darcs.External ( viewDoc )-import Darcs.Global ( setDebugMode, setTimingsMode )-import Darcs.Match ( checkMatchSyntax )-import Progress ( setProgressMode )-import Darcs.RepoPath ( getCurrentDirectory )-import Darcs.Test ( runPosthook, runPrehook )-import Darcs.Utils ( formatPath )-import Data.List ( intercalate )-import Printer ( text )-import URL ( setDebugHTTP, disableHTTPPipelining )--runTheCommand :: [CommandControl] -> String -> [String] -> IO ()-runTheCommand commandControlList cmd args =- either fail rtc $ disambiguateCommands commandControlList cmd args- where- rtc (CommandOnly c, as) = runCommand Nothing c as- rtc (SuperCommandOnly c, as) = runRawSupercommand c as- rtc (SuperCommandSub c s, as) = runCommand (Just c) s as---- This is the actual heavy lifter code, which is responsible for parsing the--- arguments and then running the command itself.--runCommand :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO ()--runCommand _ _ args -- Check for "dangerous" typoes...- | "-all" `elem` args = -- -all indicates --all --look-for-adds!- fail "Are you sure you didn't mean --all rather than -all?"-runCommand msuper cmd args = do- cwd <- getCurrentDirectory- let options = opts1 ++ opts2- (opts1, opts2) = commandOptions cwd cmd- case getOpt Permute- (optionFromDarcsOption cwd listOptions++options) args of- (opts,extra,[])- | Help `elem` opts -> viewDoc $ text $ getCommandHelp msuper cmd- | ListOptions `elem` opts -> do- setProgressMode False--- Warning: A do-notation statement discarded a result of type Either String ().- _ <- commandPrereq cmd opts- file_args <- commandGetArgPossibilities cmd- putStrLn $ unlines $ getOptionsOptions (opts1++opts2) : file_args- | otherwise -> considerRunning msuper cmd (addVerboseIfDebug opts) extra- (_,_,ermsgs) -> fail $ chompNewline(unlines ermsgs)- where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts- | otherwise = opts--considerRunning :: Maybe DarcsCommand -> DarcsCommand- -> [DarcsFlag] -> [String] -> IO ()-considerRunning msuper cmd opts old_extra = do- cwd <- getCurrentDirectory- location <- commandPrereq cmd opts- case location of- Left complaint -> fail $ "Unable to " ++- formatPath ("darcs " ++ superName msuper ++ commandName cmd) ++- " here.\n\n" ++ complaint- Right () -> do- specops <- nubopts `fmap` addCommandDefaults cmd opts- extra <- (commandArgdefaults cmd) specops cwd old_extra- when (Disable `elem` specops) $- fail $ "Command "++commandName cmd++" disabled with --disable option!"- case extraArgumentsError extra cmd msuper of- Nothing -> runWithHooks specops extra- Just msg -> fail msg- where nubopts = nubOptions (uncurry (++) $ commandAlloptions cmd)- runWithHooks os ex = do- here <- getCurrentDirectory- checkMatchSyntax os- -- set any global variables- when (Timings `elem` os) setTimingsMode- when (Debug `elem` os) setDebugMode- when (DebugHTTP `elem` os) setDebugHTTP- when (Quiet `elem` os) $ setProgressMode False- when (NoHTTPPipelining `elem` os) $ disableHTTPPipelining- unless (Quiet `elem` os) $ atexit $ doCRCWarnings (Verbose `elem` os)- -- actually run the command and its hooks- preHookExitCode <- runPrehook os here- if preHookExitCode /= ExitSuccess- then exitWith preHookExitCode- else do let fixFlag = FixFilePath here cwd- fixedOs <- mapM (fixUrlFlag [fixFlag]) os- (commandCommand cmd) (fixFlag : fixedOs) ex- postHookExitCode <- runPosthook os here- exitWith postHookExitCode---- Checks if the number of extra arguments matches the number of extra--- arguments supported by the command as specified in `commandExtraArgs`.--- Extra arguments are arguments that follow the command but aren't--- considered a flag. In `darcs push xyz`, xyz would be an extra argument.-extraArgumentsError :: [String] -- extra commands provided by user- -> DarcsCommand- -> Maybe DarcsCommand- -> Maybe String-extraArgumentsError extra cmd msuper- | extraArgsCmd < 0 = Nothing- | extraArgsInput > extraArgsCmd = Just badArg- | extraArgsInput < extraArgsCmd = Just missingArg- | otherwise = Nothing- where- extraArgsInput = length extra- extraArgsCmd = commandExtraArgs cmd- badArg = "Bad argument: `" ++ unwords extra ++- "'\n" ++ getCommandMiniHelp msuper cmd- missingArg = "Missing argument: " ++ nthArg (length extra + 1) ++- "\n" ++ getCommandMiniHelp msuper cmd- nthArg n = nthOf n (commandExtraArgHelp cmd)- nthOf 1 (h:_) = h- nthOf n (_:hs) = nthOf (n-1) hs- nthOf _ [] = "UNDOCUMENTED"--addCommandDefaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag]-addCommandDefaults cmd already = do- let (opts1, opts2) = commandAlloptions cmd- defaults <- getDefaultFlags (commandName cmd) (opts1 ++ opts2) already- return $ already ++ defaults--getOptionsOptions :: [OptDescr DarcsFlag] -> String-getOptionsOptions = intercalate "\n" . concatMap goo- where- goo (Option _ os _ _) = map ("--"++) os--runRawSupercommand :: DarcsCommand -> [String] -> IO ()-runRawSupercommand super [] =- fail $ "Command '"++ commandName super ++"' requires subcommand!\n\n"- ++ subusage super-runRawSupercommand super args = do- cwd <- getCurrentDirectory- case getOpt RequireOrder- (optionFromDarcsOption cwd help++- optionFromDarcsOption cwd listOptions) args of- (opts,_,[])- | Help `elem` opts ->- viewDoc $ text $ getCommandHelp Nothing super- | ListOptions `elem` opts -> do- putStrLn "--help"- mapM_ (putStrLn . commandName) (extractCommands $ getSubcommands super)- | otherwise ->- if Disable `elem` opts- then fail $ "Command " ++ (commandName super) ++- " disabled with --disable option!"- else fail $ "Invalid subcommand!\n\n" ++ subusage super- (_,_,ermsgs) -> fail $ chompNewline(unlines ermsgs)
− src/Darcs/SelectChanges.hs
@@ -1,904 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, ForeignFunctionInterface #-}--#include "gadts.h"--module Darcs.SelectChanges (selectChanges, WhichChanges(..), viewChanges, withSelectedPatchFromRepo,- filterOutConflicts, runSelection, selectionContextPrim,- selectionContext- ) where-import Data.List ( intersperse )-import Data.Maybe ( isJust, isNothing )-import Data.Char ( toUpper )-import Control.Monad ( when, (>=>) )-import Control.Monad.Identity ( Identity(..) )-import Control.Monad.Trans ( liftIO )-import Control.Monad.Reader ( ReaderT, Reader, asks, runReader, runReaderT )-import Control.Monad.State ( StateT, modify, gets, runStateT, execStateT )-import System.Exit ( exitWith, ExitCode(ExitSuccess) )--import English ( Noun(..), englishNum )-import Darcs.Arguments ( showFriendly )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, n2pia )-import Darcs.Repository ( Repository, readRepo, unrecordedChanges )-import Darcs.Patch ( RepoPatch, Patchy, PrimPatch, summary,- invert, listTouchedFiles,- commuteFLorComplain, fromPrims, anonymous )-import Darcs.Patch.Set ( newset2RL )-import Darcs.Patch.Apply( ApplyState )-import qualified Darcs.Patch ( thing, things )-import Darcs.Patch.Split ( Splitter(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:||:)(..),- (+>+), lengthFL, mapFL_FL,- spanFL, spanFL_M, reverseFL, (+<+), mapFL, filterFL )-import Darcs.Witnesses.WZipper( FZipper(..), left, right- , rightmost, nullFZ- , toEnd, toStart)-import Darcs.Patch.Choices ( PatchChoices, patchChoices,- patchChoicesTpsSub,- forceFirst, forceLast, makeUncertain, tag,- getChoices, refineChoices,- separateFirstFromMiddleLast,- patchSlot',- selectAllMiddles,- forceMatchingLast,- forceMatchingFirst, makeEverythingLater,- makeEverythingSooner,- TaggedPatch, tpPatch, Slot(..),- substitute- )-import Darcs.Patch.Permutations ( partitionConflictingFL, selfCommuter, commuterIdRL )-import qualified Darcs.Patch.TouchesFiles as TouchesFiles-import Darcs.PrintPatch ( printFriendly, printPatch, printPatchPager )-import Darcs.Match ( haveNonrangeMatch, matchAPatch, matchAPatchread )-import Darcs.Flags ( DarcsFlag( Summary, DontGrabDeps, Verbose, DontPromptForDependencies- , SkipConflicts )- , isInteractive, UseIndex(..), ScanKnown(..) )-import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal, seal2, unseal2, Sealed(..), Sealed2(..) )-import Darcs.Utils ( askUser, promptChar, PromptConfig(..) )-import Darcs.Lock ( editText )-import Printer ( prefix, putDocLn )-import Storage.Hashed.Tree( Tree )---- | When asking about patches, we either ask about them in--- oldest-first or newest first (with respect to the current ordering--- of the repository), and we either want an initial segment or a--- final segment of the poset of patches.------ @First@: ask for an initial--- segment, first patches first (default for all pull-like commands)------ @FirstReversed@: ask for an initial segment, last patches first--- (used to ask about dependencies in record, and for pull-like--- commands with the @--reverse@ flag).------ @LastReversed@: ask for a final segment, last patches first. (default--- for unpull-like commands, except for selecting *primitive* patches in--- rollback)------ @Last@: ask for a final segment, first patches first. (used for selecting--- primitive patches in rollback, and for unpull-like commands with the--- @--reverse@ flag-data WhichChanges = Last | LastReversed | First | FirstReversed deriving (Eq, Show)---- | A @WhichChanges@ is backwards if the order in which patches are presented--- is the opposite of the order of dependencies for that operation.-backward :: WhichChanges -> Bool-backward w = w == Last || w == FirstReversed---- | The type of the function we use to filter patches when @--match@ is--- given.-type MatchCriterion p = WhichChanges -> [DarcsFlag] -> Sealed2 p -> Bool---- | A @PatchSelectionContext@ contains all the static settings for selecting--- patches. See "PatchSelectionM"-data PatchSelectionContext p = PSC { opts :: [DarcsFlag]- , splitter :: Maybe (Splitter p)- , files :: Maybe [FilePath]- , matchCriterion :: MatchCriterion p- , jobname :: String- , pristine :: Maybe (Tree IO)}---- | A 'PatchSelectionContext' for selecting 'Prim' patches.-selectionContextPrim :: PrimPatch prim => String -> [DarcsFlag] -> Maybe (Splitter prim)- -> Maybe [FilePath] -> Maybe (Tree IO) -> PatchSelectionContext prim-selectionContextPrim jn o spl fs p =- PSC { opts = o- , splitter = spl- , files = fs- , matchCriterion = triv- , jobname = jn- , pristine = p }---- | A 'PatchSelectionContext' for selecting full patches ('PatchInfoAnd' patches)-selectionContext :: (RepoPatch p) => String -> [DarcsFlag] -> Maybe (Splitter (PatchInfoAnd p))- -> Maybe [FilePath] -> PatchSelectionContext (PatchInfoAnd p)-selectionContext jn o spl fs =- PSC { opts = o- , splitter = spl- , files = fs- , matchCriterion = iswanted- , jobname = jn- , pristine = Nothing }---- | The dynamic parameters for interactive selection of patches.-data InteractiveSelectionContext p C(x y) = ISC { total :: Int- -- ^ total number of patches- , current :: Int- -- ^ number of already-seen patches- , tps :: FZipper (TaggedPatch p) C(x y)- -- ^ the patches we offer- , choices :: PatchChoices p C(x y)- -- ^ the user's choices- }--type PatchSelectionM p a = ReaderT (PatchSelectionContext p) a--type InteractiveSelectionM p C(x y) a =- StateT (InteractiveSelectionContext p C(x y))- (PatchSelectionM p IO) a--type PatchSelection p C(x y) =- PatchSelectionM p IO ((FL p :> FL p) C(x y))---- Common match criteria---- | For commands without @--match@, 'triv' matches all patches-triv :: MatchCriterion p-triv = \ _ _ _ -> True---- | 'iswanted' selects patches according to the @--match@ flag in--- opts'-iswanted :: Patchy p => MatchCriterion (PatchInfoAnd p)-iswanted whch opts' =- unseal2 (iw whch)- where- iw First = matchAPatch opts' . hopefully- iw Last = matchAPatch opts' . hopefully- iw LastReversed = matchAPatch opts' . hopefully . invert- iw FirstReversed = matchAPatch opts' . hopefully . invert--liftR :: Monad m => Reader r a -> ReaderT r m a-liftR = asks . runReader---- | runs a 'PatchSelection' action in the given 'PatchSelectionContext'.-runSelection :: (Patchy p) => PatchSelection p C(x y) -> PatchSelectionContext p- -> IO ((FL p :> FL p) C(x y))-runSelection = runReaderT---- | Select patches from a @FL@.-selectChanges :: forall p C(x y) . (Patchy p, ApplyState p ~ Tree) =>- WhichChanges -> FL p C(x y)- -> PatchSelection p C(x y)-selectChanges First = sc1 First-selectChanges Last = sc1 Last-selectChanges FirstReversed = return . invert- >=> sc1 FirstReversed- >=> return . invertC--selectChanges LastReversed = return . invert- >=> sc1 LastReversed- >=> return . invertC--sc1 :: forall p C(x y) . (Patchy p, ApplyState p ~ Tree) =>- WhichChanges -> FL p C(x y)- -> PatchSelection p C(x y)-sc1 whch =- ((liftR . patchesToConsider whch)- >=> realSelectChanges whch- >=> return . selectedPatches whch- >=> (liftR . canonizeAfterSplitter))---- | inverses the choices that have been made-invertC :: (Patchy p) => (FL p :> FL p) C(x y) -> (FL p :> FL p) C(y x)-invertC (a :> b) = (invert b) :> (invert a)---- | Shows the patch that is actually being selected the way the user--- should see it.-repr :: (Patchy p) => WhichChanges -> Sealed2 p -> Sealed2 p-repr First (Sealed2 p) = Sealed2 p-repr LastReversed (Sealed2 p) = Sealed2 (invert p)-repr Last (Sealed2 p) = Sealed2 p-repr FirstReversed (Sealed2 p) = Sealed2 (invert p)---- | The equivalent of 'selectChanges' for the @darcs changes@ command-viewChanges :: (Patchy p, ApplyState p ~ Tree) => [DarcsFlag] -> [Sealed2 p] -> IO ()-viewChanges opts' ps = textView opts' Nothing 0 [] ps---- | The type of the answers to a "shall I [wiggle] that [foo]?" question--- They are found in a [[KeyPress]] bunch, each list representing a set of--- answers which belong together-data KeyPress = KeyPress { kp :: Char- , kpHelp :: String }---- | Generates the help for a set of basic and advanced 'KeyPress' groups.-helpFor :: String -> [[KeyPress]] -> [[KeyPress]] -> String-helpFor jn basicKeypresses advancedKeyPresses =- unlines $ [ "How to use "++jn++":" ]- ++ (concat $ intersperse [""] $ map (map help) keypresses)- ++ [ ""- , "?: show this help"- , ""- , "<Space>: accept the current default (which is capitalized)"- ]- where help i = kp i:(": "++kpHelp i)- keypresses = basicKeypresses ++ advancedKeyPresses---- | The keys used by a list of 'keyPress' groups.-keysFor :: [[KeyPress]] -> [Char]-keysFor = concatMap (map kp)---- | The function for selecting a patch to amend record. Read at your own risks.-withSelectedPatchFromRepo ::- forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree)- => String -- name of calling command (always "amend" as of now)- -> Repository p C(r u t)- -> [DarcsFlag]- -> (FORALL(a) (FL (PatchInfoAnd p) :> PatchInfoAnd p) C(a r) -> IO ())- -> IO ()-withSelectedPatchFromRepo jn repository o job = do- patchSet <- readRepo repository- sp <- wspfr jn (matchAPatchread o) (newset2RL patchSet) NilFL- case sp of- Just (FlippedSeal (skipped :> selected')) -> job (skipped :> selected')- Nothing ->- putStrLn $ "Cancelling " ++ jn ++ " since no patch was selected."---- | This ensures that the selected patch commutes freely with the skipped--- patches, including pending and also that the skipped sequences has an--- ending context that matches the recorded state, z, of the repository.-wspfr :: (RepoPatch p, ApplyState p ~ Tree)- => String- -> (FORALL(a b) (PatchInfoAnd p) C(a b) -> Bool)- -> RL (PatchInfoAnd p) C(x y)- -> FL (PatchInfoAnd p) C(y u)- -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd p) :> (PatchInfoAnd p)) C(u)))-wspfr _ _ NilRL _ = return Nothing-wspfr jn matches remaining@(p:<:pps) skipped- | not $ matches p = wspfr jn matches pps (p:>:skipped)- | otherwise =- case commuteFLorComplain (p :> skipped) of- Left _ -> do putStrLn "\nSkipping depended-upon patch:"- printFriendly Nothing [] p- wspfr jn matches pps (p:>:skipped)- Right (skipped' :> p') -> do- printFriendly Nothing [] p- yorn <- promptChar $- PromptConfig { pPrompt = prompt'- , pBasicCharacters = keysFor basicOptions- , pAdvancedCharacters = keysFor advancedOptions- , pDefault = Just 'n'- , pHelp = "?h" }- case yorn of- 'y' -> return $ Just $ flipSeal $ skipped' :> p'- 'n' -> nextPatch- 'j' -> nextPatch- 'k' -> case skipped of- NilFL -> repeatThis- (prev :>: skipped') -> wspfr jn matches (prev :<: remaining) skipped'- 'v' -> printPatch p >> repeatThis- 'p' -> printPatchPager p >> repeatThis- 'x' -> do putDocLn $ prefix " " $ summary p- repeatThis- 'q' -> do putStrLn $ jnCapital ++ " cancelled."- exitWith $ ExitSuccess- _ -> do putStrLn $ helpFor jn basicOptions advancedOptions- repeatThis- where jnCapital = (toUpper $ head jn) : tail jn- repeatThis = wspfr jn matches (p:<:pps) skipped- prompt' = "Shall I " ++ jn ++ " this patch?"- nextPatch = wspfr jn matches pps (p:>:skipped)- basicOptions =- [[ KeyPress 'y' (jn ++ " this patch")- , KeyPress 'n' ("don't " ++ jn ++ " it")- , KeyPress 'j' "skip to next patch"- , KeyPress 'k' "back up to previous patch"- ]]- advancedOptions =- [[ KeyPress 'v' "view this patch in full"- , KeyPress 'p' "view this patch in full with pager"- , KeyPress 'x' "view a summary of this patch"- , KeyPress 'q' ("cancel " ++ jn)- ]]---- After selecting with a splitter, the results may not be canonical-canonizeAfterSplitter :: (FL p :> FL p) C(x y) -> Reader (PatchSelectionContext p) ((FL p :> FL p) C(x y))-canonizeAfterSplitter (x :> y) =- do mspl <- asks splitter- let canonizeIfNeeded = maybe id canonizeSplit mspl- return $ canonizeIfNeeded x :> canonizeIfNeeded y--realSelectChanges :: forall p C(x y). (Patchy p, ApplyState p ~ Tree)- => WhichChanges- -> PatchChoices p C(x y)- -> PatchSelectionM p IO (PatchChoices p C(x y))-realSelectChanges whch autoChoices =- do- o <- asks opts- if not $ isInteractive o- then return $ promote autoChoices- else refineChoices (textSelect whch) autoChoices- where forward = not $ backward whch- promote = if forward- then makeEverythingSooner- else makeEverythingLater---- | When using @--match@, remove unmatched patches not depended upon by matched--- patches.-deselectUnwanted :: forall p C(x y) . Patchy p => WhichChanges ->- PatchChoices p C(x y) ->- Reader (PatchSelectionContext p) (PatchChoices p C(x y))-deselectUnwanted whichch pc =- do- o <- asks opts- c <- asks matchCriterion- let iswanted_ = c whichch o . seal2 . tpPatch- select = if forward- then forceMatchingFirst iswanted_- else forceMatchingLast iswanted_- deselect = if forward- then forceMatchingLast (not . iswanted_)- else forceMatchingFirst (not . iswanted_)- return $- if haveNonrangeMatch o- then if DontGrabDeps `elem` o- then deselect pc- else demote $ select pc- else pc- where- forward = not $ backward whichch- demote = if forward- then makeEverythingLater- else makeEverythingSooner---- | Selects the patches matching the match criterion, and puts them first or last--- according to whch, while respecting any dependencies.-patchesToConsider :: (Patchy p, ApplyState p ~ Tree)- => WhichChanges- -> FL p C(x y)- -> Reader (PatchSelectionContext p) (PatchChoices p C(x y))-patchesToConsider whch ps =- do- fs <- asks files- o <- asks opts- let deselectNotTouching =- case whch of- First -> TouchesFiles.deselectNotTouching- Last -> TouchesFiles.selectNotTouching- FirstReversed -> TouchesFiles.selectNotTouching- LastReversed -> TouchesFiles.deselectNotTouching- everything = patchChoices ps- if isNothing fs && not (haveNonrangeMatch o)- then return everything- else do notUnwanted <- deselectUnwanted whch everything- return $ deselectNotTouching fs notUnwanted---- | Returns the results of a patch selection user interaction-selectedPatches :: Patchy p => WhichChanges -> PatchChoices p C(y z)- -> (FL p :> FL p) C(y z)-selectedPatches Last pc =- case getChoices pc of- fc :> mc :> lc -> mapFL_FL tpPatch (fc +>+ mc) :> mapFL_FL tpPatch lc--selectedPatches First pc =- case separateFirstFromMiddleLast pc of- xs :> ys -> mapFL_FL tpPatch xs :> mapFL_FL tpPatch ys--selectedPatches LastReversed pc =- case separateFirstFromMiddleLast pc of- xs :> ys -> mapFL_FL tpPatch (xs) :> (mapFL_FL tpPatch (ys))--selectedPatches FirstReversed pc =- case getChoices pc of- fc :> mc :> lc -> (mapFL_FL tpPatch (fc +>+ mc)) :> (mapFL_FL tpPatch lc)---- | Runs a function on the underlying @PatchChoices@ object-liftChoices :: forall p a C(x y) . Patchy p =>- StateT (PatchChoices p C(x y)) Identity a- -> InteractiveSelectionM p C(x y) a-liftChoices act = do- ch <- gets choices- let (result, _) = runIdentity $ runStateT act ch- modify $ \isc -> isc {choices = ch} -- Should this be ch or the result of runState?- return result---- | @justDone n@ notes that @n@ patches have just been processed-justDone :: Patchy p => Int -> InteractiveSelectionM p C(x y) ()-justDone n = modify $ \isc -> isc{ current = current isc + n}---- | The actual interactive selection process.-textSelect :: forall p C(x y) . (Patchy p, ApplyState p ~ Tree) => WhichChanges ->- FL (TaggedPatch p) C(x y) -> PatchChoices p C(x y)- -> PatchSelectionM p IO (PatchChoices p C(x y))-textSelect whch tps' pcs = do- userSelection <- execStateT (skipMundane whch >>- showCur whch >>- textSelectIfAny) $- ISC { total = lengthFL tps'- , current = 0- , tps = FZipper NilRL tps'- , choices = pcs }- return $ choices userSelection- where textSelectIfAny = do- z <- gets tps- if rightmost z- then return ()- else textSelect' whch--textSelect' :: (Patchy p, ApplyState p ~ Tree) => WhichChanges ->- InteractiveSelectionM p C(x y) ()-textSelect' whch = do- z <- gets tps- when (not $ rightmost z) $- do- textSelectOne whch- textSelect' whch--optionsBasic :: [Char] -> [Char] -> [KeyPress]-optionsBasic jn aThing =- [ KeyPress 'y' (jn++" this "++aThing)- , KeyPress 'n' ("don't "++jn++" it")- , KeyPress 'w' ("wait and decide later, defaulting to no") ]--optionsFile :: [Char] -> [KeyPress]-optionsFile jn =- [ KeyPress 's' ("don't "++jn++" the rest of the changes to this file")- , KeyPress 'f' (jn++" the rest of the changes to this file") ]--optionsView :: String -> String -> [KeyPress]-optionsView aThing someThings =- [ KeyPress 'v' ("view this "++aThing++" in full")- , KeyPress 'p' ("view this "++aThing++" in full with pager")- , KeyPress 'l' ("list all selected "++someThings) ]--optionsSummary :: String -> [KeyPress]-optionsSummary aThing =- [ KeyPress 'x' ("view a summary of this "++aThing) ]--optionsQuit :: String -> String -> [KeyPress]-optionsQuit jn someThings =- [ KeyPress 'd' (jn++" selected "++someThings++", skipping all the remaining "++someThings)- , KeyPress 'a' (jn++" all the remaining "++someThings)- , KeyPress 'q' ("cancel "++jn) ]--optionsNav :: String -> [KeyPress]-optionsNav aThing =- [ KeyPress 'j' ("skip to next "++ aThing)- , KeyPress 'k' ("back up to previous "++ aThing)- , KeyPress 'g' ("start over from the first "++aThing)]--optionsSplit :: Maybe (Splitter a) -> String -> [KeyPress]-optionsSplit split aThing- | Just _ <- split- = [ KeyPress 'e' ("interactively edit this "++ aThing) ]- | otherwise = []--options :: forall p C(x y) . (Patchy p) => Bool ->- InteractiveSelectionM p C(x y) ([[KeyPress]],[[KeyPress]])-options single = do- split <- asks splitter- jn <- asks jobname- aThing <- thing- someThings <- things- o <- asks opts- return $- ([optionsBasic jn aThing]- ,[optionsSplit split aThing]- ++ (if single then- [optionsFile jn ] else [])- ++ [optionsView aThing someThings ++- if Summary `elem` o then []- else optionsSummary aThing]- ++ [optionsQuit jn someThings]- ++ [optionsNav aThing]- )---- | Returns a @Sealed2@ version of the patch we are asking the user--- about.-currentPatch :: forall p C(x y) . Patchy p =>- InteractiveSelectionM p C(x y)- (Maybe (Sealed2 (TaggedPatch p)))-currentPatch = do- (FZipper _ tps_todo) :: FZipper (TaggedPatch p) C(x y) <- gets tps- case tps_todo of- NilFL -> return Nothing- (tp:>:_) -> return $ Just (Sealed2 tp)---- | Returns the patches we have yet to ask the user about.-todo :: forall p C(x y) . Patchy p- => InteractiveSelectionM p C(x y)- (FlippedSeal (FL (TaggedPatch p)) C(y))-todo = do- (FZipper _ tps_todo) <- gets tps- return (FlippedSeal tps_todo)---- | Modify the underlying @PatchChoices@ by some function-modChoices :: forall p C(x y) . Patchy p =>- (PatchChoices p C(x y) -> PatchChoices p C(x y))- -> InteractiveSelectionM p C(x y) ()-modChoices f = modify $ \isc -> isc{choices = f $ choices isc}---- | returns @Just f@ if the 'currentPatch' only modifies @f@,--- @Nothing@ otherwise.-currentFile :: forall p C(x y) . Patchy p- => InteractiveSelectionM p C(x y) (Maybe FilePath)-currentFile = do- c <- currentPatch- return $ case c of- Nothing -> Nothing- Just (Sealed2 tp) ->- case listTouchedFiles tp of- [f] -> Just f- _ -> Nothing---- | @decide True@ selects the current patch, and @decide False@ deselects--- it.-decide :: forall p C(x y t u) . Patchy p => WhichChanges -> Bool- -> TaggedPatch p C(t u)- -> InteractiveSelectionM p C(x y) ()-decide whch takeOrDrop tp =- if backward whch == takeOrDrop -- we go backward xor we are dropping- then modChoices $ forceLast (tag tp)- else modChoices $ forceFirst (tag tp)---- | like 'decide', but for all patches touching @file@-decideWholeFile :: forall p C(x y). Patchy p => WhichChanges ->- FilePath -> Bool -> InteractiveSelectionM p C(x y) ()-decideWholeFile whch file takeOrDrop =- do- FlippedSeal tps_todo <- todo- let patches_to_skip =- filterFL (\tp' -> listTouchedFiles tp' == [file]) tps_todo- mapM_ (unseal2 $ decide whch takeOrDrop) patches_to_skip---- | Undecide the current patch.-postponeNext :: forall p C(x y) . Patchy p => InteractiveSelectionM p C(x y) ()-postponeNext =- do- Just (Sealed2 tp) <- currentPatch- modChoices $ makeUncertain (tag tp)---- | Focus the next patch.-skipOne :: forall p C(x y) . Patchy p => InteractiveSelectionM p C(x y) ()-skipOne = modify so- where so x = x{tps = right (tps x), current = current x +1}---- | Focus the previous patch.-backOne :: forall p C(x y) . Patchy p => InteractiveSelectionM p C(x y) ()-backOne = modify so- where so isc = isc{tps = left (tps isc), current = max (current isc-1) 0}---- | Split the current patch (presumably a hunk), and add the replace it--- with its parts.-splitCurrent :: forall p C(x y) . Patchy p => Splitter p- -> InteractiveSelectionM p C(x y) ()-splitCurrent s = do- FZipper tps_done (tp:>:tps_todo) <- gets tps- case (applySplitter s (tpPatch tp)) of- Nothing -> return ()- Just (text, parse) ->- do- newText <- liftIO $ editText "darcs-patch-edit" text- case parse newText of- Nothing -> return ()- Just ps -> do- tps_new <- liftIO . return . snd- $ patchChoicesTpsSub (Just (tag tp)) ps- modify $ \isc -> isc { total = ( total isc- + lengthFL tps_new - 1 )- , tps = (FZipper tps_done- (tps_new +>+ tps_todo))- , choices = (substitute- (seal2 (tp :||: tps_new))- (choices isc))- }---- | Returns a list of the currently selected patches, in--- their original context, i.e., not commuted past unselected--- patches.-selected :: forall p C(x y). Patchy p => WhichChanges ->- InteractiveSelectionM p C(x y) [Sealed2 p]-selected whichch = do- c <- gets choices- (first_chs :> _ :> last_chs) <- return $ getChoices c- return $ if backward whichch- then- mapFL (repr whichch . Sealed2 . tpPatch) $ last_chs- else- mapFL (repr whichch . Sealed2 . tpPatch) $ first_chs---- | Prints the list of the selected patches. See 'selected'.-printSelected :: Patchy p => WhichChanges ->- InteractiveSelectionM p C(x y) ()-printSelected whichch = do- someThings <- things- o <- asks opts- s <- selected whichch- liftIO $ do- putStrLn $ "---- Already selected "++someThings++" ----"- mapM_ (putDocLn . unseal2 (showFriendly o)) s- putStrLn $ "---- end of already selected "++someThings++" ----"--printSummary :: forall p C(x y) . Patchy p => p C(x y) -> IO ()-printSummary =- putDocLn . prefix " " . summary---- | Skips all remaining patches.-skipAll :: forall p C(x y) . Patchy p =>- InteractiveSelectionM p C(x y) ()-skipAll = do- modify $ \isc -> isc {tps = toEnd $ tps isc}--backAll :: forall p C(x y) . Patchy p =>- InteractiveSelectionM p C(x y) ()-backAll = do- modify $ \isc -> isc {tps = toStart $ tps isc- ,current = 0}--isSingleFile :: Patchy p => p C(x y) -> Bool-isSingleFile p = length (listTouchedFiles p) == 1--askConfirmation :: forall p C(x y) . Patchy p =>- InteractiveSelectionM p C(x y) ()-askConfirmation = do- jn <- asks jobname- liftIO $ if jn `elem` ["unpull", "unrecord", "obliterate"]- then do- yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? "- case yorn of- ('y':_) -> return ()- _ -> exitWith $ ExitSuccess- else return ()---- | The singular form of the noun for items of type @p@.-thing :: Patchy p => InteractiveSelectionM p C(x y) String-thing = gets choices >>= return . Darcs.Patch.thing . helper- where- helper :: PatchChoices p C(a b) -> p C(a b)- helper = undefined---- | The plural form of the noun for items of type @p@.-things :: Patchy p => InteractiveSelectionM p C(x y) String-things = gets choices >>= return . Darcs.Patch.things . helper- where- helper :: PatchChoices p C(a b) -> p C(a b)- helper = undefined---- | The question to ask about one patch.-prompt :: Patchy p => InteractiveSelectionM p C(x y) String-prompt = do- jn <- asks jobname- aThing <- thing- n <- gets current- n_max <- gets total- return $ "Shall I "++jn++" this "++aThing++"? "- ++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ") "---- | Asks the user about one patch, returns their answer.-promptUser :: forall p C(x y) . Patchy p => Bool -> Char- -> InteractiveSelectionM p C(x y) Char-promptUser single def = do- thePrompt <- prompt- (basicOptions,advancedOptions) <- options single- liftIO $ promptChar $ PromptConfig { pPrompt = thePrompt- , pBasicCharacters = keysFor basicOptions- , pAdvancedCharacters = keysFor advancedOptions- , pDefault = Just def- , pHelp = "?h"- }---- | Ask the user what to do with the next patch.-textSelectOne :: forall p C(x y). (Patchy p, ApplyState p ~ Tree) => WhichChanges- -> InteractiveSelectionM p C(x y) ()-textSelectOne whichch = do- c <- currentPatch- case c of- Nothing -> return ()- Just (Sealed2 tp) ->- do- jn <- asks jobname- spl <- asks splitter- let singleFile = isSingleFile (tpPatch tp)- reprCur = repr whichch (Sealed2 (tpPatch tp))- (basicOptions,advancedOptions) <- options singleFile- theSlot <- liftChoices $ patchSlot' tp- let- the_default = getDefault (whichch == Last || whichch == FirstReversed) theSlot- jnCapital = (toUpper $ head jn) : tail jn- yorn <- promptUser singleFile the_default- let nextPatch = skipMundane whichch >> showCur whichch- case yorn of- 'y' -> decide whichch True tp >> skipOne >> nextPatch- 'n' -> decide whichch False tp >> skipOne >> nextPatch- 'w' -> postponeNext >> skipOne >> nextPatch- 'e' | (Just s) <- spl -> splitCurrent s >> showCur whichch- 's' -> currentFile >>= maybe- (return ())- (\f -> decideWholeFile whichch f False) >> nextPatch- 'f' -> currentFile >>= maybe- (return ())- (\f -> decideWholeFile whichch f True) >> nextPatch- 'v' -> liftIO $ unseal2 printPatch reprCur- 'p' -> liftIO $ unseal2 printPatchPager reprCur- 'l' -> printSelected whichch >> showCur whichch- 'x' -> liftIO $ unseal2 printSummary reprCur- 'd' -> skipAll- 'g' -> backAll >> showCur whichch- 'a' ->- do- askConfirmation- modChoices $ selectAllMiddles (whichch == Last || whichch == FirstReversed)- skipAll- 'q' -> liftIO $- do putStrLn $ jnCapital++" cancelled."- exitWith $ ExitSuccess- 'j' -> skipOne >> showCur whichch- 'k' -> backOne >> showCur whichch- _ -> do- liftIO . putStrLn $ helpFor jn basicOptions advancedOptions---- | Shows the current patch as it should be seen by the user.-showCur :: forall p C(x y) . (Patchy p, ApplyState p ~ Tree) => WhichChanges- -> InteractiveSelectionM p C(x y) ()-showCur whichch = do- o <- asks opts- p <- asks pristine- c <- currentPatch- case c of- Nothing -> return ()- Just (Sealed2 tp) -> do- let reprCur = repr whichch (Sealed2 (tpPatch tp))- liftIO . (unseal2 (printFriendly p o)) $ reprCur---- | The interactive part of @darcs changes@-textView :: forall p . (Patchy p, ApplyState p ~ Tree) => [DarcsFlag] -> Maybe Int -> Int- -> [Sealed2 p] -> [Sealed2 p]- -> IO ()-textView _ _ _ _ [] = return ()-textView o n_max n- ps_done ps_todo@(p:ps_todo') = do- unseal2 (printFriendly Nothing o) p- repeatThis -- prompt the user- where- prev_patch :: IO ()- prev_patch = case ps_done of- [] -> repeatThis- (p':ps_done') ->- textView o- n_max (n-1) ps_done' (p':ps_todo)- next_patch :: IO ()- next_patch = case ps_todo' of- [] -> -- May as well work out the length now we have all- -- the patches in memory- textView o n_max- n ps_done []- _ -> textView o n_max- (n+1) (p:ps_done) ps_todo'- first_patch = textView o n_max 0 [] (ps_done++ps_todo)- options_yn =- [ KeyPress 'y' "view this patch and go to the next"- , KeyPress 'n' "skip to the next patch" ]- optionsView' =- [ KeyPress 'v' "view this patch in full"- , KeyPress 'p' "view this patch in full with pager" ]- optionsSummary' =- [ KeyPress 'x' "view a summary of this patch" ]- optionsNav' =- [ KeyPress 'q' "quit view changes"- , KeyPress 'k' "back up to previous patch"- , KeyPress 'j' "skip to next patch"- , KeyPress 'g' "start over from the first patch"- , KeyPress 'c' "count total patch number" ]- basicOptions = [ options_yn ]- advancedOptions =- [ optionsView' ++- if Summary `elem` o then [] else optionsSummary' ]- ++ [ optionsNav' ]- prompt' = "Shall I view this patch? "- ++ "(" ++ show (n+1) ++ "/" ++ maybe "?" show n_max ++ ")"- repeatThis :: IO ()- repeatThis = do- yorn <- promptChar (PromptConfig prompt' (keysFor basicOptions) (keysFor advancedOptions) (Just 'n') "?h")- case yorn of- 'y' -> unseal2 printPatch p >> next_patch- 'n' -> next_patch- 'v' -> unseal2 printPatch p >> repeatThis- 'p' -> unseal2 printPatchPager p >> repeatThis- 'x' -> do putDocLn $ prefix " " $ unseal2 summary p- repeatThis- 'q' -> exitWith ExitSuccess- 'k' -> prev_patch- 'j' -> next_patch- 'g' -> first_patch- 'c' -> textView o- count_n_max n ps_done ps_todo- _ -> do putStrLn $ helpFor "view changes" basicOptions advancedOptions- repeatThis- count_n_max | isJust n_max = n_max- | otherwise = Just $ length ps_done + length ps_todo---- | Skips patches we should not ask the user about-skipMundane :: Patchy p => WhichChanges ->- InteractiveSelectionM p C(x y) ()-skipMundane whichch = do- (FZipper tps_done tps_todo) <- gets tps- o <- asks opts- crit <- asks matchCriterion- jn <- asks jobname- (skipped :> unskipped) <- liftChoices $ spanFL_M- (patchSlot' >=> return . decided)- tps_todo- let numSkipped = lengthFL skipped- when (numSkipped > 0) . liftIO $ show_skipped o jn numSkipped skipped- let boringThenInteresting =- if DontPromptForDependencies `elem` o- then spanFL (not.(crit whichch o) . seal2 . tpPatch) $- unskipped- else NilFL :> unskipped- case boringThenInteresting of- boring :> interesting ->- do- justDone $ lengthFL boring + numSkipped- modify $ \isc -> isc {tps = (FZipper (reverseFL boring +<+ reverseFL skipped +<+ tps_done) interesting)}- where- show_skipped o jn n ps = do putStrLn $ _nevermind_ jn ++ _these_ n ++ "."- when (Verbose `elem` o) $- showskippedpatch ps- _nevermind_ jn = "Will not ask whether to " ++ jn ++ " "- _these_ n = show n ++ " already decided " ++ _elem_ n ""- _elem_ n = englishNum n (Noun "patch")- showskippedpatch :: Patchy p => FL (TaggedPatch p) C(y t) -> IO ()- showskippedpatch =- sequence_ . mapFL (printSummary . tpPatch)--decided :: Slot -> Bool-decided InMiddle = False-decided _ = True---- | The action bound to space, depending on the current status of the--- patch.-getDefault :: Bool -> Slot -> Char-getDefault _ InMiddle = 'w'-getDefault True InFirst = 'n'-getDefault True InLast = 'y'-getDefault False InFirst = 'y'-getDefault False InLast = 'n'---- |Optionally remove any patches (+dependencies) from a sequence that--- conflict with the recorded or unrecorded changes in a repo-filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree)- => [DarcsFlag] -- ^Command-line options. Only 'SkipConflicts' is- -- significant; filtering will happen iff it is present- -> RL (PatchInfoAnd p) C(x t) -- ^Recorded patches from repository, starting from- -- same context as the patches to filter- -> Repository p C(r u t) -- ^Repository itself, used for grabbing unrecorded changes- -> FL (PatchInfoAnd p) C(x z) -- ^Patches to filter- -> IO (Bool, Sealed (FL (PatchInfoAnd p) C(x))) -- ^(True iff any patches were removed, possibly filtered patches)-filterOutConflicts o us repository them- | SkipConflicts `elem` o- = do let commuter = commuterIdRL selfCommuter- unrec <- fmap n2pia . (anonymous . fromPrims)- =<< unrecordedChanges (UseIndex, ScanKnown) repository Nothing- them' :> rest <- return $ partitionConflictingFL commuter them (unrec :<: us)- return (check rest, Sealed them')- | otherwise- = return (False, Sealed them)- where check :: FL p C(a b) -> Bool- check NilFL = False- check _ = True
− src/Darcs/SignalHandler.hs
@@ -1,151 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, DeriveDataTypeable #-}--module Darcs.SignalHandler ( withSignalsHandled, withSignalsBlocked,- catchInterrupt, catchNonSignal,- tryNonSignal, stdoutIsAPipe ) where--import Prelude hiding ( catch )--import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName )-import System.Exit ( exitWith, ExitCode ( ExitFailure ) )-import Control.Concurrent ( ThreadId, myThreadId )-import Control.Exception.Extensible- ( catch, throw, throwTo,- Exception(..), SomeException(..), IOException )-#if (MIN_VERSION_base(4,4,0))-import Control.Exception.Extensible ( mask )-#else-import Control.Exception.Extensible ( block, unblock )-#endif-import System.Posix.Files ( getFdStatus, isNamedPipe )-import System.Posix.IO ( stdOutput )-import Data.Typeable ( Typeable, cast )-import Data.List ( isPrefixOf )-import System.IO ( hPutStrLn, stderr )-import Control.Monad ( when )--import Workaround ( installHandler, raiseSignal, Handler(..), Signal,- sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE )-#ifdef WIN32-import CtrlC ( withCtrlCHandler )-#endif--#if !(MIN_VERSION_base(4,4,0))-mask f = block (f unblock)-#endif--stdoutIsAPipe :: IO Bool-stdoutIsAPipe- = catch- (do stat <- getFdStatus stdOutput- return (isNamedPipe stat))- (\(_ :: IOException) -> return False)--withSignalsHandled :: IO a -> IO a-newtype SignalException = SignalException Signal deriving (Show, Typeable)--instance Exception SignalException where- toException e = SomeException e- fromException (SomeException e) = cast e--withSignalsHandled job = do- thid <- myThreadId- mapM_ (ih thid) [sigINT, sigHUP, sigABRT, sigTERM, sigPIPE]- catchUserErrors (job' thid `catchSignal` defaults)- die_with_string- where defaults s | s == sigINT = ew s "Interrupted!"- | s == sigHUP = ew s "HUP"- | s == sigABRT = ew s "ABRT"- | s == sigTERM = ew s "TERM"- | s == sigPIPE = exitWith $ ExitFailure $ 1- | otherwise = ew s "Unhandled signal!"- ew sig s = do hPutStrLn stderr $ ("withSignalsHandled: " ++ s)- resethandler sig- raiseSignal sig -- ensure that our caller knows how we died- exitWith $ ExitFailure $ 1- die_with_string e | "STDOUT" `isPrefixOf` e =- do is_pipe <- stdoutIsAPipe- when (not is_pipe) $- hPutStrLn stderr $ "\ndarcs failed: "++drop 6 e- exitWith $ ExitFailure $ 2- die_with_string e = do hPutStrLn stderr $ "\ndarcs failed: "++e- exitWith $ ExitFailure $ 2-#ifdef WIN32- job' thid =- withCtrlCHandler (throwTo thid $ SignalException sigINT) job-#else- job' _ = job-#endif--resethandler :: Signal -> IO ()--- Warning: A do-notation statement discarded a result of type Handler.-resethandler s = do _ <- installHandler s Default Nothing- return ()--ih :: ThreadId -> Signal -> IO ()-ih thid s =--- Warning: A do-notation statement discarded a result of type Handler.- do _ <- installHandler s (Catch $ throwTo thid $ SignalException s) Nothing- return ()--catchSignal :: IO a -> (Signal -> IO a) -> IO a-catchSignal job handler =- job `catch` (\(SignalException sig) -> handler sig)---- catchNonSignal is a drop-in replacement for Control.Exception.catch, which allows--- us to catch anything but a signal. Useful for situations where we want--- don't want to inhibit ctrl-C.--catchNonSignal :: IO a -> (SomeException -> IO a) -> IO a-catchNonSignal comp handler = catch comp handler'- where handler' se =- case fromException se :: Maybe SignalException of- Nothing -> handler se- Just _ -> throw se--catchInterrupt :: IO a -> IO a -> IO a-catchInterrupt job handler =- job `catchSignal` h- where h s | s == sigINT = handler- | otherwise = throw (SignalException s)--tryNonSignal :: IO a -> IO (Either SomeException a)-tryNonSignal j = (Right `fmap` j) `catchNonSignal` \e -> return (Left e)--catchUserErrors :: IO a -> (String -> IO a) -> IO a-catchUserErrors comp handler = catch comp handler'- where handler' ioe- | isUserError ioe = handler (ioeGetErrorString ioe)- | ioeGetFileName ioe == Just "<stdout>" = handler ("STDOUT" ++ ioeGetErrorString ioe)- | otherwise = throw ioe--withSignalsBlocked :: IO a -> IO a-withSignalsBlocked job = mask (\unmask -> job >>= \r ->- unmask (return r) `catchSignal` couldnt_do r)- where couldnt_do r s | s == sigINT = oops "interrupt" r- | s == sigHUP = oops "HUP" r- | s == sigABRT = oops "ABRT" r- | s == sigALRM = oops "ALRM" r- | s == sigTERM = oops "TERM" r- | s == sigPIPE = return r- | otherwise = oops "unknown signal" r- oops s r = do hPutStrLn stderr $ "Couldn't handle " ++ s ++- " since darcs was in a sensitive job."- return r
− src/Darcs/Ssh.hs
@@ -1,231 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}---- |--- Module : Darcs.Ssh--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module Darcs.Ssh- (- copySSH- , SSHCmd(..)- , getSSH- , environmentHelpSsh- , environmentHelpScp- , environmentHelpSshPort- , remoteDarcs- ) where---import Prelude hiding ( lookup, catch )--import qualified Ratified ( hGetContents )--import System.Environment ( getEnv )-import System.Exit ( ExitCode(..) )--import Control.Monad ( when )--import qualified Data.ByteString as B (ByteString, hGet, writeFile )--import Data.Map ( Map, empty, insert, lookup )-import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )--import System.IO ( Handle, hSetBinaryMode, hPutStrLn, hGetLine, hFlush )-import System.IO.Unsafe ( unsafePerformIO )-import System.Process ( runInteractiveProcess )--import Darcs.SignalHandler ( catchNonSignal )-import Darcs.Flags( RemoteDarcs(..) )-import Darcs.Global ( defaultSsh, SshSettings)-import Darcs.URL (SshFilePath(..), urlOf)-import Darcs.Utils ( breakCommand, prettyException, catchall )-import Exec ( exec, Redirect(..), )-import Progress ( withoutProgress, debugMessage, debugFail )--import qualified Darcs.Global as Settings---sshConnections :: IORef (Map String (Maybe Connection))-sshConnections = unsafePerformIO $ newIORef empty-{-# NOINLINE sshConnections #-}---data Connection = C- { inp :: !Handle- , out :: !Handle- , err :: !Handle- , deb :: String -> IO ()- }----- | @withSSHConnection rdarcs repoid withconnection withoutconnection@--- performs an action on a remote host. If we are already connected to @repoid @,--- then it does @withconnection@, else @withoutconnection@.-withSSHConnection :: String -- ^ rdarcs- -> SshFilePath -- ^ Destination repo id- -> (Connection -> IO a) -- ^ withconnection- -> IO a -- ^ withoutconnection- -> IO a-withSSHConnection rdarcs repoid withconnection withoutconnection =- withoutProgress $- do cs <- readIORef sshConnections- case lookup (sshUhost repoid) (cs :: Map String (Maybe Connection)) of- Just Nothing -> withoutconnection- Just (Just c) -> withconnection c- Nothing ->- do mc <- do (ssh,sshargs_) <- getSSH SSH- let sshargs = sshargs_ ++ [sshUhost repoid, rdarcs,- "transfer-mode","--repodir",sshRepo repoid]- debugMessage $ unwords (ssh : sshargs)- (i,o,e,_) <- runInteractiveProcess ssh sshargs Nothing Nothing- hSetBinaryMode i True- hSetBinaryMode o True- l <- hGetLine o- if l == "Hello user, I am darcs transfer mode"- then return ()- else debugFail "Couldn't start darcs transfer-mode on server"- let c = C { inp = i, out = o, err = e,- deb = \s -> debugMessage ("with ssh (transfer-mode) " ++ sshUhost repoid ++ " " ++ s) }- modifyIORef sshConnections (insert (sshUhost repoid) (Just c))- return $ Just c- `catchNonSignal`- \e -> do debugMessage $ "Failed to start ssh connection:\n "++- prettyException e- severSSHConnection repoid- debugMessage $ unlines $- [ "NOTE: the server may be running a version of darcs prior to 2.0.0."- , ""- , "Installing darcs 2 on the server will speed up ssh-based commands."- ]- return Nothing- maybe withoutconnection withconnection mc--severSSHConnection :: SshFilePath- -> IO ()-severSSHConnection x = do- debugMessage $ "Severing ssh failed connection to " ++ (sshUhost x)- modifyIORef sshConnections (insert (urlOf x) Nothing)---grabSSH :: SshFilePath -> Connection -> IO B.ByteString-grabSSH dest c = do- debugMessage $ "grabSSH dest=" ++ urlOf dest- let failwith e = do severSSHConnection dest- -- hGetContents is ok here because we're- -- only grabbing stderr, and we're also- -- about to throw the contents.- eee <- Ratified.hGetContents (err c)- debugFail $ e ++ " grabbing ssh file "++- urlOf dest++"/"++ file ++"\n"++eee- file = sshFile dest- deb c $ "get "++ file- hPutStrLn (inp c) $ "get " ++ file- hFlush (inp c)- l2 <- hGetLine (out c)- if l2 == "got "++file- then do showlen <- hGetLine (out c)- case reads showlen of- [(len,"")] -> B.hGet (out c) len- _ -> failwith "Couldn't get length"- else if l2 == "error "++file- then do e <- hGetLine (out c)- case reads e of- (msg,_):_ -> debugFail $ "Error reading file remotely:\n"++msg- [] -> failwith "An error occurred"- else failwith "Error"--remoteDarcs :: RemoteDarcs- -> String-remoteDarcs DefaultRemoteDarcs = "darcs"-remoteDarcs (RemoteDarcs x) = x---copySSH :: RemoteDarcs- -> SshFilePath- -> FilePath- -> IO ()-copySSH remote dest to | rdarcs <- remoteDarcs remote = do- debugMessage $ "copySSH file: " ++ urlOf dest- withSSHConnection rdarcs dest (\c -> grabSSH dest c >>= B.writeFile to) $ do- let u = escape_dollar $ urlOf dest- (scp, args) <- getSSH SCP- r <- exec scp (args ++ [u, to]) (AsIs,AsIs,AsIs)- when (r /= ExitSuccess) $- debugFail $ "(scp) failed to fetch: " ++ u- where- -- '$' in filenames is troublesome for scp, for some reason.- escape_dollar :: String -> String- escape_dollar = concatMap tr- where- tr '$' = "\\$"- tr c = [c]----- ------------------------------------------------------------------------ older ssh helper functions--- -----------------------------------------------------------------------data SSHCmd = SSH- | SCP- | SFTP---fromSshCmd :: SshSettings- -> SSHCmd- -> String-fromSshCmd s SSH = Settings.ssh s-fromSshCmd s SCP = Settings.scp s-fromSshCmd s SFTP = Settings.sftp s----- | Return the command and arguments needed to run an ssh command--- First try the appropriate darcs environment variable and SSH_PORT--- defaulting to "ssh" and no specified port.-getSSH :: SSHCmd- -> IO (String, [String])-getSSH cmd = do- port <- (portFlag cmd `fmap` getEnv "SSH_PORT") `catchall` return []- let (ssh, ssh_args) = breakCommand command- return (ssh, ssh_args ++ port)- where- command = fromSshCmd defaultSsh cmd- portFlag SSH x = ["-p", x]- portFlag SCP x = ["-P", x]- portFlag SFTP x = ["-oPort=" ++ x]---environmentHelpSsh :: ([String], [String])-environmentHelpSsh = (["DARCS_SSH"], [- "Repositories of the form [user@]host:[dir] are taken to be remote",- "repositories, which Darcs accesses with the external program ssh(1).",- "",- "The environment variable $DARCS_SSH can be used to specify an",- "alternative SSH client. Arguments may be included, separated by",- "whitespace. The value is not interpreted by a shell, so shell",- "constructs cannot be used; in particular, it is not possible for the",- "program name to contain whitespace by using quoting or escaping."])---environmentHelpScp :: ([String], [String])-environmentHelpScp = (["DARCS_SCP", "DARCS_SFTP"], [- "When reading from a remote repository, Darcs will attempt to run",- "`darcs transfer-mode' on the remote host. This will fail if the",- "remote host only has Darcs 1 installed, doesn't have Darcs installed",- "at all, or only allows SFTP.",- "",- "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).",- "The commands invoked can be customized with the environment variables",- "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.",- "If the remote end allows only sftp, try setting DARCS_SCP=sftp."])---environmentHelpSshPort :: ([String], [String])-environmentHelpSshPort = (["SSH_PORT"], [- "If this environment variable is set, it will be used as the port",- "number for all SSH calls made by Darcs (when accessing remote",- "repositories over SSH). This is useful if your SSH server does not",- "run on the default port, and your SSH client does not support",- "ssh_config(5). OpenSSH users will probably prefer to put something",- "like `Host *.example.net Port 443' into their ~/.ssh/config file."])
− src/Darcs/Test.hs
@@ -1,95 +0,0 @@--- Copyright (C) 2002-2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Test ( getTest,- runPosthook, runPrehook )-where-import Darcs.RepoPath ( AbsolutePath )-import Darcs.Utils ( withCurrentDirectory )-import System.Exit ( ExitCode(..) )-import System.Cmd ( system )-import Control.Monad ( when )--import Darcs.Arguments ( DarcsFlag( Quiet,- AskPosthook, AskPrehook ),- getPosthookCmd, getPrehookCmd )-import Darcs.Repository.Prefs ( getPrefval )-import Darcs.Utils ( askUser )-import System.IO ( hPutStrLn, stderr )--getTest :: [DarcsFlag] -> IO (IO ExitCode)-getTest opts =- let putInfo s = when (not $ Quiet `elem` opts) $ putStr s- in do- testline <- getPrefval "test"- return $- case testline of- Nothing -> return ExitSuccess- Just testcode -> do- putInfo "Running test...\n"- ec <- system testcode- if ec == ExitSuccess- then putInfo "Test ran successfully.\n"- else putInfo "Test failed!\n"- return ec--runPosthook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode-runPosthook opts repodir = do ph <- getPosthook opts- withCurrentDirectory repodir $ runHook opts "Posthook" ph--getPosthook :: [DarcsFlag] -> IO (Maybe String)-getPosthook opts = case getPosthookCmd opts of- Nothing -> return Nothing- Just command ->- if AskPosthook `elem` opts- then do putStr ("\nThe following command is set to execute.\n"++- "Execute the following command now (yes or no)?\n"++- command++"\n")- yorn <- askUser ""- case yorn of ('y':_) -> return $ Just command- _ -> do putStrLn "Posthook cancelled..."- return Nothing- else return $ Just command--runPrehook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode-runPrehook opts repodir = do ph <- getPrehook opts- withCurrentDirectory repodir $ runHook opts "Prehook" ph--getPrehook :: [DarcsFlag] -> IO (Maybe String)-getPrehook opts = case getPrehookCmd opts of- Nothing -> return Nothing- Just command ->- if AskPrehook `elem` opts- then do putStr ("\nThe following command is set to execute.\n"++- "Execute the following command now (yes or no)?\n"++- command++"\n")- yorn <- askUser ""- case yorn of ('y':_) -> return $ Just command- _ -> do putStrLn "Prehook cancelled..."- return Nothing- else return $ Just command--runHook :: [DarcsFlag] -> String -> Maybe String -> IO ExitCode-runHook _ _ Nothing = return ExitSuccess-runHook opts cname (Just command) =- do ec <- system command- when (Quiet `notElem` opts) $- if ec == ExitSuccess- then putStrLn $ cname++" ran successfully."- else hPutStrLn stderr $ cname++" failed!"- return ec-
− src/Darcs/Test/Email.hs
@@ -1,93 +0,0 @@--- Copyright (C) 2002-2005,2007 David Roundy--- Copyright (C) 2009 Reinier Lamers------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- | This module contains unit tests of the code in 'Darcs.Email'------ These tests check whether the emails generated by darcs meet a few criteria.--- We check for line length and non-ASCII characters. We apparently do not have--- to check for CR-LF newlines because that's handled by sendmail.-module Darcs.Test.Email ( testSuite ) where-import Data.Char ( isPrint )-import qualified Data.ByteString as B ( length, unpack, null, head,- cons, empty, foldr, ByteString )-import qualified Data.ByteString.Char8 as BC ( unpack )-import Test.Framework ( Test, testGroup )-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Printer ( text, renderPS )-import Darcs.Email ( makeEmail, readEmail, formatHeader )--testSuite :: Test-testSuite = testGroup "Darcs.Email"- [ emailParsing- , emailHeaderNoLongLines- , emailHeaderAsciiChars- , emailHeaderLinesStart- , emailHeaderNoEmptyLines- ]---- | Checks that darcs can read the emails it generates-emailParsing :: Test-emailParsing = testProperty "Checking that email can be parsed" $ \s ->- unlines ("":s++["", ""]) ==- BC.unpack (readEmail (renderPS- $ makeEmail "reponame" [] (Just (text "contents\n"))- Nothing- (text $ unlines s) (Just "filename")))---- | Check that formatHeader never creates lines longer than 78 characters--- (excluding the carriage return and line feed)-emailHeaderNoLongLines :: Test-emailHeaderNoLongLines =- testProperty "Checking email header line length" $ \field value ->- let cleanField = cleanFieldString field- in not $ any (>78) $ map B.length $ bsLines $ formatHeader cleanField value---- Check that an email header does not contain non-ASCII characters--- formatHeader doesn't escape field names, there is no such thing as non-ascii--- field names afaik-emailHeaderAsciiChars :: Test-emailHeaderAsciiChars =- testProperty "Checking email for illegal characters" $ \field value ->- let cleanField = cleanFieldString field- in not (any (>127) (B.unpack (formatHeader cleanField value)))---- Check that header the second and later lines of a header start with a space-emailHeaderLinesStart :: Test-emailHeaderLinesStart =- testProperty "Checking for spaces at start of folded email header lines" $ \field value ->- let headerLines = bsLines (formatHeader cleanField value)- cleanField = cleanFieldString field- in all (\l -> B.null l || B.head l == 32) (tail headerLines)---- Checks that there are no lines in email headers with only whitespace-emailHeaderNoEmptyLines :: Test-emailHeaderNoEmptyLines =- testProperty "Checking that there are no empty lines in email headers" $ \field value ->- let headerLines = bsLines (formatHeader cleanField value)- cleanField = cleanFieldString field- in all (not . B.null) headerLines --(not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines--bsLines :: B.ByteString -> [B.ByteString]-bsLines = finalizeFold . B.foldr splitAtLines (B.empty, [])- where splitAtLines 10 (thisLine, prevLines) = (B.empty, thisLine:prevLines)- splitAtLines c (thisLine, prevLines) = (B.cons c thisLine, prevLines)- finalizeFold (lastLine, otherLines) = lastLine : otherLines--cleanFieldString :: String -> String-cleanFieldString = filter (\c -> isPrint c && c < '\x80' && c /= ':')-
− src/Darcs/Test/Misc.hs
@@ -1,107 +0,0 @@--- Copyright (C) 2002-2005,2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Test.Misc ( testSuite ) where--import ByteStringUtils ( unpackPSFromUTF8, fromHex2PS, fromPS2Hex )-import qualified Data.ByteString.Char8 as BC ( unpack, pack )-import qualified Data.ByteString as B ( concat, empty )-import Lcs ( shiftBoundaries )-import Data.Array.Base-import Control.Monad.ST-import Test.HUnit ( assertBool, assertEqual, assertFailure )-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.Framework.Providers.HUnit ( testCase )-import Test.Framework ( Test, testGroup )--#include "gadts.h"--testSuite :: Test-testSuite = testGroup ""- [ byteStringUtilsTestSuite- , lcsTestSuite- ]----- ------------------------------------------------------------------------- * ByteStringUtils--- Here are a few quick tests of the shiftBoundaries function.--- ------------------------------------------------------------------------byteStringUtilsTestSuite :: Test-byteStringUtilsTestSuite = testGroup "ByteStringUtils"- [ testCase "UTF-8 packing and unpacking preserves 'hello world'"- (assertBool "" (unpackPSFromUTF8 (BC.pack "hello world") == "hello world"))- , testCase "Checking that hex packing and unpacking preserves 'hello world'"- (assertEqual "" (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world"))- "hello world")- , testProperty "Checking that B.concat works" propConcatPS- , testProperty "Checking that hex conversion works" propHexConversion- ]--propHexConversion :: String -> Bool-propHexConversion s =- fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s--propConcatPS :: [String] -> Bool-propConcatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss)---- ------------------------------------------------------------------------- * LCS--- Here are a few quick tests of the shiftBoundaries function.--- ------------------------------------------------------------------------lcsTestSuite :: Test-lcsTestSuite = testGroup "LCS"- [ testCase "lcs code" (mapM_ assertFailure showLcsTests)- ]--showLcsTests :: [String]-showLcsTests = concatMap checkKnownShifts knownShifts-checkKnownShifts :: ([Int],[Int],String,String,[Int],[Int])- -> [String]-checkKnownShifts (ca, cb, sa, sb, ca', cb') = runST (- do ca_arr <- newListArray (0, length ca) $ toBool (0:ca)- cb_arr <- newListArray (0, length cb) $ toBool (0:cb)- let p_a = listArray (0, length sa) $ B.empty:(toPS sa)- p_b = listArray (0, length sb) $ B.empty:(toPS sb)- shiftBoundaries ca_arr cb_arr p_a 1 1- shiftBoundaries cb_arr ca_arr p_b 1 1- ca_res <- fmap (fromBool . tail) $ getElems ca_arr- cb_res <- fmap (fromBool . tail) $ getElems cb_arr- return $ if ca_res == ca' && cb_res == cb' then []- else ["shiftBoundaries failed on "++sa++" and "++sb++" with "- ++(show (ca,cb))++" expected "++(show (ca', cb'))- ++" got "++(show (ca_res, cb_res))++"\n"])- where toPS = map (\c -> if c == ' ' then B.empty else BC.pack [c])- toBool = map (>0)- fromBool = map (\b -> if b then 1 else 0)--knownShifts :: [([Int],[Int],String,String,[Int],[Int])]-knownShifts =- [([0,0,0],[0,1,0,1,0],"aaa","aaaaa",- [0,0,0],[0,0,0,1,1]),- ([0,1,0],[0,1,1,0],"cd ","c a ",- [0,1,0],[0,1,1,0]),- ([1,0,0,0,0,0,0,0,0],[1,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","dg{} ih{} if{}",- [1,0,0,0,0,0,0,0,0],[1,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end- ([0,0,0,0,0,0,0,0,0],[0,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","fg{} ih{} if{}",- [0,0,0,0,0,0,0,0,0],[0,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end- ([],[1,1],"","aa",[],[1,1]),- ([1,1],[],"aa","",[1,1],[])]
− src/Darcs/Test/Patch.hs
@@ -1,370 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-#if __GLASGOW_HASKELL__ >= 700-{-# LANGUAGE ImpredicativeTypes #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE AllowAmbiguousTypes #-}-#endif--- Copyright (C) 2002-2005,2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Test.Patch ( testSuite ) where--import Data.Maybe( isNothing )-import Test.Framework ( Test, testGroup )-import Test.Framework.Providers.HUnit ( testCase )-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.QuickCheck.Arbitrary( Arbitrary )-import Test.QuickCheck( Testable )-import Test.HUnit ( assertBool )--import Darcs.Test.Util.TestResult ( TestResult, isOk, fromMaybe )-import Darcs.Test.Patch.Utils ( testConditional )--import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq ( unsafeCompare )-import Darcs.Witnesses.Show-import Darcs.Patch.Prim( PrimPatch, join, FromPrim, PrimOf, PrimPatchBase )-import Darcs.Patch.Prim.Class( PrimCanonize )-import qualified Darcs.Patch.Prim.V1 as V1 ( Prim )-import qualified Darcs.Patch.Prim.V3 as V3 ( Prim )-import qualified Darcs.Patch.V1 as V1-import Darcs.Patch.V2.Real ( isConsistent, isForward, RealPatch )-import Darcs.Patch.RepoPatch( RepoPatch )-import Darcs.Patch.Patchy ( Commute(..), Patchy )-import Darcs.Patch.Merge( Merge )-import Darcs.Patch.Apply( ApplyState )--import Darcs.Test.Patch.Arbitrary.Generic-import qualified Darcs.Test.Patch.Arbitrary.PrimV1 as P1-import qualified Darcs.Test.Patch.Arbitrary.PrimV3 as P3-import Darcs.Test.Patch.Arbitrary.Real-import Darcs.Test.Patch.Arbitrary.PatchV1 ()-import Darcs.Test.Patch.Arbitrary.PrimV1 ()-import Darcs.Test.Patch.RepoModel-import Darcs.Test.Patch.V3Model( V3Model )-import Darcs.Test.Patch.V1Model( V1Model )-import Darcs.Test.Patch.WithState( WithState, wsPatch, WithStartState )--import qualified Darcs.Test.Patch.Info--import qualified Darcs.Test.Patch.Examples.Set1 as Ex-import qualified Darcs.Test.Patch.Examples.Set2Unwitnessed as ExU--import Darcs.Test.Patch.Properties.Check( Check(..), checkAPatch )-import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop-import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop-import qualified Darcs.Test.Patch.Properties.Generic as Prop-import qualified Darcs.Test.Patch.Properties.Real as Prop-import qualified Darcs.Test.Patch.Properties.GenericUnwitnessed as PropU--import qualified Darcs.Test.Patch.WSub as WSub--#include "gadts.h"--type instance ModelOf (FL prim) = ModelOf prim--#if __GLASGOW_HASKELL__ >= 700-type TestGenerator thing gen = (FORALL(t ctx) ((FORALL(xx yy) thing xx yy -> t) -> (gen ctx -> t)))-type TestCondition thing = (FORALL (yy zz) thing C(yy zz) -> Bool)-type TestCheck thing t = (FORALL (yy zz) thing C(yy zz) -> t)---- arbitraryThing :: (FORALL(xx yy) thing C(xx yy) -> t) -> (thing C(a b) -> t)-arbitraryThing :: x -> TestGenerator thing (thing x)-arbitraryThing _ f p = f p-#endif---- | Run a test function on a set of data, using HUnit. The test function should--- return @Nothing@ upon success and a @Just x@ upon failure.-testCases :: Show a => String -- ^ The test name- -> (a -> TestResult) -- ^ The test function- -> [a] -- ^ The test data- -> Test-testCases name test datas = testCase name (assertBool assertName res)- where assertName = "Boolean assertion for \"" ++ name ++ "\""- res = and $ map (isOk . test) datas--unit_V1P1:: [Test]-unit_V1P1 =- [ testCases "known commutes" Prop.checkCommute Ex.knownCommutes- , testCases "known non-commutes" Prop.checkCantCommute Ex.knownCantCommutes- , testCases "known merges" Prop.checkMerge Ex.knownMerges- , testCases "known merges (equiv)" Prop.checkMergeEquiv Ex.knownMergeEquivs- , testCases "known canons" Prop.checkCanon Ex.knownCanons- , testCases "merge swaps" Prop.checkMergeSwap Ex.mergePairs2- , testCases "the patch validation works" Prop.tTestCheck Ex.validPatches- , testCases "commute/recommute" (Prop.recommute commute) Ex.commutePairs- , testCases "merge properties: merge either way valid" Prop.tMergeEitherWayValid Ex.mergePairs- , testCases "merge properties: merge swap" Prop.mergeEitherWay Ex.mergePairs- , testCases "primitive patch IO functions" (Prop.tShowRead eqFLUnsafe) Ex.primitiveTestPatches- , testCases "IO functions (test patches)" (Prop.tShowRead eqFLUnsafe) Ex.testPatches- , testCases "IO functions (named test patches)" (Prop.tShowRead unsafeCompare) Ex.testPatchesNamed- , testCases "primitive commute/recommute" (Prop.recommute commute) Ex.primitiveCommutePairs- ]--unit_V2P1 :: [Test]-unit_V2P1 =- [ testCases "join commute" (PropU.joinCommute WSub.join) ExU.primPermutables- , testCases "prim recommute" (PropU.recommute WSub.commute) ExU.commutables- , testCases "prim patch and inverse commute" (PropU.patchAndInverseCommute WSub.commute) ExU.commutables- , testCases "prim inverses commute" (PropU.commuteInverses WSub.commute) ExU.commutables- , testCases "FL prim recommute" (PropU.recommute WSub.commute) ExU.commutablesFL- , testCases "FL prim patch and inverse commute" (PropU.patchAndInverseCommute WSub.commute) ExU.commutablesFL- , testCases "FL prim inverses commute" (PropU.commuteInverses WSub.commute) $ ExU.commutablesFL- , testCases "fails" (PropU.commuteFails WSub.commute) ([] :: [(V1.Prim WSub.:> V1.Prim) C(x y)])- , testCases "read and show work on Prim" PropU.show_read ExU.primPatches- , testCases "read and show work on RealPatch" PropU.show_read ExU.realPatches- , testCases "example flattenings work" PropU.consistentTreeFlattenings ExU.realPatchLoopExamples- , testCases "real merge input consistent" (PropU.mergeArgumentsConsistent isConsistent) ExU.realMergeables- , testCases "real merge input is forward" (PropU.mergeArgumentsConsistent isForward) ExU.realMergeables- , testCases "real merge output is forward" (PropU.mergeConsistent isForward) ExU.realMergeables- , testCases "real merge output consistent" (PropU.mergeConsistent isConsistent) ExU.realMergeables- , testCases "real merge either way" PropU.mergeEitherWay ExU.realMergeables- , testCases "real merge and commute" PropU.mergeCommute ExU.realMergeables-- , testCases "real recommute" (PropU.recommute WSub.commute) ExU.realCommutables- , testCases "real inverses commute" (PropU.commuteInverses WSub.commute) ExU.realCommutables- , testCases "real permutivity" (PropU.permutivity WSub.commute) ExU.realNonduplicateTriples- , testCases "real partial permutivity" (PropU.partialPermutivity WSub.commute) ExU.realNonduplicateTriples- ]--instance PrimPatch prim => Check (RealPatch prim) where- checkPatch p = return $ isNothing $ isConsistent p--instance Check V3.Prim where- checkPatch _ = return True -- XXX--commuteReals :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y) -> Maybe ((RealPatch prim :> RealPatch prim) C(x y))-commuteReals = commute--qc_prim :: forall prim C(x y a) model.- (PrimPatch prim, ArbitraryPrim prim, Show2 prim- , model ~ ModelOf prim, RepoModel model- , RepoState model ~ ApplyState (PrimOf prim)- , Show1 (ModelOf prim)- , Check prim, PrimPatchBase prim, PrimOf prim ~ prim- , FromPrim prim- , Show1 (prim C(a))- , Show1 ((prim :> prim) C(a))- , Show1 (WithState model prim C(a))- , Arbitrary (Sealed ((prim :> prim) C(a)))- , Arbitrary (Sealed ((prim :> prim :> prim) C(a)))- , Arbitrary (Sealed (prim C(a)))- , Arbitrary (Sealed (FL prim C(a)))- , Arbitrary (Sealed ((FL prim :> FL prim) C(a)))- , Arbitrary (Sealed (WithState model prim C(a)))- , Arbitrary (Sealed (WithState model (FL prim) C(a)))- , Arbitrary (Sealed2 (WithState model (prim :> prim)))- , Arbitrary (Sealed ((WithState model (prim :> prim)) C(a)))- , Arbitrary (Sealed ((WithState model (FL prim :> FL prim)) C(a)))- ) => prim C(x y) -> [Test]-qc_prim _ =- -- The following fails because of setpref patches...- -- testProperty "prim inverse doesn't commute" (inverseDoesntCommute :: Prim -> Maybe Doc)- [ testProperty "prim join effect preserving... "- (unseal2 $ Prop.joinEffectPreserving join :: Sealed2 (WithState model (prim :> prim)) -> TestResult)- ]-#if __GLASGOW_HASKELL__ >= 700- ++ concat- [ pair_properties (undefined :: prim C(x y)) "arbitrary" arbitraryThing'- , pair_properties (undefined :: FL prim C(x y)) "arbitrary FL" arbitraryThing'- , coalesce_properties (undefined :: prim C(x y)) "arbitrary" arbitraryThing'- , nonreal_commute_properties (undefined :: prim C(x y)) "arbitrary" arbitraryThing'- , nonreal_commute_properties (undefined :: FL prim C(x y)) "arbitrary FL" arbitraryThing'- , patch_properties (undefined :: prim C(x a)) "arbitrary" arbitraryThing'- , patch_properties (undefined :: FL prim C(x a)) "arbitrary FL" arbitraryThing'- , patch_repo_properties (undefined :: prim C(x a)) "arbitrary" arbitraryThing'- , patch_repo_properties (undefined :: FL prim C(x a)) "arbitrary FL" arbitraryThing'- , pair_repo_properties (undefined :: prim C(x a)) "arbitrary" arbitraryThing'- , pair_repo_properties (undefined :: FL prim C(x a)) "arbitrary FL" arbitraryThing'- ]- where arbitraryThing' = arbitraryThing (undefined :: a) -- bind the witness for generator-#endif--qc_V2P1 :: [Test]-qc_V2P1 =- [ testProperty "tree flattenings are consistent... "- Prop.propConsistentTreeFlattenings- , testProperty "with quickcheck that real patches are consistent... "- (unseal $ P1.patchFromTree $ fromMaybe . isConsistent)- -- permutivity ----------------------------------------------------------------------------- , testConditional "permutivity"- (unseal $ P1.commuteTripleFromTree notDuplicatestriple)- (unseal $ P1.commuteTripleFromTree $ Prop.permutivity commuteReals)- , testConditional "partial permutivity"- (unseal $ P1.commuteTripleFromTree notDuplicatestriple)- (unseal $ P1.commuteTripleFromTree $ Prop.partialPermutivity commuteReals)- , testConditional "nontrivial permutivity"- (unseal $ P1.commuteTripleFromTree (\t -> nontrivialTriple t && notDuplicatestriple t))- (unseal $ P1.commuteTripleFromTree $ (Prop.permutivity commuteReals))- ]--qc_V2 :: forall prim C(xx yy a). (PrimPatch prim, Show1 (ModelOf prim), RepoModel (ModelOf prim),- Check (RealPatch prim), ArbitraryPrim prim, Show2 prim,- RepoState (ModelOf prim) ~ ApplyState prim)- => prim C(xx yy) -> [Test]-qc_V2 _ =- [ testProperty "readPatch and showPatch work on RealPatch... "- (unseal $ patchFromTree $ (Prop.show_read :: RealPatch prim C(x y) -> TestResult))- , testProperty "readPatch and showPatch work on FL RealPatch... "- (unseal2 $ (Prop.show_read :: FL (RealPatch prim) C(x y) -> TestResult))- , testProperty "we can do merges using QuickCheck"- (isNothing . (Prop.propIsMergeable ::- Sealed (WithStartState (ModelOf prim) (Tree prim))- -> Maybe (Tree (RealPatch prim) C(x))))- ]-#if __GLASGOW_HASKELL__ >= 700- ++ concat- [ merge_properties (undefined :: RealPatch prim C(x y)) "tree" mergePairFromTree- , merge_properties (undefined :: RealPatch prim C(x y)) "twfp" mergePairFromTWFP- , pair_properties (undefined :: RealPatch prim C(x y)) "tree" commutePairFromTree- , pair_properties (undefined :: RealPatch prim C(x y)) "twfp" commutePairFromTWFP- , patch_properties (undefined :: RealPatch prim C(x y)) "tree" patchFromTree- -- , patch_repo_properties (undefined :: RealPatch prim C(x y)) "tree" arbitraryThing'- ]- where arbitraryThing' = arbitraryThing (undefined :: a)-#endif--#if __GLASGOW_HASKELL__ >= 700-properties :: forall thing gen. (Show1 gen, Arbitrary (Sealed gen)) =>- TestGenerator thing gen- -- -> forall xx yy. thing xx yy- -> String -> String- -> forall t. Testable t => [(String, TestCondition thing, TestCheck thing t)]- -> [Test]-properties gen prefix genname tests =- [ cond name condition check | (name, condition, check) <- tests ]- where cond :: forall testable. Testable testable- => String -> TestCondition thing -> TestCheck thing testable -> Test- cond t c p =- testConditional (prefix ++ " (" ++ genname ++ "): " ++ t) (unseal $ gen c) (unseal $ gen p)--type PropList what gen = String -> TestGenerator what gen -> [Test]--pair_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p)- => p x y -> PropList (p :> p) gen-pair_properties _ genname gen =- properties gen "commute" genname- [ ("recommute" , const True , Prop.recommute commute )- , ("nontrivial recommute" , nontrivialCommute, Prop.recommute commute )- , ("inverses commute" , const True , Prop.commuteInverses commute )- , ("nontrivial inverses" , nontrivialCommute, Prop.commuteInverses commute )- , ("inverse composition" , const True , Prop.inverseComposition )- ]--coalesce_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, PrimPatch p)- => p x y -> PropList (p :> p :> p) gen-coalesce_properties _ genname gen =- properties gen "commute" genname- [ ("join commutes with commute", const True, Prop.joinCommute join) ]---- The following properties do not hold for "Real" patches (conflictors and--- duplicates, specifically) .-nonreal_commute_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p)- => p x y -> PropList (p :> p) gen-nonreal_commute_properties _ genname gen =- properties gen "commute" genname- [ ("patch & inverse commute", const True , Prop.patchAndInverseCommute commute)- , ("patch & inverse commute", nontrivialCommute, Prop.patchAndInverseCommute commute)- ]--patch_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p)- => p x y -> PropList p gen-patch_properties _ genname gen =- properties gen "patch" genname- [ ("inverse . inverse is id" , const True , Prop.invertSymmetry)- ]--patch_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p,- RepoModel (ModelOf (PrimOf p)),- RepoState (ModelOf (PrimOf p)) ~ ApplyState p)- => p x y -> PropList (WithState (ModelOf (PrimOf p)) p) gen-patch_repo_properties _ genname gen =- properties gen "patch/repo" genname- [ ("invert rollback" , const True , Prop.invertRollback)- ]--pair_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p,- RepoModel (ModelOf p),- RepoState (ModelOf p) ~ ApplyState p)- => p x y -> PropList (WithState (ModelOf p) (p :> p)) gen-pair_repo_properties _ genname gen =- properties gen "patch/repo" genname- [ ("commute is effect preserving" , const True , Prop.effectPreserving commute )- ]--merge_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen)- , Patchy p, Merge p, Show2 p, Check p)- => p x y -> PropList (p :\/: p) gen-merge_properties _ genname gen =- properties gen "merge" genname- [ ("merge either way" , const True , Prop.mergeEitherWay )- , ("merge either way valid" , const True , Prop.tMergeEitherWayValid)- , ("nontrivial merge either way", nontrivialMerge, Prop.mergeEitherWay )- , ("merge commute" , const True , Prop.mergeCommute )- ]-#endif--qc_V1P1 :: [Test]-qc_V1P1 =- [- testProperty "show and read work right" (unseal Prop.propReadShow)- ]- ++ Prop.checkSubcommutes Prop.subcommutesInverse "patch and inverse both commute"- ++ Prop.checkSubcommutes Prop.subcommutesNontrivialInverse "nontrivial commutes are correct"- ++ Prop.checkSubcommutes Prop.subcommutesFailure "inverses fail"- ++- [ testProperty "commuting by patch and its inverse is ok" Prop.propCommuteInverse- -- , testProperty "conflict resolution is valid... " Prop.propResolveConflictsValid- , testProperty "a patch followed by its inverse is identity"- Prop.propPatchAndInverseIsIdentity- , testProperty "'simple smart merge'" Prop.propSimpleSmartMergeGoodEnough- , testProperty "commutes are equivalent" Prop.propCommuteEquivalency- , testProperty "merges are valid" Prop.propMergeValid- , testProperty "inverses being valid" Prop.propInverseValid- , testProperty "other inverse being valid" Prop.propOtherInverseValid- -- The patch generator isn't smart enough to generate correct test cases for- -- the following: (which will be obsoleted soon, anyhow)- -- , testProperty "the order dependence of unravel... " Prop.propUnravelOrderIndependent- -- , testProperty "the unravelling of three merges... " Prop.propUnravelThreeMerge- -- , testProperty "the unravelling of a merge of a sequence... " Prop.propUnravelSeqMerge- , testProperty "the order of commutes" Prop.propCommuteEitherOrder- , testProperty "commute either way" Prop.propCommuteEitherWay- , testProperty "the double commute" Prop.propCommuteTwice- , testProperty "merges commute and are well behaved"- Prop.propMergeIsCommutableAndCorrect- , testProperty "merges can be swapped" Prop.propMergeIsSwapable- , testProperty "again that merges can be swapped (I'm paranoid) " Prop.propMergeIsSwapable-- ] -- the following properties are disabled, because they routinely lead to- -- exponential cases, making the tests run for ever and ever; nevertheless,- -- we would expect them to hold- {- ++ merge_properties (undefined :: V1.Patch Prim C(x y)) "tree" mergePairFromTree- ++ merge_properties (undefined :: V1.Patch Prim C(x y)) "twfp" mergePairFromTWFP- ++ commute_properties (undefined :: V1.Patch Prim C(x y)) "tree" commutePairFromTree- ++ commute_properties (undefined :: V1.Patch Prim C(x y)) "twfp" commutePairFromTWFP -}---- | This is the big list of tests that will be run using testrunner.-testSuite :: [Test]-testSuite = [ testGroup "Darcs.Patch.Prim.V1" $ qc_prim (undefined :: V1.Prim C(x y))- , testGroup "Darcs.Patch.V1 (using Prim.V1)" $ unit_V1P1 ++ qc_V1P1- , testGroup "Darcs.Patch.V2 (using Prim.V1)" $ unit_V2P1 ++ qc_V2 (undefined :: V1.Prim C(x y)) ++ qc_V2P1- , testGroup "Darcs.Patch.Prim.V3" $ qc_prim (undefined :: V3.Prim C(x y))- , testGroup "Darcs.Patch.V2 (using Prim.V3)" $ qc_V2 (undefined :: V3.Prim C(x y))- , Darcs.Test.Patch.Info.testSuite- ]
− src/Darcs/Test/Patch/Arbitrary/Generic.hs
@@ -1,231 +0,0 @@-{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-}-{-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses,- FlexibleInstances, ViewPatterns #-}--#include "gadts.h"-module Darcs.Test.Patch.Arbitrary.Generic- ( Tree(..), TreeWithFlattenPos(..), G2(..), ArbitraryPrim, NullPatch(..), RepoModel(..)- , flattenOne, flattenTree, mapTree, sizeTree- , commutePairFromTree, mergePairFromTree- , commuteTripleFromTree, mergePairFromCommutePair- , commutePairFromTWFP, mergePairFromTWFP, getPairs, getTriples- , patchFromTree- , canonizeTree- , quickCheck- ) where--import Control.Monad ( liftM )-import Test.QuickCheck-import Darcs.Test.Patch.WithState-import Darcs.Test.Patch.RepoModel-import Darcs.Test.Util.QuickCheck ( bSized )-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Unsafe-import Darcs.Witnesses.Ordered-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Patchy ( Invert(..), Commute(..) )-import Darcs.Patch.Prim ( PrimOf, PrimPatch, PrimPatchBase, FromPrim(..), PrimConstruct( anIdentity ) )-import Darcs.Patch.Prim.V1 ()-import Darcs.Patch.V2 ( RealPatch ) -- XXX this is more or less a hack---import Darcs.ColorPrinter ( errorDoc )---import Darcs.ColorPrinter ( traceDoc )-import Darcs.Witnesses.Show---import Printer ( greenText, ($$) )---- | Generate a patch to a certain state.-class ArbitraryStateIn s p where- arbitraryStateIn :: s C(x) -> Gen (p C(x))--data Tree p C(x) where- NilTree :: Tree p C(x)- SeqTree :: p C(x y) -> Tree p C(y) -> Tree p C(x)- ParTree :: Tree p C(x) -> Tree p C(x) -> Tree p C(x)--mapTree :: (FORALL(y z) p C(y z) -> q C(y z)) -> Tree p C(x) -> Tree q C(x)-mapTree _ NilTree = NilTree-mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t)-mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2)--instance Show2 p => Show (Tree p C(x)) where- showsPrec _ NilTree = showString "NilTree"- showsPrec d (SeqTree a t) = showParen (d > appPrec) $ showString "SeqTree " .- showsPrec2 (appPrec + 1) a . showString " " .- showsPrec (appPrec + 1) t- showsPrec d (ParTree t1 t2) = showParen (d > appPrec) $ showString "ParTree " .- showsPrec (appPrec + 1) t1 . showString " " .- showsPrec (appPrec + 1) t2--instance Show2 p => Show1 (Tree p) where- showDict1 = ShowDictClass--instance Show2 p => Show1 (TreeWithFlattenPos p) where- showDict1 = ShowDictClass--sizeTree :: Tree p C(x) -> Int-sizeTree NilTree = 0-sizeTree (SeqTree _ t) = 1 + sizeTree t-sizeTree (ParTree t1 t2) = 1 + sizeTree t1 + sizeTree t2---- newtype G1 l p C(x) = G1 { _unG1 :: l (p C(x)) }-newtype G2 l p C(x y) = G2 { unG2 :: l (p C(x y)) }--flattenTree :: (Merge p) => Tree p C(z) -> Sealed (G2 [] (FL p) C(z))-flattenTree NilTree = seal $ G2 $ return NilFL-flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t-flattenTree (ParTree (flattenTree -> Sealed gpss1) (flattenTree -> Sealed gpss2))- = seal $ G2 $- do ps1 <- unG2 gpss1- ps2 <- unG2 gpss2- ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2)- -- We can't prove that the existential type in the result- -- of merge will be the same for each pair of- -- ps1 and ps2.- map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1']--instance ArbitraryState s p => ArbitraryStateIn s (Tree p) where- -- Don't generate trees deeper than 6 with default QuickCheck size (0..99).- -- Note if we don't put a non-zero lower bound the first generated trees will always have depth 0.- arbitraryStateIn rm = bSized 3 0.035 9 $ \depth -> arbitraryTree rm depth---- | Generate a tree of patches, bounded by the depth @maxDepth@.-arbitraryTree :: ArbitraryState s p => s C(x) -> Int -> Gen (Tree p C(x))-arbitraryTree rm depth- | depth == 0 = return NilTree- -- Note a probability of N for NilTree would imply ~(100*N)% of empty trees.- -- For the purpose of this module empty trees are useless, but even when- -- NilTree case is omitted there is still a small percentage of empty trees- -- due to the generation of null-patches (empty-hunks) and the use of canonizeTree.- | otherwise = frequency [(1, do Sealed (WithEndState p rm') <- arbitraryState rm- t <- arbitraryTree rm' (depth - 1)- return (SeqTree p t))- ,(3, do t1 <- arbitraryTree rm (depth - 1)- t2 <- arbitraryTree rm (depth - 1)- return (ParTree t1 t2))]---class NullPatch p where- nullPatch :: p C(x y) -> EqCheck C(x y)--class (ArbitraryState (ModelOf prim) prim, NullPatch prim, PrimPatch prim, RepoModel (ModelOf prim)) => ArbitraryPrim prim---- canonize a tree, removing any dead branches-canonizeTree :: NullPatch p => Tree p C(x) -> Tree p C(x)-canonizeTree NilTree = NilTree-canonizeTree (ParTree t1 t2)- | NilTree <- canonizeTree t1 = canonizeTree t2- | NilTree <- canonizeTree t2 = canonizeTree t1- | otherwise = ParTree (canonizeTree t1) (canonizeTree t2)-canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t- | otherwise = SeqTree p (canonizeTree t)---instance (RepoModel model, ArbitraryPrim prim, model ~ ModelOf prim,- ArbitraryState model prim) => Arbitrary (Sealed (WithStartState model (Tree prim))) where- arbitrary = do repo <- aSmallRepo- Sealed (WithStartState rm tree) <-- liftM (seal . WithStartState repo) (arbitraryStateIn repo)- return $ Sealed $ WithStartState rm (canonizeTree tree)--flattenOne :: (FromPrim p, Merge p) => Tree (PrimOf p) C(x) -> Sealed (FL p C(x))-flattenOne NilTree = seal NilFL-flattenOne (SeqTree p (flattenOne -> Sealed ps)) = seal (fromPrim p :>: ps)-flattenOne (ParTree (flattenOne -> Sealed ps1) (flattenOne -> Sealed ps2)) =- --traceDoc (greenText "flattening two parallel series: ps1" $$ showPatch ps1 $$- -- greenText "ps2" $$ showPatch ps2) $- case merge (ps1 :\/: ps2) of- ps2' :/\: _ -> seal (ps1 +>+ ps2')--data TreeWithFlattenPos p C(x) = TWFP Int (Tree p C(x))--commutePairFromTWFP :: (FromPrim p, Merge p, PrimPatchBase p)- => (FORALL (y z) (p :> p) C(y z) -> t)- -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) C(x) -> t)-commutePairFromTWFP handlePair (WithStartState _ (TWFP n t))- = unseal2 handlePair $- let xs = unseal getPairs (flattenOne t)- in if length xs > n && n >= 0 then xs!!n else seal2 (fromPrim anIdentity :> fromPrim anIdentity)--commutePairFromTree :: (FromPrim p, Merge p, PrimPatchBase p)- => (FORALL (y z) (p :> p) C(y z) -> t)- -> (WithStartState model (Tree (PrimOf p)) C(x) -> t)-commutePairFromTree handlePair (WithStartState _ t)- = unseal2 handlePair $- case flattenOne t of- Sealed ps ->- let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $- getPairs ps- in if null xs then seal2 (fromPrim anIdentity :> fromPrim anIdentity) else last xs--commuteTripleFromTree :: (FromPrim p, Merge p, PrimPatchBase p)- => (FORALL (y z) (p :> p :> p) C(y z) -> t)- -> (WithStartState model (Tree (PrimOf p)) C(x) -> t)-commuteTripleFromTree handle (WithStartState _ t)- = unseal2 handle $- case flattenOne t of- Sealed ps ->- let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $- getTriples ps- in if null xs- then seal2 (fromPrim anIdentity :> fromPrim anIdentity :> fromPrim anIdentity)- else last xs--mergePairFromCommutePair :: (Commute p, Invert p)- => (FORALL (y z) (p :\/: p) C(y z) -> t)- -> (FORALL (y z) (p :> p) C(y z) -> t)-mergePairFromCommutePair handlePair (a :> b)- = case commute (a :> b) of- Just (b' :> _) -> handlePair (a :\/: b')- Nothing -> handlePair (b :\/: b)---- impredicativity problems mean we can't use (.) in the definitions below--mergePairFromTWFP :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)- => (FORALL (y z) (p :\/: p) C(y z) -> t)- -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) C(x) -> t)-mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x)--mergePairFromTree :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)- => (FORALL (y z) (p :\/: p) C(y z) -> t)- -> (WithStartState model (Tree (PrimOf p)) C(x) -> t)-mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x)--patchFromCommutePair :: (Commute p, Invert p)- => (FORALL (y z) p C(y z) -> t)- -> (FORALL (y z) (p :> p) C(y z) -> t)-patchFromCommutePair handle (_ :> b) = handle b--patchFromTree :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)- => (FORALL (y z) p C(y z) -> t)- -> (WithStartState model (Tree (PrimOf p)) C(x) -> t)-patchFromTree x = commutePairFromTree (patchFromCommutePair x)---instance Show2 p => Show (TreeWithFlattenPos p C(x)) where- showsPrec d (TWFP n t) = showParen (d > appPrec) $ showString "TWFP " .- showsPrec (appPrec + 1) n . showString " " .- showsPrec1 (appPrec + 1) t--getPairs :: FL p C(x y) -> [Sealed2 (p :> p)]-getPairs NilFL = []-getPairs (_:>:NilFL) = []-getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c)--getTriples :: FL p C(x y) -> [Sealed2 (p :> p :> p)]-getTriples NilFL = []-getTriples (_:>:NilFL) = []-getTriples (_:>:_:>:NilFL) = []-getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d)--instance (ArbitraryPrim prim, RepoModel (ModelOf prim), model ~ ModelOf prim,- ArbitraryState model prim)- => Arbitrary (Sealed (WithStartState model (TreeWithFlattenPos prim))) where- arbitrary = do Sealed (WithStartState rm t) <- arbitrary- let num = unseal (length . getPairs) (flattenOneRP t)- if num == 0 then return $ Sealed $ WithStartState rm $ TWFP 0 NilTree- else do n <- choose (0, num - 1)- return $ Sealed $ WithStartState rm $ TWFP n t- where -- just used to get the length. In principle this should be independent of the patch type.- flattenOneRP :: Tree prim C(x) -> Sealed (FL (RealPatch prim) C(x))- flattenOneRP = flattenOne-
− src/Darcs/Test/Patch/Arbitrary/PatchV1.hs
@@ -1,288 +0,0 @@--- Copyright (C) 2002-2003,2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}--#include "gadts.h"--module Darcs.Test.Patch.Arbitrary.PatchV1 () where--import Prelude hiding ( pi )-import System.IO.Unsafe ( unsafePerformIO )-import Test.QuickCheck-import Control.Applicative-import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM )--import Darcs.Patch.Info ( PatchInfo, patchinfo )-import qualified Data.ByteString as B ( ByteString )-import qualified Data.ByteString.Char8 as BC ( pack )--import Darcs.Patch ( addfile, adddir, move,- hunk, tokreplace, binary,- changepref, invert, merge )-import Darcs.Patch.V1 ()-import qualified Darcs.Patch.V1.Core as V1 ( Patch(..) )-import Darcs.Patch.Prim.V1 ()-import Darcs.Patch.Prim.V1.Core ( Prim(..) )-import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) )-import Darcs.Witnesses.Unsafe---- This definitely feels a bit weird to be importing Properties here, and--- probably means we want to move this elsewhere, but Darcs.Test.Patch.Check is--- already taken with something apparently only semi-related-import Darcs.Test.Patch.Properties.Check( checkAPatch )--#include "impossible.h"--type Patch = V1.Patch Prim--class ArbitraryP p where- arbitraryP :: Gen (Sealed (p C(x)))--{--TODO: there is a lot of overlap in testing between between this module-and Darcs.Test.Patch.QuickCheck--This module tests Prim and V1 patches, and Darcs.Test.Patch.QuickCheck-tests Prim and V2 patches--This module's generator covers a wider set of patch types, but is less-likely to generate conflicts than Darcs.Test.Patch.QuickCheck.--Until this is cleaned up, we take some care that the Arbitrary instances-do not overlap and are only used for tests from the respective-modules.--(There are also tests in other modules that probably depend on the-Arbitrary instances in this module.)--}--instance Arbitrary (Sealed (Prim C(x))) where- arbitrary = arbitraryP--instance Arbitrary (Sealed (FL Patch C(x))) where- arbitrary = arbitraryP---- instance Arbitrary (Sealed2 (Prim :> Prim)) where- -- arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch)) where- arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch :\/: FL Patch)) where- arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch :> FL Patch)) where- arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch :> FL Patch :> FL Patch)) where- arbitrary = unseal Sealed2 <$> arbitraryP---instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :> p2) where- arbitraryP = do Sealed p1 <- arbitraryP- Sealed p2 <- arbitraryP- return (Sealed (p1 :> p2))--instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :\/: p2) where- arbitraryP = do Sealed p1 <- arbitraryP- Sealed p2 <- arbitraryP- return (Sealed (unsafeCoercePEnd p1 :\/: p2))--instance ArbitraryP (FL Patch) where- arbitraryP = sized arbpatch--instance ArbitraryP Prim where- arbitraryP = onepatchgen--hunkgen :: Gen (Sealed (Prim C(x)))-hunkgen = do- i <- frequency [(1,choose (0,5)),(1,choose (0,35)),- (2,return 0),(3,return 1),(2,return 2),(1,return 3)]- j <- frequency [(1,choose (0,5)),(1,choose (0,35)),- (2,return 0),(3,return 1),(2,return 2),(1,return 3)]- if i == 0 && j == 0 then hunkgen- else Sealed <$>- liftM4 hunk filepathgen linenumgen- (replicateM i filelinegen)- (replicateM j filelinegen)--tokreplacegen :: Gen (Sealed (Prim C(x)))-tokreplacegen = do- f <- filepathgen- o <- tokengen- n <- tokengen- if o == n- then return $ Sealed $ tokreplace f "A-Za-z" "old" "new"- else return $ Sealed $ tokreplace f "A-Za-z_" o n--twofilegen :: (FORALL(y) FilePath -> FilePath -> Prim C(x y)) -> Gen (Sealed (Prim C(x)))-twofilegen p = do- n1 <- filepathgen- n2 <- filepathgen- if n1 /= n2 && checkAPatch (p n1 n2)- then return $ Sealed $ p n1 n2- else twofilegen p--chprefgen :: Gen (Sealed (Prim C(x)))-chprefgen = do- f <- oneof [return "color", return "movie"]- o <- tokengen- n <- tokengen- if o == n then return $ Sealed $ changepref f "old" "new"- else return $ Sealed $ changepref f o n--simplepatchgen :: Gen (Sealed (Prim C(x)))-simplepatchgen = frequency [(1,liftM (Sealed . addfile) filepathgen),- (1,liftM (Sealed . adddir) filepathgen),- (1,liftM3 (\x y z -> Sealed (binary x y z)) filepathgen arbitrary arbitrary),- (1,twofilegen move),- (1,tokreplacegen),- (1,chprefgen),- (7,hunkgen)- ]--onepatchgen :: Gen (Sealed (Prim C(x)))-onepatchgen = oneof [simplepatchgen, mapSeal (invert . unsafeCoerceP) `fmap` simplepatchgen]--norecursgen :: Int -> Gen (Sealed (FL Patch C(x)))-norecursgen 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen-norecursgen n = oneof [mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen,flatcompgen n]--arbpatch :: Int -> Gen (Sealed (FL Patch C(x)))-arbpatch 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen-arbpatch n = frequency [(3,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen),- (2,flatcompgen n),- (0,rawMergeGen n),- (0,mergegen n),- (1,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen)- ]---- | Generate an arbitrary list of at least one element-unempty :: Arbitrary a => Gen [a]-unempty = do- a <- arbitrary- as <- arbitrary- return (a:as)--rawMergeGen :: Int -> Gen (Sealed (FL Patch C(x)))-rawMergeGen n = do Sealed p1 <- arbpatch len- Sealed p2 <- arbpatch len- if checkAPatch (invert p1:>:p2:>:NilFL) &&- checkAPatch (invert p2:>:p1:>:NilFL)- then case merge (p2 :\/: p1) of- _ :/\: p2' -> return (Sealed (unsafeCoercePStart p2'))- else rawMergeGen n- where len = if n < 15 then n`div`3 else 3--mergegen :: Int -> Gen (Sealed (FL Patch C(x)))-mergegen n = do- Sealed p1 <- norecursgen len- Sealed p2 <- norecursgen len- if checkAPatch (invert p1:>:p2:>:NilFL) &&- checkAPatch (invert p2:>:p1:>:NilFL)- then case merge (p2:\/:p1) of- _ :/\: p2' ->- if checkAPatch (p1+>+p2')- then return $ Sealed $ p1+>+p2'- else impossible- else mergegen n- where len = if n < 15 then n`div`3 else 3--arbpi :: Gen PatchInfo-arbpi = do n <- unempty- a <- unempty- l <- unempty- d <- unempty- return $ unsafePerformIO $ patchinfo n d a l--instance Arbitrary PatchInfo where- arbitrary = arbpi--instance Arbitrary B.ByteString where- arbitrary = liftM BC.pack arbitrary--flatlistgen :: Int -> Gen (Sealed (FL Patch C(x)))-flatlistgen 0 = return $ Sealed NilFL-flatlistgen n = do Sealed x <- onepatchgen- Sealed xs <- flatlistgen (n-1)- return (Sealed (V1.PP x :>: xs))--flatcompgen :: Int -> Gen (Sealed (FL Patch C(x)))-flatcompgen n = do- Sealed ps <- flatlistgen n- let myp = regularizePatches $ ps- if checkAPatch myp- then return $ Sealed myp- else flatcompgen n---- resize to size 25, that means we'll get line numbers no greater--- than 1025 using QuickCheck 2.1-linenumgen :: Gen Int-linenumgen = frequency [(1,return 1), (1,return 2), (1,return 3),- (3,liftM (\n->1+abs n) (resize 25 arbitrary)) ]--tokengen :: Gen String-tokengen = oneof [return "hello", return "world", return "this",- return "is", return "a", return "silly",- return "token", return "test"]--toklinegen :: Gen String-toklinegen = liftM unwords $ replicateM 3 tokengen--filelinegen :: Gen B.ByteString-filelinegen = liftM BC.pack $- frequency [(1,map fromSafeChar `fmap` arbitrary),(5,toklinegen),- (1,return ""), (1,return "{"), (1,return "}") ]--filepathgen :: Gen String-filepathgen = liftM fixpath badfpgen--fixpath :: String -> String-fixpath "" = "test"-fixpath p = fpth p--fpth :: String -> String-fpth ('/':'/':cs) = fpth ('/':cs)-fpth (c:cs) = c : fpth cs-fpth [] = []--newtype SafeChar = SS Char-instance Arbitrary SafeChar where- arbitrary = oneof $ map (return . SS) (['a'..'z']++['A'..'Z']++['1'..'9']++"0")--fromSafeChar :: SafeChar -> Char-fromSafeChar (SS s) = s--badfpgen :: Gen String-badfpgen = frequency [(1,return "test"), (1,return "hello"), (1,return "world"),- (1,map fromSafeChar `fmap` arbitrary),- (1,liftM2 (\a b-> a++"/"++b) filepathgen filepathgen) ]--regularizePatches :: FL Patch C(x y) -> FL Patch C(x y)-regularizePatches patches = rpint (unsafeCoerceP NilFL) patches- where -- this reverses the list, which seems odd and causes- -- the witness unsafety- rpint :: FL Patch C(x y) -> FL Patch C(a b) -> FL Patch C(x y)- rpint ok_ps NilFL = ok_ps- rpint ok_ps (p:>:ps) =- if checkAPatch (unsafeCoerceP p:>:ok_ps)- then rpint (unsafeCoerceP p:>:ok_ps) ps- else rpint ok_ps ps-
− src/Darcs/Test/Patch/Arbitrary/PrimV1.hs
@@ -1,394 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Test.Patch.Arbitrary.PrimV1 where--import qualified Darcs.Test.Patch.Arbitrary.Generic as T- ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP- , mergePairFromTree, mergePairFromTWFP- , patchFromTree )-import Darcs.Test.Patch.Arbitrary.Generic-import Darcs.Test.Patch.RepoModel--import Control.Monad ( liftM )-import Test.QuickCheck-import Darcs.Test.Patch.WithState-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Unsafe-import Darcs.Witnesses.Ordered--- import Darcs.Witnesses.Show-import Darcs.Patch.Prim.V1 ()-import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk, TokReplace ), Prim( FP ), isIdentity )-import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.FileHunk( IsHunk( isHunk ), FileHunk(..) )--import Darcs.Test.Patch.V1Model-import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )--import Darcs.Commands.Replace ( defaultToks )-import Darcs.Patch.Prim--import Control.Applicative ( (<$>) )-import qualified Data.ByteString.Char8 as BC-import Data.Maybe ( isJust )--#include "gadts.h"-#include "impossible.h"--patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) p C(y z) -> t) -> WithStartState V1Model (Tree Prim) C(x) -> t-patchFromTree = T.patchFromTree--mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :\/: p) C(y z) -> t) -> WithStartState V1Model (Tree Prim) C(x) -> t-mergePairFromTree = T.mergePairFromTree--mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :\/: p) C(y z) -> t) -> WithStartState V1Model (TreeWithFlattenPos Prim) C(x) -> t-mergePairFromTWFP = T.mergePairFromTWFP--commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p) C(y z) -> t) -> WithStartState V1Model (TreeWithFlattenPos Prim) C(x) -> t-commutePairFromTWFP = T.commutePairFromTWFP--commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p) C(y z) -> t) -> WithStartState V1Model (Tree Prim) C(x) -> t-commutePairFromTree = T.commutePairFromTree--commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p :> p) C(y z) -> t) -> WithStartState V1Model (Tree Prim) C(x) -> t-commuteTripleFromTree = T.commuteTripleFromTree--nonEmptyHunk :: (IsHunk p) => p C(x y) -> Bool-nonEmptyHunk p- | Just (FileHunk _ _ [] []) <- isHunk p = False- | otherwise = True--nonEmptyHunksPair :: (IsHunk p) => (p :> p) C(x y) -> Bool-nonEmptyHunksPair (p1 :> p2) = nonEmptyHunk p1 && nonEmptyHunk p2--nonEmptyHunksTriple :: (IsHunk p) => (p :> p :> p) C(x y) -> Bool-nonEmptyHunksTriple (p1 :> p2 :> p3) = nonEmptyHunk p1 && nonEmptyHunk p2 && nonEmptyHunk p3--nonEmptyHunksFLPair :: (IsHunk p) => (FL p :> FL p) C(x y) -> Bool-nonEmptyHunksFLPair (ps :> qs) = allFL nonEmptyHunk ps && allFL nonEmptyHunk qs--type instance ModelOf Prim = V1Model-instance ArbitraryPrim Prim--instance NullPatch Prim where- nullPatch (FP _ fp) = nullPatch fp- nullPatch p | IsEq <- isIdentity p = IsEq- nullPatch _ = NotEq--instance NullPatch FilePatchType where- nullPatch (Hunk _ [] []) = unsafeCoerceP IsEq -- is this safe?- nullPatch _ = NotEq--instance Arbitrary (Sealed2 (FL (WithState V1Model Prim))) where- arbitrary = do repo <- ourSmallRepo- liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo---- instance Show1 (TreeWithFlattenPos Prim) where--- showDict1 = ShowDictClass---- WithState and propFail are handy for debugging arbitrary code-propFail :: Int -> Tree Prim C(x) -> Bool-propFail n xs = sizeTree xs < n--------------------------------------------------------------------------- * QuickCheck generators--------------------------------------------------------------------------- ** FilePatchType generators--aHunk :: FORALL(x y) Content -> Gen (FilePatchType C(x y))-aHunk content- = sized $ \n ->- do pos <- choose (1, contentLen+1)- let prefixLen = pos-1- restLen = contentLen-prefixLen- oldLen <- frequency- [ (75, choose (0, min restLen n))- -- produces small hunks common in real editing- , (25, choose (0, min 10 restLen))- ]- -- newLen choice aims to cover all possibilities, that is,- -- remove less/the same/more than added and empty the file.- newLen <- frequency- [ ( 54- , choose (1,min 1 n)- )- , ( if oldLen /= 0 then 42 else 0- , choose (1,min 1 oldLen)- )- , ( if oldLen /= 0 then 2 else 0- , return oldLen- )- , ( if oldLen /= 0 then 2 else 0- , return 0- )- ]- new <- vectorOf newLen aLine- let old = take oldLen $ drop prefixLen $ content- return $ Hunk pos old new- where- contentLen = length content--aTokReplace :: FORALL(x y) Content -> Gen (FilePatchType C(x y))-aTokReplace []- = do w <- vectorOf 1 alpha- w' <- vectorOf 1 alpha- return $ TokReplace defaultToks w w'-aTokReplace content- = do let fileWords = concatMap BC.words content- wB <- elements fileWords- w' <- alphaBS `notIn` fileWords- return $ TokReplace defaultToks (BC.unpack wB) (BC.unpack w')- where- alphaBS = do x <- alpha; return $ BC.pack [x]--------------------------------------------------------------------------- ** Prim generators--aHunkP :: FORALL(x y) (AnchoredPath,File) -> Gen (Prim C(x y))-aHunkP (path,file)- = do Hunk pos old new <- aHunk content- return $ hunk (ap2fp path) pos old new- where- content = fileContent file--aTokReplaceP :: FORALL (x y) (AnchoredPath,File) -> Gen (Prim C(x y))-aTokReplaceP (path,file)- = do TokReplace tokchars old new <- aTokReplace content- return $ tokreplace (ap2fp path) tokchars old new- where- content = fileContent file--anAddFileP :: FORALL (x y) (AnchoredPath,Dir) -> Gen (Prim C(x y))-anAddFileP (path,dir)- = do newFilename <- aFilename `notIn` existing- let newPath = path `appendPath` newFilename- return $ addfile (ap2fp newPath)- where- existing = map fst $ filterFiles $ dirContent dir--aRmFileP :: FORALL (x y) AnchoredPath -- ^ Path of an empty file- -> Prim C(x y)-aRmFileP path = rmfile (ap2fp path)--anAddDirP :: FORALL (x y) (AnchoredPath,Dir) -> Gen (Prim C(x y))-anAddDirP (path,dir)- = do newDirname <- aDirname `notIn` existing- let newPath = path `appendPath` newDirname- return $ adddir (ap2fp newPath)- where- existing = map fst $ filterDirs $ dirContent dir--aRmDirP :: FORALL (x y) AnchoredPath -- ^ Path of an empty directory- -> Prim C(x y)-aRmDirP path = rmdir (ap2fp path)--aMoveP :: FORALL (x y) Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (Prim C(x y))-aMoveP nameGen oldPath (dirPath,dir)- = do newName <- nameGen `notIn` existing- let newPath = dirPath `appendPath` newName- return $ move (ap2fp oldPath) (ap2fp newPath)- where- existing = map fst $ dirContent dir---- | Generates any type of 'Prim' patch, except binary and setpref patches.-aPrim :: FORALL(x y) V1Model C(x) -> Gen (WithEndState V1Model (Prim C(x)) C(y))-aPrim repo- = do mbFile <- maybeOf repoFiles- mbEmptyFile <- maybeOf $ filter (isEmpty . snd) repoFiles- dir <- elements (rootDir:repoDirs)- mbOldDir <- maybeOf repoDirs- mbEmptyDir <- maybeOf $ filter (isEmpty . snd) repoDirs- patch <- frequency- [ ( if isJust mbFile then 12 else 0- , aHunkP $ fromJust mbFile- )- , ( if isJust mbFile then 6 else 0- , aTokReplaceP $ fromJust mbFile- )- , ( 2- , anAddFileP dir- )- , ( if isJust mbEmptyFile then 12 else 0- , return $ aRmFileP $ fst $ fromJust mbEmptyFile- )- , ( 2- , anAddDirP dir- )- , ( if isJust mbEmptyDir then 10 else 0- , return $ aRmDirP $ fst $ fromJust mbEmptyDir- )- , ( if isJust mbFile then 3 else 0- , aMoveP aFilename (fst $ fromJust mbFile) dir- )- , let oldPath = fst $ fromJust mbOldDir in- ( if isJust mbOldDir- && not (oldPath `isPrefix` fst dir)- then 4 else 0- , aMoveP aDirname oldPath dir- )- ]- let repo' = unFail $ repoApply repo patch- return $ WithEndState patch repo'- where- repoItems = list repo- repoFiles = filterFiles repoItems- repoDirs = filterDirs repoItems- rootDir = (anchoredRoot,root repo)--{- [COVERAGE OF aPrim]-- PLEASE,- if you change something that may affect the coverage of aPrim then- a) recalculate it, or if that is not possible;- b) indicate the need to do it.-- Patch type- ----------- 42% hunk- 22% tokreplace- 14% move- 6% rmdir- 6% addfile- 6% adddir- 4% rmfile--}--------------------------------------------------------------------------- *** Pairs of primitive patches---- Try to generate commutable pairs of hunks-hunkPairP :: FORALL(x y) (AnchoredPath,File) -> Gen ((Prim :> Prim) C(x y))-hunkPairP (path,file)- = do h1@(Hunk l1 old1 new1) <- aHunk content- (delta, content') <- selectChunk h1 content- Hunk l2' old2 new2 <- aHunk content'- let l2 = l2'+delta- return (hunk fpPath l1 old1 new1 :> hunk fpPath l2 old2 new2)- where- content = fileContent file- fpPath = ap2fp path- selectChunk (Hunk l old new) content_- = elements [prefix, suffix]- where- start = l - 1- prefix = (0, take start content_)- suffix = (start + length new, drop (start + length old) content_)- selectChunk _ _ = impossible--aPrimPair :: FORALL(x y) V1Model C(x) -> Gen (WithEndState V1Model ((Prim :> Prim) C(x)) C(y))-aPrimPair repo- = do mbFile <- maybeOf repoFiles- frequency- [ ( if isJust mbFile then 1 else 0- , do p1 :> p2 <- hunkPairP $ fromJust mbFile- let repo' = unFail $ repoApply repo p1- repo'' = unFail $ repoApply repo' p2- return $ WithEndState (p1 :> p2) repo''- )- , ( 1- , do Sealed wesP <- arbitraryState repo- return $ unsafeCoerceP1 wesP- )- ]- where- repoItems = list repo- repoFiles = filterFiles repoItems--{- [COVERAGE OF aPrimPair]-- PLEASE,- if you change something that may affect the coverage of aPrimPair then- a) recalculate it, or if that is not possible;- b) indicate the need to do it.-- Rate of ommutable pairs- ------------------------ 67% commutable-- Commutable coverage (for 1000 tests)- -------------------- 21% hunks-B- 20% hunks-A- 14% file:>dir- 12% file:>move- 8% trivial-FP- 8% hunk:>tok- 4% hunks-D- 3% tok:>tok- 2% hunks-C- 1% move:>move- 1% dir:>move- 1% dir:>dir- 0% emptyhunk:>file--}--------------------------------------------------------------------------- Arbitrary instances--ourSmallRepo :: Gen (V1Model C(x))-ourSmallRepo = aSmallRepo--instance ArbitraryState V1Model Prim where- arbitraryState s = seal <$> aPrim s---instance Arbitrary (Sealed2 Prim) where- arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed2 (Prim :> Prim)) where- arbitrary = do repo <- ourSmallRepo- WithEndState pp _ <- aPrimPair repo- return $ seal2 pp--instance Arbitrary (Sealed ((Prim :> Prim) C(a))) where- arbitrary = do repo <- ourSmallRepo- WithEndState pp _ <- aPrimPair repo- return $ seal pp--instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where- arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where- arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim)) where- arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim) C(a))) where- arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where- arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim :> FL Prim) C(a))) where- arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V1Model Prim)) where- arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed (WithState V1Model Prim C(a))) where- arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed (WithState V1Model (FL Prim) C(a))) where- arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V1Model (Prim :> Prim))) where- arbitrary = do repo <- ourSmallRepo- WithEndState pp repo' <- aPrimPair repo- return $ seal2 $ WithState repo pp repo'--instance Arbitrary (Sealed (WithState V1Model (Prim :> Prim) a)) where- arbitrary = do repo <- ourSmallRepo- WithEndState pp repo' <- aPrimPair repo- return $ seal $ WithState repo pp repo'---instance Arbitrary (Sealed2 (WithState V1Model (FL Prim))) where- arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V1Model (FL Prim :> FL Prim))) where- arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed (WithState V1Model (FL Prim :> FL Prim) a)) where- arbitrary = makeWSGen ourSmallRepo
− src/Darcs/Test/Patch/Arbitrary/PrimV3.hs
@@ -1,259 +0,0 @@--- TODO: Remove these warning disabling flags...-{-# OPTIONS_GHC -w #-}-{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}-module Darcs.Test.Patch.Arbitrary.PrimV3 where--import qualified Darcs.Test.Patch.Arbitrary.Generic as T- ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP- , mergePairFromTree, mergePairFromTWFP- , patchFromTree )-import Darcs.Test.Patch.Arbitrary.Generic-import Darcs.Test.Patch.RepoModel--import Control.Monad ( liftM )-import Test.QuickCheck-import Darcs.Test.Patch.WithState-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Unsafe-import Darcs.Witnesses.Ordered--- import Darcs.Witnesses.Show-import Darcs.Patch.Prim.V3 ()-import Darcs.Patch.Prim.V3.Core ( Prim(..), Location, Hunk(..), UUID(..) )-import Darcs.Patch.RepoPatch ( RepoPatch )--import Darcs.Test.Patch.V3Model-import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )--import Darcs.Commands.Replace ( defaultToks )-import Darcs.Patch.Prim--import Control.Applicative ( (<$>) )-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString as BS-import Data.Maybe ( isJust )-import qualified Data.Map as M-import Storage.Hashed.Hash( Hash(..) )--#include "gadts.h"-#include "impossible.h"--patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) p C(y z) -> t) -> WithStartState V3Model (Tree Prim) C(x) -> t-patchFromTree = T.patchFromTree--mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :\/: p) C(y z) -> t) -> WithStartState V3Model (Tree Prim) C(x) -> t-mergePairFromTree = T.mergePairFromTree--mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :\/: p) C(y z) -> t) -> WithStartState V3Model (TreeWithFlattenPos Prim) C(x) -> t-mergePairFromTWFP = T.mergePairFromTWFP--commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p) C(y z) -> t) -> WithStartState V3Model (TreeWithFlattenPos Prim) C(x) -> t-commutePairFromTWFP = T.commutePairFromTWFP--commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p) C(y z) -> t) -> WithStartState V3Model (Tree Prim) C(x) -> t-commutePairFromTree = T.commutePairFromTree--commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p :> p) C(y z) -> t) -> WithStartState V3Model (Tree Prim) C(x) -> t-commuteTripleFromTree = T.commuteTripleFromTree--type instance ModelOf Prim = V3Model-instance ArbitraryPrim Prim--hunkIdentity (Hunk _ old new) | old == new = unsafeCoerceP IsEq-hunkIdentity _ = NotEq--instance NullPatch Prim where- nullPatch (BinaryHunk _ x) = hunkIdentity x- nullPatch (TextHunk _ x) = hunkIdentity x- nullPatch _ = NotEq--instance Arbitrary (Sealed2 (FL (WithState V3Model Prim))) where- arbitrary = do repo <- ourSmallRepo- liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo---- instance Show1 (TreeWithFlattenPos Prim) where--- showDict1 = ShowDictClass---- WithState and propFail are handy for debugging arbitrary code-propFail :: Int -> Tree Prim C(x) -> Bool-propFail n xs = sizeTree xs < n--------------------------------------------------------------------------- * QuickCheck generators--aHunk :: FORALL(x y) BS.ByteString -> Gen (Hunk C(x y))-aHunk content- = sized $ \n ->- do pos <- choose (0, BS.length content)- let prefixLen = pos- restLen = BS.length content - prefixLen- oldLen <- frequency- [ (75, choose (0, min restLen n))- , (25, choose (0, min 10 restLen))- ]- let nonempty x = if oldLen /= 0 then x else 0- newLen <- frequency- [ ( 54, choose (1,min 1 n) )- , ( nonempty 42, choose (1,min 1 oldLen) )- , ( nonempty 2, return oldLen )- , ( nonempty 2, return 0 )- ]- new <- BS.concat <$> vectorOf newLen aLine- let old = BS.take oldLen $ BS.drop prefixLen $ content- return $ Hunk pos old new--aTextHunk :: FORALL (x y) (UUID, Object Fail) -> Gen (Prim C(x y))-aTextHunk (uuid, (Blob text _)) =- do hunk <- aHunk (unFail text)- return $ TextHunk uuid hunk--aManifest :: FORALL (x y) UUID -> Location -> Object Fail -> Gen (Prim C(x y))-aManifest uuid loc (Directory dir) =- do newFilename <- aFilename `notIn` (M.keys dir)- return $ Manifest uuid loc--aDemanifest :: FORALL (x y) UUID -> Location -> Gen (Prim C(x y))-aDemanifest uuid loc = return $ Demanifest uuid loc---- | Generates any type of 'Prim' patch, except binary and setpref patches.-aPrim :: FORALL(x y) V3Model C(x) -> Gen (WithEndState V3Model (Prim C(x)) C(y))-aPrim repo- = do mbFile <- maybeOf repoFiles- mbDir <- maybeOf repoDirs- mbExisting <- maybeOf $ repoObjects repo- mbManifested <- maybeOf manifested- fresh <- anUUID- filename <- aFilename- dir <- elements (rootDir:repoDirs)- mbOtherDir <- maybeOf repoDirs- let whenfile x = if isJust mbFile then x else 0- whendir x = if isJust mbDir then x else 0- whenexisting x = if isJust mbExisting then x else 0- whenmanifested x = if isJust mbManifested then x else 0- patch <- frequency- [ ( whenfile 12, aTextHunk $ fromJust mbFile )- , ( 2, aTextHunk (fresh, Blob (return "") NoHash) ) -- create an empty thing- , ( whenexisting (whendir 2), -- manifest an existing object- aManifest (fst $ fromJust mbExisting)- (fst $ fromJust mbDir, filename)- (snd $ fromJust mbDir))- , ( whenmanifested 2, uncurry aDemanifest $ fromJust mbManifested )- -- TODO: demanifest- ]- let repo' = unFail $ repoApply repo patch- return $ WithEndState patch repo'- where- manifested = [ (id, (dirid, name)) | (dirid, Directory dir) <- repoDirs- , (name, id) <- M.toList dir ]- repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ]- repoDirs = [ (id, Directory x) | (id, Directory x) <- repoObjects repo ]- rootDir = (UUID "ROOT", root repo)--------------------------------------------------------------------------- *** Pairs of primitive patches---- Try to generate commutable pairs of hunks-hunkPair :: FORALL(x y) (UUID, Object Fail) -> Gen ((Prim :> Prim) C(x y))-hunkPair (uuid, (Blob file _)) =- do h1@(Hunk l1 old1 new1) <- aHunk (unFail file)- (delta, content') <- selectChunk h1 (unFail file)- Hunk l2' old2 new2 <- aHunk content'- let l2 = l2'+delta- return (TextHunk uuid (Hunk l1 old1 new1) :> TextHunk uuid (Hunk l2 old2 new2))- where- selectChunk (Hunk l old new) content = elements [prefix, suffix]- where start = l - 1- prefix = (0, BS.take start content)- suffix = (start + BS.length new, BS.drop (start + BS.length old) content)- selectChunk _ _ = impossible--aPrimPair :: FORALL(x y) V3Model C(x) -> Gen (WithEndState V3Model ((Prim :> Prim) C(x)) C(y))-aPrimPair repo- = do mbFile <- maybeOf repoFiles- frequency- [ ( if isJust mbFile then 1 else 0- , do p1 :> p2 <- hunkPair $ fromJust mbFile- let repo' = unFail $ repoApply repo p1- repo'' = unFail $ repoApply repo' p2- return $ WithEndState (p1 :> p2) repo''- )- , ( 1- , do Sealed wesP <- arbitraryState repo- return $ unsafeCoerceP1 wesP- )- ]- where- repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ]--------------------------------------------------------------------------- Arbitrary instances--ourSmallRepo :: Gen (V3Model C(x))-ourSmallRepo = aSmallRepo--instance ArbitraryState V3Model Prim where- arbitraryState s = seal <$> aPrim s---instance Arbitrary (Sealed2 Prim) where- arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed (Prim x)) where- arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (Prim :> Prim)) where- arbitrary = do repo <- ourSmallRepo- WithEndState pp _ <- aPrimPair repo- return $ seal2 pp--instance Arbitrary (Sealed ((Prim :> Prim) C(a))) where- arbitrary = do repo <- ourSmallRepo- WithEndState pp _ <- aPrimPair repo- return $ seal pp--instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where- arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where- arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim)) where- arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim) C(a))) where- arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where- arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim :> FL Prim) C(a))) where- arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V3Model Prim)) where- arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed (WithState V3Model Prim C(a))) where- arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed (WithState V3Model (FL Prim) C(a))) where- arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V3Model (Prim :> Prim))) where- arbitrary = do repo <- ourSmallRepo- WithEndState pp repo' <- aPrimPair repo- return $ seal2 $ WithState repo pp repo'--instance Arbitrary (Sealed (WithState V3Model (Prim :> Prim) a)) where- arbitrary = do repo <- ourSmallRepo- WithEndState pp repo' <- aPrimPair repo- return $ seal $ WithState repo pp repo'---instance Arbitrary (Sealed2 (WithState V3Model (FL Prim))) where- arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V3Model (FL Prim :> FL Prim))) where- arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed (WithState V3Model (FL Prim :> FL Prim) a)) where- arbitrary = makeWSGen ourSmallRepo
− src/Darcs/Test/Patch/Arbitrary/Real.hs
@@ -1,67 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE UndecidableInstances #-}-module Darcs.Test.Patch.Arbitrary.Real where-import Darcs.Test.Patch.Arbitrary.Generic-import Darcs.Test.Patch.Arbitrary.PrimV1 ()-import Darcs.Test.Patch.RepoModel--import Darcs.Witnesses.Ordered-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Patchy ( Patchy, Commute(..) )-import Darcs.Patch.Prim ( PrimPatch, anIdentity )-import Darcs.Patch.V2 ( RealPatch )-import Darcs.Patch.V2.Real ( isDuplicate )--import Test.QuickCheck-import Darcs.Test.Patch.WithState-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq-import Darcs.Patch.Prim ( FromPrim(..) )--#include "gadts.h"--nontrivialReals :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y) -> Bool-nontrivialReals = nontrivialCommute--nontrivialCommute :: Patchy p => (p :> p) C(x y) -> Bool-nontrivialCommute (x :> y) = case commute (x :> y) of- Just (y' :> x') -> not (y' `unsafeCompare` y) ||- not (x' `unsafeCompare` x)- Nothing -> False--nontrivialMergeReals :: PrimPatch prim => (RealPatch prim :\/: RealPatch prim) C(x y) -> Bool-nontrivialMergeReals = nontrivialMerge--nontrivialMerge :: (Patchy p, Merge p) => (p :\/: p) C(x y) -> Bool-nontrivialMerge (x :\/: y) = case merge (x :\/: y) of- y' :/\: x' -> not (y' `unsafeCompare` y) ||- not (x' `unsafeCompare` x)--instance (RepoModel (ModelOf prim), ArbitraryPrim prim)- => Arbitrary (Sealed2 (FL (RealPatch prim))) where- arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim)))- return $ unseal seal2 (flattenOne tree)--instance (RepoModel (ModelOf prim), ArbitraryPrim prim)- => Arbitrary (Sealed2 (RealPatch prim)) where- arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim)))- case mapFL seal2 `unseal` flattenOne tree of- [] -> return $ seal2 $ fromPrim anIdentity- ps -> elements ps--notDuplicatestriple :: (RealPatch prim :> RealPatch prim :> RealPatch prim) C(x y) -> Bool-notDuplicatestriple (a :> b :> c) = not (isDuplicate a || isDuplicate b || isDuplicate c)--nontrivialTriple :: PrimPatch prim => (RealPatch prim :> RealPatch prim :> RealPatch prim) C(x y) -> Bool-nontrivialTriple (a :> b :> c) =- case commute (a :> b) of- Nothing -> False- Just (b' :> a') ->- case commute (a' :> c) of- Nothing -> False- Just (c'' :> a'') ->- case commute (b :> c) of- Nothing -> False- Just (c' :> b'') -> (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) &&- (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) &&- (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a'))
− src/Darcs/Test/Patch/Check.hs
@@ -1,347 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Test.Patch.Check ( PatchCheck(), doCheck, fileExists, dirExists,- removeFile, removeDir, createFile, createDir,- insertLine, deleteLine, isValid, doVerboseCheck,- fileEmpty,- checkMove, modifyFile, FileContents(..)- ) where--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.Class ( get, put, modify )--- 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 System.FilePath ( joinPath, splitDirectories )--#include "impossible.h"---- | File contents are represented by a map from line numbers to line contents.--- If for a certain line number, the line contents are Nothing, that means--- that we are sure that that line exists, but we don't know its contents.--- 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- , 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.---- | PatchCheck is a state monad with a simulated repository state-type PatchCheck = State KnownState---- | The @FileContents@ structure for an empty file-emptyFilecontents :: FileContents-emptyFilecontents = FC M.empty 0---- | Returns a given value if the repository state is inconsistent, and performs--- a given action otherwise.-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 p (P [] [])---- | Run a check, and print the final repository state-doVerboseCheck :: PatchCheck a -> a-doVerboseCheck p =- case runState p (P [] []) of- (b, pc) -> unsafePerformIO $ do print pc- return b---- | Returns true if the current repository state is not inconsistent-isValid :: PatchCheck Bool-isValid = handleInconsistent False (return True)--has :: Prop -> [Prop] -> Bool-has _ [] = False-has k (k':ks) = k == k' || has k ks--modifyFile :: String- -> (Maybe FileContents -> Maybe FileContents)- -> PatchCheck Bool-modifyFile f change = do- _ <- fileExists f- c <- fileContents f- case change c of- Nothing -> assertNot $ FileEx f -- shorthand for "FAIL"- Just c' -> do setContents f c'- isValid--insertLine :: String -> Int -> B.ByteString -> PatchCheck Bool-insertLine f n l = do- c <- fileContents f- case c of- Nothing -> assertNot $ FileEx f -- in this case, the repo is inconsistent- Just c' -> do- let lines' = M.mapKeys (\k -> if k >= n then k+1 else k) (fcLines c')- 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 f n l = do- c <- fileContents f- case c of- Nothing -> assertNot $ FileEx f- Just c' ->- let flines = fcLines c'- flines' = M.mapKeys (\k -> if k > n then k-1 else k)- (M.delete n flines)- maxlinenum' | n <= fcMaxline c' = fcMaxline c' - 1- | otherwise = n - 1- c'' = FC flines' maxlinenum'- do_delete = do- setContents f c''- isValid- in case M.lookup n flines of- Nothing -> do_delete- Just l' -> if l == l'- then do_delete- else assertNot $ FileEx f--setContents :: String -> FileContents -> PatchCheck ()-setContents f c = handleInconsistent () $ do- P ks nots <- get- let ks' = FileLines f c : filter (not . is_file_lines_for f) ks- put (P ks' nots)- where is_file_lines_for file prop = case prop of- FileLines f' _ -> file == f'- _ -> False---- | 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- P ks _ <- get- return (fic ks)- where fic (FileLines f' c:_) | f == f' = Just c- fic (_:ks) = fic ks- fic [] = Just emptyFilecontents---- | Checks if a file is empty-fileEmpty :: String -- ^ Name of the file to check- -> PatchCheck Bool-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- -- Crude way to make it inconsistent and return false:- else assertNot $ FileEx f- return empty--movedirfilename :: String -> String -> String -> String-movedirfilename d d' f- | (d ++ "/") `isPrefixOf` f = d' ++ drop (length d) f- | f == d = d'- | otherwise = f---- | 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- 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- | f' `is_soe` a = DirEx $ movedirfilename f' f a- sw (FileLines a c) | f `is_soe` a = FileLines (movedirfilename f f' a) c- | f' `is_soe` a = FileLines (movedirfilename f' f a) c- sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a- | f' `is_soe` a = NotEx $ movedirfilename f' f a- sw p = p- 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- P ks nots <- get- if has p nots- then do- put Inconsistent- return False- else if has p ks- then return True- else do- put (P (p:ks) nots)- return True---- | Like @assert@, but negatively: state that some property must not hold for--- the current repo.-assertNot :: Prop -> PatchCheck Bool-assertNot p = handleInconsistent False $ do- P ks nots <- get- if has p ks- then do- put Inconsistent- return False- else if has p nots- then return True- else do- put (P ks (p:nots))- return True---- | 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---- | 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- 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- assert $ FileEx f-assertDirExists :: String -> PatchCheck Bool-assertDirExists d = do _ <- assertNot $ NotEx d- _ <- assertNot $ FileEx d- assert $ DirEx d-assertExists :: String -> PatchCheck Bool-assertExists f = assertNot $ NotEx f--assertNoSuch :: String -> PatchCheck Bool-assertNoSuch f = do _ <- assertNot $ FileEx f- _ <- assertNot $ DirEx f- assert $ NotEx f--createFile :: String -> PatchCheck Bool-createFile fn = do- _ <- superdirsExist fn- _ <- assertNoSuch fn- _ <- changeToTrue (FileEx fn)- changeToFalse (NotEx fn)--createDir :: String -> PatchCheck Bool-createDir fn = do- _ <- substuffDontExist fn- _ <- superdirsExist fn- _ <- assertNoSuch fn- _ <- changeToTrue (DirEx fn)- changeToFalse (NotEx fn)--removeFile :: String -> PatchCheck Bool-removeFile fn = do- _ <- superdirsExist fn- _ <- assertFileExists fn- _ <- fileEmpty fn- _ <- changeToFalse (FileEx fn)- changeToTrue (NotEx fn)--removeDir :: String -> PatchCheck Bool-removeDir fn = do- _ <- substuffDontExist fn- _ <- superdirsExist fn- _ <- assertDirExists fn- _ <- changeToFalse (DirEx fn)- changeToTrue (NotEx fn)--checkMove :: String -> String -> PatchCheck Bool-checkMove f f' = do- _ <- superdirsExist f- _ <- superdirsExist f'- _ <- assertExists f- _ <- assertNoSuch f'- doSwap f f'--substuffDontExist :: String -> PatchCheck Bool-substuffDontExist d = handleInconsistent False $ do- P ks _ <- get- if all noss ks- then return True- else do- put Inconsistent- return False- where noss (FileEx f) = not (is_within_dir f)- noss (DirEx f) = not (is_within_dir f)- noss _ = True- is_within_dir f = (d ++ "/") `isPrefixOf` f---- 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- where superdirs = map (("./"++) . joinPath)- (init (tail (inits (tail (splitDirectories fn)))))--fileExists :: String -> PatchCheck Bool-fileExists fn = do- _ <- superdirsExist fn- assertFileExists fn--dirExists :: String -> PatchCheck Bool-dirExists fn = do- _ <- superdirsExist fn- assertDirExists fn
− src/Darcs/Test/Patch/Examples/Set1.hs
@@ -1,419 +0,0 @@--- Copyright (C) 2002-2005,2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}-{-# LANGUAGE CPP #-}--module Darcs.Test.Patch.Examples.Set1- ( knownCommutes, knownCantCommutes, knownMerges- , knownMergeEquivs, knownCanons, mergePairs2- , validPatches, commutePairs, mergePairs- , primitiveTestPatches, testPatches, testPatchesNamed- , primitiveCommutePairs ) where--import System.IO.Unsafe ( unsafePerformIO )-import qualified Data.ByteString.Char8 as BC ( pack )-import qualified Data.ByteString as B ( empty )-import Darcs.Patch- ( commute, invert, merge- , Named, namepatch- , readPatch, fromPrim- , adddir, addfile, hunk, binary, rmdir, rmfile, tokreplace )-import Darcs.Patch.Prim ( PrimOf, FromPrim )-import Darcs.Patch.Prim.V1 ( Prim )-import qualified Darcs.Patch.V1 as V1 ( Patch )-import Darcs.Test.Patch.Properties.Check( checkAPatch )-import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed ( unsafeUnseal )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )--#include "gadts.h"-#include "impossible.h"--type Patch = V1.Patch Prim---- The unit tester function is really just a glorified map for functions that--- return lists, in which the lists get concatenated (where map would end up--- with a list of lists).--quickmerge :: (FL Patch :\/: FL Patch) C(x y) -> FL Patch C(y z)-quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of- _ :/\: p1' -> unsafeCoercePEnd p1'---- ------------------------------------------------------------------------- * Show/Read tests--- -------------------------------------------------------------------------- | This test involves calling 'show' to print a string describing a patch,--- and then using readPatch to read it back in, and making sure the patch we--- read in is the same as the original. Useful for making sure that I don't--- have any stupid IO bugs.---- ------------------------------------------------------------------------- * Canonization tests--- ------------------------------------------------------------------------knownCanons :: [(FL Patch C(x y),FL Patch C(x y))]-knownCanons =- [(quickhunk 1 "abcde" "ab" :>: NilFL, quickhunk 3 "cde" "" :>: NilFL),- (quickhunk 1 "abcde" "bd" :>: NilFL,- quickhunk 1 "a" "" :>:- quickhunk 2 "c" "" :>:- quickhunk 3 "e" "" :>: NilFL),- (quickhunk 4 "a" "b" :>:- quickhunk 1 "c" "d" :>: NilFL,- quickhunk 1 "c" "d" :>:- quickhunk 4 "a" "b" :>: NilFL),- (quickhunk 1 "a" "" :>:- quickhunk 1 "" "b" :>: NilFL,- quickhunk 1 "a" "b" :>: NilFL),- (quickhunk 1 "ab" "c" :>:- quickhunk 1 "cd" "e" :>: NilFL,- quickhunk 1 "abd" "e" :>: NilFL),- (quickhunk 1 "abcde" "cde" :>: NilFL, quickhunk 1 "ab" "" :>: NilFL),- (quickhunk 1 "abcde" "acde" :>: NilFL, quickhunk 2 "b" "" :>: NilFL)]--quickhunk :: (FromPrim p, PrimOf p ~ Prim) => Int -> String -> String -> p C(x y)-quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o)- (map (\c -> BC.pack [c]) n)---- ------------------------------------------------------------------------- * Merge/unmgerge tests--- -------------------------------------------------------------------------- | It should always be true that if two patches can be unmerged, then merging--- the resulting patches should give them back again.-mergePairs :: [(FL Patch :\/: FL Patch) C(x y)]-mergePairs =- take 400 [(p1:\/:p2)|- i <- [0..(length testPatches)-1],- p1<-[testPatches!!i],- p2<-drop i testPatches,- checkAPatch (invert p2 :>: p1 :>: NilFL)]---- ------------------------------------------------------------------------- * Commute/recommute tests--- -------------------------------------------------------------------------- | Here we test to see if commuting patch A and patch B and then commuting--- the result gives us patch A and patch B again. The set of patches (A,B)--- is chosen from the set of all pairs of test patches by selecting those which--- commute with one another.-commutePairs :: [(FL Patch :> FL Patch) C(x y)]-commutePairs =- take 200 [(p1:>p2)|- p1<-testPatches,- p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatches,- commute (p1:>p2) /= Nothing]--primitiveCommutePairs :: [(FL Patch :> FL Patch) C(x y)]-primitiveCommutePairs =- [(p2:>p1)|- p1<-primitiveTestPatches,- p2<-primitiveTestPatches,- commute (p2:>p1) /= Nothing,- checkAPatch (p2:>:p1:>:NilFL)]---- ------------------------------------------------------------------------- * Commute tests--- -------------------------------------------------------------------------- | Here we provide a set of known interesting commutes.-knownCommutes :: [((FL Patch:<FL Patch) C(x y),(FL Patch:<FL Patch) C(x y))]-knownCommutes = [- (testhunk 1 [] ["A"]:<- testhunk 2 [] ["B"],- testhunk 3 [] ["B"]:<- testhunk 1 [] ["A"]),- (fromPrim (tokreplace "test" "A-Za-z_" "old" "new"):<- testhunk 2- ["hello world all that is old is good old_"]- ["I don't like old things"],- testhunk 2- ["hello world all that is new is good old_"]- ["I don't like new things"]:<- fromPrim (tokreplace "test" "A-Za-z_" "old" "new")),- (testhunk 1 ["A"] ["B"]:<- testhunk 2 ["C"] ["D"],- testhunk 2 ["C"] ["D"]:<- testhunk 1 ["A"] ["B"]),- (fromPrim (rmfile "NwNSO"):<- (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))),- (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))):<- fromPrim (rmfile "NwNSO")),-- (quickmerge (testhunk 3 ["o"] ["n"]:\/:- testhunk 3 ["o"] ["v"]):<- testhunk 1 [] ["a"],- testhunk 1 [] ["a"]:<- quickmerge (testhunk 2 ["o"] ["n"]:\/:- testhunk 2 ["o"] ["v"])),-- (testhunk 1 ["A"] []:<- testhunk 3 ["B"] [],- testhunk 2 ["B"] []:<- testhunk 1 ["A"] []),-- (testhunk 1 ["A"] ["B"]:<- testhunk 2 ["B"] ["C"],- testhunk 2 ["B"] ["C"]:<- testhunk 1 ["A"] ["B"]),-- (testhunk 1 ["A"] ["B"]:<- testhunk 3 ["B"] ["C"],- testhunk 3 ["B"] ["C"]:<- testhunk 1 ["A"] ["B"]),-- (testhunk 1 ["A"] ["B","C"]:<- testhunk 2 ["B"] ["C","D"],- testhunk 3 ["B"] ["C","D"]:<- testhunk 1 ["A"] ["B","C"])]- where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)--knownCantCommutes :: [(FL Patch:< FL Patch) C(x y)]-knownCantCommutes = [- (testhunk 2 ["o"] ["n"]:<- testhunk 1 [] ["A"]),- (testhunk 1 [] ["A"]:<- testhunk 1 ["o"] ["n"]),- (quickmerge (testhunk 2 ["o"] ["n"]:\/:- testhunk 2 ["o"] ["v"]):<- testhunk 1 [] ["a"]),- (fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])):<- fromPrim (addfile "test"))]- where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)---- ------------------------------------------------------------------------- * Merge tests--- -------------------------------------------------------------------------- | Here we provide a set of known interesting merges.-knownMerges :: [((FL Patch:\/:FL Patch) C(x y),FL Patch C(y z))]-knownMerges = [- (testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"]:\/:- testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"],- testhunk 3 [BC.pack "c"] [BC.pack "d",BC.pack "e"]),- (testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]:\/:- testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"],- testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]),- (testhunk 3 [BC.pack "A"] []:\/:- testhunk 1 [BC.pack "B"] [],- testhunk 2 [BC.pack "A"] []),- (fromPrim (rmdir "./test/world"):\/:- fromPrim (hunk "./world" 3 [BC.pack "A"] []),- fromPrim (rmdir "./test/world")),-- ((quickhunk 1 "a" "bc" :>:- quickhunk 6 "d" "ef" :>: NilFL):\/:- (quickhunk 3 "a" "bc" :>:- quickhunk 8 "d" "ef" :>: NilFL),- (quickhunk 1 "a" "bc" :>:- quickhunk 7 "d" "ef" :>: NilFL)),-- (testhunk 1 [BC.pack "A"] [BC.pack "B"]:\/:- testhunk 2 [BC.pack "B"] [BC.pack "C"],- testhunk 1 [BC.pack "A"] [BC.pack "B"]),-- (testhunk 2 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:\/:- testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"],- testhunk 3 [BC.pack "A"] [BC.pack "B",BC.pack "C"])]- where testhunk l o n = fromPrim $ hunk "test" l o n--knownMergeEquivs :: [((FL Patch :\/: FL Patch) C(x y), FL Patch C(y z))]-knownMergeEquivs = [-- -- The following tests are going to be failed by the- -- Conflictor code as a cleanup.-- --(addfile "test":\/:- -- adddir "test",- -- joinPatches (adddir "test" :>:- -- addfile "test-conflict" :>: NilFL)),- --(move "silly" "test":\/:- -- adddir "test",- -- joinPatches (adddir "test" :>:- -- move "silly" "test-conflict" :>: NilFL)),- --(addfile "test":\/:- -- move "old" "test",- -- joinPatches (addfile "test" :>:- -- move "old" "test-conflict" :>: NilFL)),- --(move "a" "test":\/:- -- move "old" "test",- -- joinPatches (move "a" "test" :>:- -- move "old" "test-conflict" :>: NilFL)),- (fromPrim (hunk "test" 1 [] [BC.pack "A"]) :\/:- fromPrim (hunk "test" 1 [] [BC.pack "B"]),- fromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])),- (fromPrim (hunk "test" 1 [] [BC.pack "a"]):\/:- fromPrim (hunk "test" 1 [BC.pack "b"] []),- unsafeCoerceP NilFL),- --hunk "test" 1 [] [BC.pack "v v v v v v v",- -- BC.pack "*************",- -- BC.pack "a",- -- BC.pack "b",- -- BC.pack "^ ^ ^ ^ ^ ^ ^"]),- (quickhunk 4 "a" "" :\/:- quickhunk 3 "a" "",- quickhunk 3 "aa" ""),- ((quickhunk 1 "a" "bc" :>:- quickhunk 6 "d" "ef" :>: NilFL) :\/:- (quickhunk 3 "a" "bc" :>:- quickhunk 8 "d" "ef" :>: NilFL),- quickhunk 3 "a" "bc" :>:- quickhunk 8 "d" "ef" :>:- quickhunk 1 "a" "bc" :>:- quickhunk 7 "d" "ef" :>: NilFL),- (quickmerge (quickhunk 2 "" "bd":\/:quickhunk 2 "" "a") :\/:- quickmerge (quickhunk 2 "" "c":\/:quickhunk 2 "" "a"),- quickhunk 2 "" "abdc")- ]----- | It also is useful to verify that it doesn't matter which order we specify--- the patches when we merge.-mergePairs2 :: [(FL Patch C(x y), FL Patch C(x z))]-mergePairs2 = [(p1, p2) |- p1<-primitiveTestPatches,- p2<-primitiveTestPatches,- checkAPatch (invert p1:>:p2:>:NilFL)- ]---- ------------------------------------------------------------------------- Patch test data--- This is where we define the set of patches which we run our tests on. This--- should be kept up to date with as many interesting permutations of patch--- types as possible.--- ------------------------------------------------------------------------testPatches :: [FL Patch C(x y)]-testPatchesNamed :: [Named Patch C(x y)]-testPatchesAddfile :: [FL Patch C(x y)]-testPatchesRmfile :: [FL Patch C(x y)]-testPatchesHunk :: [FL Patch C(x y)]-primitiveTestPatches :: [FL Patch C(x y)]-testPatchesBinary :: [FL Patch C(x y)]-testPatchesCompositeNocom :: [FL Patch C(x y)]-testPatchesComposite :: [FL Patch C(x y)]-testPatchesTwoCompositeHunks :: [FL Patch C(x y)]-testPatchesCompositeHunks :: [FL Patch C(x y)]-testPatchesCompositeFourHunks :: [FL Patch C(x y)]-testPatchesMerged :: [FL Patch C(x y)]-validPatches :: [FL Patch C(x y)]--testPatchesNamed = [unsafePerformIO $- namepatch "date is" "patch name" "David Roundy" []- (fromPrim $ addfile "test"),- unsafePerformIO $- namepatch "Sat Oct 19 08:31:13 EDT 2002"- "This is another patch" "David Roundy"- ["This log file has","two lines in it"]- (fromPrim $ rmfile "test")]-testPatchesAddfile = map fromPrim- [addfile "test",adddir "test",addfile "test/test"]-testPatchesRmfile = map invert testPatchesAddfile-testPatchesHunk =- [fromPrim (hunk file line old new) |- file <- ["test"],- line <- [1,2],- old <- map (map BC.pack) partials,- new <- map (map BC.pack) partials,- old /= new- ]- where partials = [["A"],["B"],[],["B","B2"]]--primitiveTestPatches = testPatchesAddfile ++- testPatchesRmfile ++- testPatchesHunk ++- [unsafeUnseal.fromJust.readPatch $- BC.pack "move ./test/test ./hello",- unsafeUnseal.fromJust.readPatch $- BC.pack "move ./test ./hello"] ++- testPatchesBinary--testPatchesBinary =- [fromPrim $ binary "./hello"- (BC.pack $ "agadshhdhdsa75745457574asdgg" ++- "a326424677373735753246463gadshhdhdsaasdgg" ++- "a326424677373735753246463gadshhdhdsaasdgg" ++- "a326424677373735753246463gadshhdhdsaasdgg")- (BC.pack $ "adafjttkykrehhtrththrthrthre" ++- "a326424677373735753246463gadshhdhdsaasdgg" ++- "a326424677373735753246463gadshhdhdsaasdgg" ++- "a326424677373735753246463gadshhdhdsaagg"),- fromPrim $ binary "./hello"- B.empty- (BC.pack "adafjttkykrere")]--testPatchesCompositeNocom =- take 50 [p1+>+p2|- p1<-primitiveTestPatches,- p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) primitiveTestPatches,- commute (p1:>p2) == Nothing]--testPatchesComposite =- take 100 [p1+>+p2|- p1<-primitiveTestPatches,- p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) primitiveTestPatches,- commute (p1:>p2) /= Nothing,- commute (p1:>p2) /= Just (unsafeCoerceP p2:>unsafeCoerceP p1)]--testPatchesTwoCompositeHunks =- take 100 [p1+>+p2|- p1<-testPatchesHunk,- p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk]--testPatchesCompositeHunks =- take 100 [p1+>+p2+>+p3|- p1<-testPatchesHunk,- p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk,- p3<-filter (\p->checkAPatch (p1:>:p2:>:p:>:NilFL)) testPatchesHunk]--testPatchesCompositeFourHunks =- take 100 [p1+>+p2+>+p3+>+p4|- p1<-testPatchesHunk,- p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk,- p3<-filter (\p->checkAPatch (p1:>:p2:>:p:>:NilFL)) testPatchesHunk,- p4<-filter (\p->checkAPatch (p1:>:p2:>:p3:>:p:>:NilFL)) testPatchesHunk]--testPatchesMerged =- take 200- [p2+>+quickmerge (p1:\/:p2) |- p1<-take 10 (drop 15 testPatchesCompositeHunks)++primitiveTestPatches- ++take 10 (drop 15 testPatchesTwoCompositeHunks)- ++ take 2 (drop 4 testPatchesCompositeFourHunks),- p2<-take 10 testPatchesCompositeHunks++primitiveTestPatches- ++take 10 testPatchesTwoCompositeHunks- ++take 2 testPatchesCompositeFourHunks,- checkAPatch (invert p1 :>: p2 :>: NilFL),- commute (p2:>p1) /= Just (p1:>p2)- ]--testPatches = primitiveTestPatches ++- testPatchesComposite ++- testPatchesCompositeNocom ++- testPatchesMerged---- ------------------------------------------------------------------------- * Check patch test--- ------------------------------------------------------------------------validPatches = [(quickhunk 4 "a" "b" :>:- quickhunk 1 "c" "d" :>: NilFL),- (quickhunk 1 "a" "bc" :>:- quickhunk 1 "b" "d" :>: NilFL),- (quickhunk 1 "a" "b" :>:- quickhunk 1 "b" "d" :>: NilFL)]++testPatches
− src/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs
@@ -1,492 +0,0 @@--- Copyright (C) 2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Test.Patch.Examples.Set2Unwitnessed- ( primPermutables, primPatches- , commutables, commutablesFL- , realCommutables , realMergeables, realTriples- , realNonduplicateTriples, realPatches, realPatchLoopExamples- ) where--import Data.Maybe ( catMaybes )-import qualified Data.ByteString.Char8 as BC ( pack )-import Darcs.Witnesses.Sealed-import Darcs.Patch ( invert, hunk )-import Darcs.Patch.Patchy ( Invert(..) )-import Darcs.Patch.Prim ( PrimPatch )-import Darcs.Patch.Prim.V1 ( Prim )-import Darcs.Patch.V2 ( RealPatch )-import Darcs.Patch.V2.Real ( prim2real )--- import Darcs.Test.Patch.Test () -- for instance Eq Patch--- import Darcs.Test.Patch.Examples.Set2Unwitnessed-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import qualified Darcs.Test.Patch.Arbitrary.Real as W ( notDuplicatestriple )---import Printer ( greenText )---import Darcs.ColorPrinter ( traceDoc )---import Darcs.ColorPrinter ( errorDoc )-import Darcs.ColorPrinter () -- for instance Show Doc-import Darcs.Test.Patch.WSub--import qualified Darcs.Witnesses.Ordered as W ( (:>), (:\/:) )-import qualified Data.ByteString as B ( ByteString )-import Darcs.Test.Patch.V1Model ( V1Model, Content- , makeRepo, makeName, makeFile)-import Darcs.Test.Patch.WithState ( WithStartState(..) )-import Darcs.Patch.Prim.V1.Core ( Prim(FP), FilePatchType(Hunk) )-import Darcs.Patch.FileName ( FileName, fp2fn )-import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim )-import Darcs.Patch.Merge ( Merge )-import Darcs.Test.Patch.Arbitrary.Generic- ( Tree(..)- , TreeWithFlattenPos(..)- , commutePairFromTree, commuteTripleFromTree- , mergePairFromCommutePair, commutePairFromTWFP- , canonizeTree- )---- import Debug.Trace--- #include "impossible.h"--makeSimpleRepo :: String -> Content -> V1Model C(x)-makeSimpleRepo filename content = makeRepo [(makeName filename, makeFile content)]---w_tripleExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:> p W.:> p)]-w_tripleExamples = [commuteTripleFromTree seal2 $- WithStartState (makeSimpleRepo "file" [])- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "g"]))- (SeqTree (FP (fp2fn "./file") (Hunk 2 [] [BC.pack "j"]))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "s"])) NilTree)))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "e"])) NilTree))- ,commuteTripleFromTree seal2 $- WithStartState (makeSimpleRepo "file" [BC.pack "j"])- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "s"]))- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "j"] [])) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "j"] [])) NilTree)))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree))- ]---w_mergeExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:\/: p)]-w_mergeExamples = map (unseal2 (mergePairFromCommutePair seal2)) w_commuteExamples--w_commuteExamples :: (FromPrim p, Merge p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:> p)]-w_commuteExamples = [- commutePairFromTWFP seal2 $- WithStartState (makeSimpleRepo "file" [])- (TWFP 3- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"])) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "b"]))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"]))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"]))- (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "f"] [])) NilTree)))))),- commutePairFromTWFP seal2 $- WithStartState- (makeSimpleRepo "file" [BC.pack "f",BC.pack "s",BC.pack "d"])- (TWFP 3- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "d"] [])) NilTree)- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] [])) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] []))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "s",BC.pack "d"] []))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree)))))),-{- commutePairFromTWFP seal2 $- WithStartState- (makeSimpleRepo "file" [BC.pack "f",BC.pack "u",- BC.pack "s",BC.pack "d"])- (TWFP 5- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 5 [] [BC.pack "x"]))- (SeqTree (FP (fp2fn "./file") (Hunk 4 [BC.pack "d"] [])) NilTree))- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f",BC.pack "u"] [])) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] []))- (SeqTree (FP(fp2fn "./file") (Hunk 1 [BC.pack "u",BC.pack "s",BC.pack "d"] []))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "a"]))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "a"] [])) NilTree))))))),-}- commutePairFromTree seal2 $- WithStartState (makeSimpleRepo "file" [BC.pack "n",BC.pack "t",BC.pack "h"])- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "n",BC.pack "t",BC.pack "h"] []))- NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "h"] []))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "n"] []))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t"] [])) NilTree)))),- commutePairFromTree seal2 $- WithStartState (makeSimpleRepo "file" [])- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "n"])) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "i"]))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "i"])) NilTree))),- commutePairFromTree seal2 $- WithStartState (makeSimpleRepo "file" [])- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "c"]))- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "c"] [BC.pack "r"])) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"]))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "d"])) NilTree))))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree)),- commutePairFromTWFP seal2 $- WithStartState (makeSimpleRepo "file" [])- (TWFP 1- (ParTree- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "t"])) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "t"])) NilTree))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree))),- commutePairFromTWFP seal2 $- WithStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack " r",- BC.pack "c",BC.pack "v"])- (TWFP 4- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "c",BC.pack "v"] []))- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "r"] []))- (SeqTree (FP (fp2fn "fi le") (Hunk 1 [BC.pack "f"] [])) NilTree))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f",BC.pack "r"] []))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "y"])) NilTree))))- (SeqTree (FP (fp2fn "./file") (Hunk 4 [BC.pack "v"] [])) NilTree))),- commutePairFromTree seal2 $- WithStartState (makeSimpleRepo "file" [])- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "z"])) NilTree)- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree)- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "r"])) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "d"])) NilTree))))- , commutePairFromTree seal2 $- WithStartState (makeSimpleRepo "file" [BC.pack "t",BC.pack "r",BC.pack "h"])- (ParTree- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t",BC.pack "r",BC.pack "h"] []))- NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "o"])) NilTree))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t"] []))- (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "h"] [])) NilTree)))- , commutePairFromTWFP seal2 $- WithStartState (makeSimpleRepo "file" []) $- TWFP 2- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"])) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "y"]))- (SeqTree (FP (fp2fn "./file") (Hunk 2 [] [BC.pack "m"]))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree))))- , commutePairFromTree seal2 $- WithStartState (makeSimpleRepo "file" [])- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "p"]))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "p"] []))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "c"])) NilTree)))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "z"])) NilTree))- , commutePairFromTree seal2 $- WithStartState (makeSimpleRepo "file" [])- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j" ]))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree))- , commutePairFromTree seal2 $- WithStartState (makeSimpleRepo "file" [])- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j" ]))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree)))- , commutePairFromTree seal2 $- WithStartState (makeSimpleRepo "file" [BC.pack "x",BC.pack "c"])- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"]))- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "c"] [])) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "x"] []))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j"])) NilTree))))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "l"])) NilTree))- , commutePairFromTree seal2 $- WithStartState (makeSimpleRepo "file" [])- (ParTree- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "s"))) NilTree)- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "k")))- (SeqTree (FP (fp2fn "./file") (Hunk 1 (packStringLetters "k") []))- (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "m")))- (SeqTree (FP (fp2fn "./file") (Hunk 1 (packStringLetters "m") [])) NilTree)))))- ]--packStringLetters :: String -> [B.ByteString]-packStringLetters = map (BC.pack . (:[]))--w_realPatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))]-w_realPatchLoopExamples =- [Sealed (WithStartState (makeSimpleRepo fx_name [])- $ canonizeTree- (ParTree- (SeqTree (FP fx (Hunk 1 [] (packStringLetters "pkotufogbvdabnmbzajvolwviqebieonxvcvuvigkfgybmqhzuaaurjspd")))- (ParTree- (SeqTree (FP fx (Hunk 47 (packStringLetters "qhzu") (packStringLetters "zafybdcokyjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmh")))- (ParTree- (ParTree- NilTree- (ParTree- (ParTree- (ParTree- (SeqTree (FP fx (Hunk 15 (packStringLetters "mbzajvolwviqebieonxvcvuvigkfgyb") (packStringLetters "vujnxnhvybvpouyciaabszfmgssezlwwjgnethvrpnfrkubphzvdgymjjoacppqps")))- (ParTree- NilTree- (ParTree- (SeqTree (FP fx (Hunk 40 (packStringLetters "ssezlwwjgnethvrpnfrkubphzvdgymjjoacppqpsmzafybdcokyjskcgnvhkbz") (packStringLetters "wnesidpccwoiqiichxaaejdsyrhrusqljlcoro")))- (ParTree- (ParTree- (SeqTree (FP fx (Hunk 12 (packStringLetters "abnvujnxnhvybvpouyciaabszfmgwnesidpccwoiqii") (packStringLetters "czfdhqkipdstfjycqaxwnbxrihrufdeyneqiiiafwzlmg"))) NilTree)- NilTree)- NilTree))- (SeqTree (FP fx (Hunk 25 [] (packStringLetters "dihgmsotezucqdgxczvcivijootyvhlwymbiueufnvpwpeukmskqllalfe"))) NilTree))))- (SeqTree (FP fx (Hunk 56 (packStringLetters "yjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmhaaurjsp") (packStringLetters "xldhrutyhcyaqeezwujiguawfyawjjqlirxshjddvq"))) NilTree))- (SeqTree (FP fx (Hunk 20 [] (packStringLetters "ooygwiyogqrqnytixqtmvdxx")))- (SeqTree (FP fx (Hunk 26 (packStringLetters "yogqrqnytixqtmvdxxvolwviqebieonxvcvuvigkfgybmzafybdcokyjskcgnvhkbz") (packStringLetters "akhsmlbkdxnvfoikmiatfbpzdrsyykkpoxvvddeaspzxe")))- (SeqTree (FP fx (Hunk 39 [] (packStringLetters "ji")))- (ParTree- NilTree- (ParTree- NilTree- (ParTree- (ParTree- NilTree- (SeqTree (FP fx (Hunk 26 (packStringLetters "akhsmlbkdxnvfjioikmiatfbpzdrsyykkpoxvvddeaspzxepysaafnjjhcstgrczplxs") (packStringLetters "onjbhddskcj")))- (SeqTree (FP fx (Hunk 39 [] (packStringLetters "fyscunxxxjjtyqpfxeznhtwvlphmp"))) NilTree)))- (ParTree- NilTree- (SeqTree (FP fx (Hunk 44 [] (packStringLetters "xcchzwmzoezxkmkhcmesplnjpqriypshgiqklgdnbmmkldnydiy")))- (ParTree- NilTree- (SeqTree (FP fx (Hunk 64 (packStringLetters "plnjpqriypshgiqklgdnbmmkldnydiymiatfbpzdrsyykkpoxvvddeaspzxepysaafn") (packStringLetters "anjlzfdqbjqbcplvqvkhwjtkigp"))) NilTree)))))))))))- (ParTree- NilTree- NilTree)))- NilTree))- NilTree))- (ParTree- NilTree- (SeqTree (FP fx (Hunk 1 [] (packStringLetters "ti")))- (SeqTree (FP fx (Hunk 1 (packStringLetters "t") (packStringLetters "ybcop")))- (SeqTree (FP fx (Hunk 2 [] (packStringLetters "dvlhgwqlpaeweerqrhnjtfolczbqbzoccnvdsyqiefqitrqneralf")))- (SeqTree (FP fx (Hunk 15 [] (packStringLetters "yairbjphwtnaerccdlfewujvjvmjakbc")))- (SeqTree (FP fx (Hunk 51 [] (packStringLetters "xayvfuwaiiogginufnhsrmktpmlbvxiakjwllddkiyofyfw")))- (ParTree- NilTree- NilTree)))))))))]- where- fx_name :: String- fx_name = "F"-- fx :: FileName- fx = fp2fn "./F"---mergeExamples :: [Sealed2 (RealPatch Prim :\/: RealPatch Prim)]-mergeExamples = map (mapSeal2 fromW) w_mergeExamples--realPatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))]-realPatchLoopExamples = w_realPatchLoopExamples--commuteExamples :: [Sealed2 (RealPatch Prim :> RealPatch Prim)]-commuteExamples = map (mapSeal2 fromW) w_commuteExamples--tripleExamples :: [Sealed2 (RealPatch Prim :> RealPatch Prim :> RealPatch Prim)]-tripleExamples = map (mapSeal2 fromW) w_tripleExamples--notDuplicatestriple :: (RealPatch Prim :> RealPatch Prim :> RealPatch Prim) C(x y) -> Bool-notDuplicatestriple = W.notDuplicatestriple . toW--quickhunk :: PrimPatch prim => Int -> String -> String -> prim C(x y)-quickhunk l o n = hunk "test" l (map (\c -> BC.pack [c]) o)- (map (\c -> BC.pack [c]) n)--primPermutables :: [(Prim :> Prim :> Prim) C(x y)]-primPermutables =- [quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"]--mergeables :: [(Prim :\/: Prim) C(x y)]-mergeables = [quickhunk 1 "a" "b" :\/: quickhunk 1 "a" "c",- quickhunk 1 "a" "b" :\/: quickhunk 3 "z" "c",- quickhunk 0 "" "a" :\/: quickhunk 1 "" "b",- quickhunk 0 "a" "" :\/: quickhunk 1 "" "b",- quickhunk 0 "a" "" :\/: quickhunk 1 "b" "",- quickhunk 0 "" "a" :\/: quickhunk 1 "b" ""- ]--mergeablesFL :: [(FL Prim :\/: FL Prim) C(x y)]-mergeablesFL = map (\ (x:\/:y) -> (x :>: NilFL) :\/: (y :>: NilFL)) mergeables ++- [] -- [(quickhunk 1 "a" "b" :>: quickhunk 3 "z" "c" :>: NilFL)- -- :\/: (quickhunk 1 "a" "z" :>: NilFL),- -- (quickhunk 1 "a" "b" :>: quickhunk 1 "b" "c" :>: NilFL)- -- :\/: (quickhunk 1 "a" "z" :>: NilFL)]--mergeable2commutable :: Invert p => (p :\/: p) C(x y) -> (p :> p) C(x y)-mergeable2commutable (x :\/: y) = unsafeCoerceP (invert x) :> y--commutablesFL :: [(FL Prim :> FL Prim) C(x y)]-commutablesFL = map mergeable2commutable mergeablesFL-commutables :: [(Prim :> Prim) C(x y)]-commutables = map mergeable2commutable mergeables--primPatches :: [Prim C(x y)]-primPatches = concatMap mergeable2patches mergeables- where mergeable2patches (x:\/:y) = [x,y]--realPatches :: [RealPatch Prim C(x y)]-realPatches = concatMap commutable2patches realCommutables- where commutable2patches (x:>y) = [x,y]--realTriples :: [(RealPatch Prim :> RealPatch Prim :> RealPatch Prim) C(x y)]-realTriples = [ob' :> oa2 :> a2'',- oa' :> oa2 :> a2'']- ++ map unsafeUnseal2 tripleExamples- ++ map unsafeUnseal2 (concatMap getTriples realFLs)- where oa = prim2real $ quickhunk 1 "o" "aa"- oa2 = oa- a2 = prim2real $ quickhunk 2 "a34" "2xx"- ob = prim2real $ quickhunk 1 "o" "bb"- ob' :/\: oa' = merge (oa :\/: ob)- a2' :/\: _ = merge (ob' :\/: a2)- a2'' :/\: _ = merge (oa2 :\/: a2')--realNonduplicateTriples :: [(RealPatch Prim :> RealPatch Prim :> RealPatch Prim) C(x y)]-realNonduplicateTriples = filter (notDuplicatestriple) realTriples--realFLs :: [FL (RealPatch Prim) C(x y)]-realFLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL]- where oa = prim2real $ quickhunk 1 "o" "a"- ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL)--realCommutables :: [(RealPatch Prim :> RealPatch Prim) C(x y)]-realCommutables = map unsafeUnseal2 commuteExamples++- map mergeable2commutable realMergeables++- [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs realFLs)- where oa = prim2real $ quickhunk 1 "o" "a"- ob = prim2real $ quickhunk 1 "o" "b"- _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL)--realMergeables :: [(RealPatch Prim :\/: RealPatch Prim) C(x y)]-realMergeables = map (\ (x :\/: y) -> prim2real x :\/: prim2real y) mergeables- ++ realIglooMergeables- ++ realQuickcheckMergeables- ++ map unsafeUnseal2 mergeExamples- ++ catMaybes (map pair2m (concatMap getPairs realFLs))- ++ [(oa :\/: od),- (oa :\/: a2'),- (ob' :\/: od''),- (oe :\/: od),- (of' :\/: oe'),- (ob' :\/: oe'),- (oa :\/: oe'),- (ob' :\/: oc'),- (b2' :\/: oc'''),- (ob' :\/: a2),- (b2' :\/: og'''),- (oc''' :\/: og'''),- (oc'' :\/: og''),- (ob'' :\/: og''),- (ob'' :\/: oc''),- (oc' :\/: od'')]- where oa = prim2real $ quickhunk 1 "o" "aa"- a2 = prim2real $ quickhunk 2 "a34" "2xx"- og = prim2real $ quickhunk 3 "4" "g"- ob = prim2real $ quickhunk 1 "o" "bb"- b2 = prim2real $ quickhunk 2 "b" "2"- oc = prim2real $ quickhunk 1 "o" "cc"- od = prim2real $ quickhunk 7 "x" "d"- oe = prim2real $ quickhunk 7 "x" "e"- pf = prim2real $ quickhunk 7 "x" "f"- od'' = prim2real $ quickhunk 8 "x" "d"- ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL)- a2' :/\: _ = merge (ob' :\/: a2)- ob'' :/\: _ = merge (a2 :\/: ob')- og' :/\: _ = merge (oa :\/: og)- og'' :/\: _ = merge (a2 :\/: og')- og''' :/\: _ = merge (ob' :\/: og')- oc' :/\: _ = merge (oa :\/: oc)- oc'' :/\: _ = merge (a2 :\/: oc)- oc''' :/\: _ = merge (ob' :\/: oc')- oe' :/\: _ = merge (od :\/: oe)- of' :/\: _ = merge (od :\/: pf)- pair2m :: Sealed2 (RealPatch Prim :> RealPatch Prim)- -> Maybe ((RealPatch Prim :\/: RealPatch Prim) C(x y))- pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)- return $ unsafeCoerceP (xx :\/: y')--realIglooMergeables :: [(RealPatch Prim :\/: RealPatch Prim) C(x y)]-realIglooMergeables = [(a :\/: b),- (b :\/: c),- (a :\/: c),- (x :\/: a),- (y :\/: b),- (z :\/: c),- (x' :\/: y'),- (z' :\/: y'),- (x' :\/: z'),- (a :\/: a)]- where a = prim2real $ quickhunk 1 "1" "A"- b = prim2real $ quickhunk 2 "2" "B"- c = prim2real $ quickhunk 3 "3" "C"- x = prim2real $ quickhunk 1 "1BC" "xbc"- y = prim2real $ quickhunk 1 "A2C" "ayc"- z = prim2real $ quickhunk 1 "AB3" "abz"- x' :/\: _ = merge (a :\/: x)- y' :/\: _ = merge (b :\/: y)- z' :/\: _ = merge (c :\/: z)--realQuickcheckMergeables :: [(RealPatch Prim :\/: RealPatch Prim) C(x y)]-realQuickcheckMergeables = [-- invert k1 :\/: n1- --, invert k2 :\/: n2- hb :\/: k- , b' :\/: b'- , n' :\/: n'- , b :\/: d- , k' :\/: k'- , k3 :\/: k3- ] ++ catMaybes (map pair2m pairs)- where hb = prim2real $ quickhunk 0 "" "hb"- k = prim2real $ quickhunk 0 "" "k"- n = prim2real $ quickhunk 0 "" "n"- b = prim2real $ quickhunk 1 "b" ""- d = prim2real $ quickhunk 2 "" "d"- d':/\:_ = merge (b :\/: d)- --k1 :>: n1 :>: NilFL :/\: _ = mergeFL (hb :\/: k :>: n :>: NilFL)- --k2 :>: n2 :>: NilFL :/\: _ =- -- merge (hb :>: b :>: NilFL :\/: k :>: n :>: NilFL)- k' :>: n' :>: NilFL :/\: _ :>: b' :>: _ = merge (hb :>: b :>: d' :>: NilFL :\/: k :>: n :>: NilFL)- pairs = getPairs (hb :>: b :>: d' :>: k' :>: n' :>: NilFL)- pair2m :: Sealed2 (RealPatch Prim :> RealPatch Prim)- -> Maybe ((RealPatch Prim :\/: RealPatch Prim) C(x y))- pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)- return $ unsafeCoerceP (xx :\/: y')-- i = prim2real $ quickhunk 0 "" "i"- x = prim2real $ quickhunk 0 "" "x"- xi = prim2real $ quickhunk 0 "xi" ""- d3 :/\: _ = merge (xi :\/: d)- _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL)-
− src/Darcs/Test/Patch/Info.hs
@@ -1,163 +0,0 @@--- Copyright (C) 2009 Reinier Lamers------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- | This module contains tests for the code in Darcs.Patch.Info. Most of them--- are about the UTF-8-encoding of patch metadata.-module Darcs.Test.Patch.Info ( testSuite ) where--import Prelude hiding ( pi )-import Data.ByteString ( ByteString )-import qualified Data.ByteString as B ( split, pack )-import qualified Data.ByteString.Char8 as BC ( unpack )-import Data.List ( sort )-import Data.Maybe ( isNothing )-import Data.Text as T ( find, any )-import Data.Text.Encoding ( decodeUtf8With )-import Data.Text.Encoding.Error ( lenientDecode )-import System.IO.Unsafe ( unsafePerformIO )-import Test.QuickCheck ( Arbitrary(arbitrary), oneof, listOf, choose, shrink- , Gen )-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.Framework (Test, testGroup)-import Data.List ( isPrefixOf )--import Darcs.Patch.Info ( PatchInfo(..), patchinfo,- piLog, piAuthor, piName )-import ByteStringUtils ( decodeLocale, packStringToUTF8, unpackPSFromUTF8 )--testSuite :: Test-testSuite = testGroup "Darcs.Patch.Info"- [ metadataDecodingTest- , metadataEncodingTest- , packUnpackTest- ]---- | A newtype wrapping String so we can make our own random generator for it.-newtype UnicodeString = UnicodeString { asString :: String }- deriving (Show, Eq, Ord)---- | A newtype wrapping PatchInfo that has a random generator that generates--- both UTF-8-encoded and non-encoded PatchInfo's.-newtype UTF8OrNotPatchInfo = UTF8OrNotPatchInfo PatchInfo deriving (Eq, Ord)---- | A newtype wrapping PatchInfo, which has a random generator that generates--- only UTF-8-encoded PatchInfo's.-newtype UTF8PatchInfo = UTF8PatchInfo PatchInfo deriving (Eq, Ord)--instance Arbitrary UnicodeString where- -- 0x10ffff is the highest Unicode code point ; 0xd800 - 0xdfff are- -- surrogates. '\xfffd' is excluded because it is used as a marker- -- for UTF-8 test failure.- arbitrary = UnicodeString `fmap` listOf (oneof [choose ('\0', '\xd799')- ,choose ('\xe000', '\xfffc')- ,choose ('\xfffe', '\x10ffff')])--instance Show UTF8PatchInfo where- showsPrec _ = withUTF8PatchInfo rawPatchInfoShow-instance Show UTF8OrNotPatchInfo where- showsPrec _ = withUTF8OrNotPatchInfo rawPatchInfoShow---- | Shows a PatchInfo, outputting every byte and clearly marking what is what-rawPatchInfoShow :: PatchInfo -> String -> String-rawPatchInfoShow pi = ("PatchInfo: \n"++)- . ("date: "++) . shows (_piDate pi) . ('\n':)- . ("author: "++) . shows (_piAuthor pi) . ('\n':)- . ("name: "++) . shows (_piName pi) . ('\n':)- . ("log: "++) . shows (_piLog pi) . ('\n':)--instance Arbitrary UTF8PatchInfo where- arbitrary = UTF8PatchInfo `fmap` arbitraryUTF8Patch- shrink upi = flip withUTF8PatchInfo upi $ \pi -> do- sn <- shrink (piName pi)- sa <- shrink (piAuthor pi)- sl <- shrink (filter (not . isPrefixOf "Ignore-this:") (piLog pi))- return (UTF8PatchInfo- (unsafePerformIO $ patchinfo sn- (BC.unpack (_piDate pi)) sa sl))--instance Arbitrary UTF8OrNotPatchInfo where- arbitrary = UTF8OrNotPatchInfo `fmap` oneof ([arbitraryUTF8Patch,- arbitraryUnencodedPatch])---- | Generate arbitrary patch metadata that uses the metadata creation function--- 'patchinfo' from Darcs.Patch.Info.-arbitraryUTF8Patch :: Gen PatchInfo-arbitraryUTF8Patch =- do n <- asString `fmap` arbitrary- d <- arbitrary- a <- asString `fmap` arbitrary- l <- (lines . asString) `fmap` arbitrary- return $ unsafePerformIO $ patchinfo n d a l---- | Generate arbitrary patch metadata that has totally arbitrary byte strings--- as its name, date, author and log.-arbitraryUnencodedPatch :: Gen PatchInfo-arbitraryUnencodedPatch = do- n <- arbitraryByteString- d <- arbitraryByteString- a <- arbitraryByteString- -- split 10 is the ByteString equivalent of 'lines'- l <- B.split 10 `fmap` arbitraryByteString- i <- arbitrary- return (PatchInfo d n a l i)--arbitraryByteString :: Gen ByteString-arbitraryByteString = (B.pack . map fromIntegral)- `fmap` listOf (choose (0, 255) :: Gen Int)---- | Test that anything produced by the 'patchinfo' function is valid UTF-8-metadataEncodingTest :: Test-metadataEncodingTest = testProperty "Testing patch metadata encoding" $- withUTF8PatchInfo $- \patchInfo -> encodingOK (_piAuthor patchInfo)- && encodingOK (_piName patchInfo)- && all encodingOK (_piLog patchInfo)- where encodingOK = isNothing . T.find (=='\xfffd') . decodeUtf8With lenientDecode---- | Test that metadata in patches are decoded as UTF-8 or locale depending on--- whether they're valid UTF-8.-metadataDecodingTest :: Test-metadataDecodingTest = testProperty "Testing patch metadata decoding" $- withUTF8OrNotPatchInfo $- \patchInfo -> utf8OrLocale (_piAuthor patchInfo) == piAuthor patchInfo- && utf8OrLocale (_piName patchInfo) == piName patchInfo- && map utf8OrLocale (_piLog patchInfo) `superset` piLog patchInfo- where utf8OrLocale bs = if isValidUTF8 bs- then unpackPSFromUTF8 bs- else decodeLocale bs--isValidUTF8 :: ByteString -> Bool-isValidUTF8 = not . T.any (=='\xfffd') . decodeUtf8With lenientDecode--packUnpackTest :: Test-packUnpackTest = testProperty "Testing UTF-8 packing and unpacking" $- \uString -> asString uString == (unpackPSFromUTF8 . packStringToUTF8) (asString uString)--superset :: (Eq a, Ord a) => [a] -> [a] -> Bool-superset a b = sorted_superset (sort a) (sort b)- where sorted_superset (x:xs) (y:ys) | x == y = sorted_superset xs ys- | x < y = sorted_superset xs (y:ys)- | otherwise = False- sorted_superset [] (_:_) = False- sorted_superset _ [] = True--withUTF8PatchInfo :: (PatchInfo -> a) -> UTF8PatchInfo -> a-withUTF8PatchInfo f mpi = case mpi of- UTF8PatchInfo pinf -> f pinf-withUTF8OrNotPatchInfo :: (PatchInfo -> a) -> UTF8OrNotPatchInfo -> a-withUTF8OrNotPatchInfo f mpi = case mpi of- UTF8OrNotPatchInfo pinf -> f pinf
− src/Darcs/Test/Patch/Properties/Check.hs
@@ -1,111 +0,0 @@-module Darcs.Test.Patch.Properties.Check ( Check(..), checkAPatch ) where--import Test.QuickCheck-import Control.Applicative-import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM )--import Darcs.Patch.Info ( PatchInfo, patchinfo )-import Darcs.Test.Patch.Check ( PatchCheck,- checkMove, removeDir, createDir,- isValid, insertLine, fileEmpty, fileExists,- deleteLine, modifyFile, createFile, removeFile,- doCheck, doVerboseCheck, FileContents(..)- )-import Darcs.Patch.RegChars ( regChars )-import ByteStringUtils ( linesPS )-import qualified Data.ByteString as B ( ByteString, null, concat )-import qualified Data.ByteString.Char8 as BC ( break, pack )-import Darcs.Patch.FileName ( fn2fp )-import qualified Data.Map as M ( mapMaybe )--import Darcs.Patch ( addfile, adddir, move,- hunk, tokreplace, binary,- changepref, invert, merge,- effect )-import Darcs.Patch.Invert ( Invert )-import Darcs.Patch.V1 ()-import qualified Darcs.Patch.V1.Core as V1 ( Patch(..) )-import Darcs.Patch.V1.Core ( isMerger )-import Darcs.Patch.Prim.V1 ()-import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) )-import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) )-import Darcs.Witnesses.Unsafe--#include "gadts.h"-#include "impossible.h"--type Patch = V1.Patch Prim--class Check p where- checkPatch :: p C(x y) -> PatchCheck Bool--instance Check p => Check (FL p) where- checkPatch NilFL = isValid- checkPatch (p :>: ps) = checkPatch p >> checkPatch ps--checkAPatch :: (Invert p, Check p) => p C(x y) -> Bool-checkAPatch p = doCheck $ do _ <- checkPatch p- checkPatch $ invert p--instance Check (V1.Patch Prim) where- checkPatch p | isMerger p = do- checkPatch $ effect p- checkPatch (V1.Merger _ _ _ _) = impossible- checkPatch (V1.Regrem _ _ _ _) = impossible- checkPatch (V1.PP p) = checkPatch p--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- mapM_ (deleteLine (fn2fp f) line) old- mapM_ (insertLine (fn2fp f) line) (reverse new)- isValid- checkPatch (FP f (TokReplace t old new)) =- modifyFile (fn2fp f) (tryTokPossibly t old new)- -- 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- mapM_ (deleteLine (fn2fp f) 1) (linesPS o)- _ <- fileEmpty $ fn2fp f- mapM_ (insertLine (fn2fp f) 1) (reverse $ linesPS n)- isValid-- checkPatch (DP d AddDir) = createDir $ fn2fp d- checkPatch (DP d RmDir) = removeDir $ fn2fp d-- checkPatch (Move f f') = checkMove (fn2fp f) (fn2fp f')- checkPatch (ChangePref _ _ _) = return True--tryTokPossibly :: String -> String -> String- -> (Maybe FileContents) -> (Maybe FileContents)-tryTokPossibly t o n = liftM $ \contents ->- let lines' = M.mapMaybe (liftM B.concat- . tryTokInternal t (BC.pack o) (BC.pack n))- (fcLines contents)- in contents { fcLines = lines' }--tryTokInternal :: String -> B.ByteString -> B.ByteString- -> B.ByteString -> Maybe [B.ByteString]-tryTokInternal _ _ _ s | B.null s = Just []-tryTokInternal t o n s =- case BC.break (regChars t) s of- (before,s') ->- case BC.break (not . regChars t) s' of- (tok,after) ->- case tryTokInternal t o n after of- Nothing -> Nothing- Just rest ->- if tok == o- then Just $ before : n : rest- else if tok == n- then Nothing- else Just $ before : tok : rest--verboseCheckAPatch :: (Invert p, Check p) => p C(x y) -> Bool-verboseCheckAPatch p = doVerboseCheck $ do checkPatch p-
− src/Darcs/Test/Patch/Properties/Generic.hs
@@ -1,369 +0,0 @@--- Copyright (C) 2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-}--#include "gadts.h"--module Darcs.Test.Patch.Properties.Generic- ( invertSymmetry, inverseComposition, invertRollback,- recommute, commuteInverses, effectPreserving,- permutivity, partialPermutivity,- patchAndInverseCommute, mergeEitherWay,- show_read,- mergeCommute, mergeConsistent, mergeArgumentsConsistent,- joinEffectPreserving, joinCommute, propIsMergeable- ) where--import Darcs.Test.Util.TestResult ( TestResult, succeeded, failed, rejected,- (<&&>), fromMaybe )-import Darcs.Test.Patch.RepoModel ( RepoModel, RepoState, repoApply, eqModel, showModel- , maybeFail )-import Darcs.Test.Patch.WithState ( WithState(..), WithStartState(..) )-import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenOne )--import Control.Monad ( msum )-import Darcs.Witnesses.Show ( Show2(..), show2 )-import Darcs.Patch.Patchy ( Patchy, showPatch, commute, invert )-import Darcs.Patch.Prim.Class ( PrimPatch, PrimOf, FromPrim )-import Darcs.Patch ()-import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Commute ( commuteFLorComplain )-import Darcs.Patch.Merge ( Merge(merge) )-import Darcs.Patch.Read ( readPatch )-import Darcs.Patch.Invert ( invertFL )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..), isIsEq )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:/\:)(..), lengthFL, eqFL, reverseRL )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal2, Sealed2 )-import Printer ( Doc, renderPS, redText, greenText, ($$), text )---import Darcs.ColorPrinter ( traceDoc )--propIsMergeable :: forall model p C(x) . (FromPrim p, Merge p, RepoModel model)- => Sealed (WithStartState model (Tree (PrimOf p)))- -> Maybe (Tree p C(x))-propIsMergeable (Sealed (WithStartState _ t))- = case flattenOne t of- Sealed ps -> let _ = seal2 ps :: Sealed2 (FL p)- in case lengthFL ps of- _ -> Nothing---- | invert symmetry inv(inv(p)) = p-invertSymmetry :: Patchy p => p C(a b) -> TestResult-invertSymmetry p = case invert (invert p) =\/= p of- IsEq -> succeeded- NotEq -> failed $ redText "p /= inv(inv(p))"--inverseComposition :: Patchy p => (p :> p) C(x y) -> TestResult-inverseComposition (a :> b) =- case eqFL (reverseRL (invertFL (a:>:b:>:NilFL))) (invert b:>:invert a:>:NilFL) of- IsEq -> succeeded- NotEq -> failed $ redText "inv(a :>: b :>: NilFL) /= inv(b) :>: inv(a) :>: NilFL"---- | invert rollback if b = A(a) then a = A'(b)-invertRollback :: (ApplyState p ~ RepoState model, Patchy p, RepoModel model)- => WithState model p C(a b) -> TestResult-invertRollback (WithState a x b)- = case maybeFail $ repoApply b (invert x) of- Nothing -> failed $ redText "x' not applicable to b."- Just a1 -> if a1 `eqModel` a- then succeeded- else failed $ redText "a1: " $$ text (showModel a1)- $$ redText " ---- is not equals to a:" $$ text (showModel a)- $$ redText "where a was" $$ text (showModel b)- $$ redText "with (invert x) on top:" $$ showPatch (invert x)---- | recommute AB ↔ B′A′ if and only if B′A′ ↔ AB-recommute :: Patchy p => (FORALL(x y) ((p :> p) C(x y) -> Maybe ((p :> p) C(x y))))- -> (p :> p) C(a b) -> TestResult-recommute c (x :> y) =- case c (x :> y) of- Nothing -> rejected- Just (y' :> x') ->- case c (y' :> x') of- Nothing -> failed (redText "failed" $$ showPatch y' $$ redText ":>" $$ showPatch x')- Just (x'' :> y'') ->- case y'' =/\= y of- NotEq -> failed (redText "y'' =/\\= y failed, where x" $$ showPatch x $$- redText ":> y" $$ showPatch y $$- redText "y'" $$ showPatch y' $$- redText ":> x'" $$ showPatch x' $$- redText "x''" $$ showPatch x'' $$- redText ":> y''" $$ showPatch y'')- IsEq -> case x'' =/\= x of- NotEq -> failed (redText "x'' /= x" $$ showPatch x'' $$ redText ":>" $$ showPatch y'')- IsEq -> succeeded---- | commuteInverses AB ↔ B′A′ if and only if B⁻¹A⁻¹ ↔ A′⁻¹B′⁻¹-commuteInverses :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))- -> (p :> p) C(a b) -> TestResult-commuteInverses c (x :> y) =- case c (x :> y) of- Nothing -> rejected- Just (y' :> x') ->- case c (invert y :> invert x) of- Nothing -> failed $ redText "second commute failed" $$- redText "x" $$ showPatch x $$ redText "y" $$ showPatch y $$- redText "y'" $$ showPatch y' $$ redText "x'" $$ showPatch x'- Just (ix' :> iy') ->- case invert ix' =/\= x' of- NotEq -> failed $ redText "invert ix' /= x'" $$- redText "x" $$ showPatch x $$- redText "y" $$ showPatch y $$- redText "y'" $$ showPatch y' $$- redText "x'" $$ showPatch x' $$- redText "ix'" $$ showPatch ix' $$- redText "iy'" $$ showPatch iy' $$- redText "invert ix'" $$ showPatch (invert ix') $$- redText "invert iy'" $$ showPatch (invert iy')- IsEq -> case y' =\/= invert iy' of- NotEq -> failed $ redText "y' /= invert iy'" $$ showPatch iy' $$ showPatch y'- IsEq -> succeeded---- | effect preserving AB <--> B'A' then effect(AB) = effect(B'A')-effectPreserving :: (Patchy p, RepoModel model, ApplyState p ~ RepoState model) =>- (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))- -> WithState model (p :> p) C(a b) -> TestResult-effectPreserving c (WithState r (x :> y) r')- = case c (x :> y) of- Nothing -> rejected- Just (y' :> x') ->- case maybeFail $ repoApply r y' of- Nothing -> failed $ redText "y' is not applicable to r."- Just r_y' ->- case maybeFail $ repoApply r_y' x' of- Nothing -> failed $ redText "x' is not applicable to r_y'."- Just r_y'x' -> if r_y'x' `eqModel` r'- then succeeded- else failed $ redText "r_y'x' is not equal to r'."---- | patchAndInverseCommute If AB ↔ B′A′ then A⁻¹B′ ↔ BA′⁻¹-patchAndInverseCommute :: Patchy p =>- (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))- -> (p :> p) C(a b) -> TestResult-patchAndInverseCommute c (x :> y) =- case c (x :> y) of- Nothing -> rejected- Just (y' :> x') ->- case c (invert x :> y') of- Nothing -> failed (redText ""- $$ redText "-------- original commute (x :> y):"- $$ showPatch x $$ redText ":>" $$ showPatch y- $$ redText "-------- result (y' :> x'):"- $$ showPatch y' $$ redText ":>" $$ showPatch x'- $$ redText "-------- bad commute (invert x :> y'):"- $$ showPatch (invert x) $$ redText ":>" $$ showPatch y')- Just (y'' :> ix') ->- case y'' =\/= y of- NotEq -> failed (redText "y'' /= y" $$- redText "x" $$ showPatch x $$- redText "y" $$ showPatch y $$- redText "x'" $$ showPatch x' $$- redText "y'" $$ showPatch y' $$- redText "y''" $$ showPatch y'' $$- redText ":> x'" $$ showPatch x')- IsEq -> case x' =\/= invert ix' of- NotEq -> failed (redText "x' /= invert ix'" $$- redText "y''" $$ showPatch y'' $$- redText ":> x'" $$ showPatch x' $$- redText "invert x" $$ showPatch (invert x) $$- redText ":> y" $$ showPatch y $$- redText "y'" $$ showPatch y' $$- redText "ix'" $$ showPatch ix')- IsEq -> succeeded--permutivity :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))- -> (p :> p :> p) C(a b) -> TestResult-permutivity c (x:>y:>z) =- case c (x :> y) of- Nothing -> rejected- Just (y1 :> x1) ->- case c (y :> z) of- Nothing -> rejected- Just (z2 :> y2) ->- case c (x :> z2) of- Nothing -> rejected- Just (z3 :> x3) ->- case c (x1 :> z) of- Nothing -> failed $ redText "permutivity1"- Just (z4 :> x4) ->- --traceDoc (greenText "third commuted" $$- -- greenText "about to commute" $$- -- greenText "y1" $$ showPatch y1 $$- -- greenText "z4" $$ showPatch z4) $- case c (y1 :> z4) of- Nothing -> failed $ redText "permutivity2"- Just (z3_ :> y4)- | IsEq <- z3_ =\/= z3 ->- --traceDoc (greenText "passed z3") $ error "foobar test" $- case c (y4 :> x4) of- Nothing -> failed $ redText "permutivity5: input was" $$- redText "x" $$ showPatch x $$- redText "y" $$ showPatch y $$- redText "z" $$ showPatch z $$- redText "z3" $$ showPatch z3 $$- redText "failed commute of" $$- redText "y4" $$ showPatch y4 $$- redText "x4" $$ showPatch x4 $$- redText "whereas commute of x and y give" $$- redText "y1" $$ showPatch y1 $$- redText "x1" $$ showPatch x1- Just (x3_ :> y2_)- | NotEq <- x3_ =\/= x3 -> failed $ redText "permutivity6"- | NotEq <- y2_ =/\= y2 -> failed $ redText "permutivity7"- | otherwise -> succeeded- | otherwise ->- failed $ redText "permutivity failed" $$- redText "z3" $$ showPatch z3 $$- redText "z3_" $$ showPatch z3_--partialPermutivity :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))- -> (p :> p :> p) C(a b) -> TestResult-partialPermutivity c (xx:>yy:>zz) = pp (xx:>yy:>zz) <&&> pp (invert zz:>invert yy:>invert xx)- where pp (x:>y:>z) =- case c (y :> z) of- Nothing -> rejected- Just (z1 :> y1) ->- case c (x :> z1) of- Nothing -> rejected- Just (_ :> x1) ->- case c (x :> y) of- Just _ -> rejected -- this is covered by full permutivity test above- Nothing ->- case c (x1 :> y1) of- Nothing -> succeeded- Just _ -> failed $ greenText "partialPermutivity error" $$- greenText "x" $$ showPatch x $$- greenText "y" $$ showPatch y $$- greenText "z" $$ showPatch z--mergeArgumentsConsistent :: Patchy p =>- (FORALL(x y) p C(x y) -> Maybe Doc)- -> (p :\/: p) C(a b) -> TestResult-mergeArgumentsConsistent isConsistent (x :\/: y) =- fromMaybe $- msum [(\z -> redText "mergeArgumentsConsistent x" $$ showPatch x $$ z) `fmap` isConsistent x,- (\z -> redText "mergeArgumentsConsistent y" $$ showPatch y $$ z) `fmap` isConsistent y]--mergeConsistent :: (Patchy p, Merge p) =>- (FORALL(x y) p C(x y) -> Maybe Doc)- -> (p :\/: p) C(a b) -> TestResult-mergeConsistent isConsistent (x :\/: y) =- case merge (x :\/: y) of- y' :/\: x' ->- fromMaybe $- msum [(\z -> redText "mergeConsistent x" $$ showPatch x $$ z) `fmap` isConsistent x,- (\z -> redText "mergeConsistent y" $$ showPatch y $$ z) `fmap` isConsistent y,- (\z -> redText "mergeConsistent x'" $$ showPatch x' $$ z $$- redText "where x' comes from x" $$ showPatch x $$- redText "and y" $$ showPatch y) `fmap` isConsistent x',- (\z -> redText "mergeConsistent y'" $$ showPatch y' $$ z) `fmap` isConsistent y']--mergeEitherWay :: (Patchy p, Merge p) => (p :\/: p) C(x y) -> TestResult-mergeEitherWay (x :\/: y) =- case merge (x :\/: y) of- y' :/\: x' -> case merge (y :\/: x) of- x'' :/\: y'' | IsEq <- x'' =\/= x',- IsEq <- y'' =\/= y' -> succeeded- | otherwise -> failed $ redText "mergeEitherWay bug"--mergeCommute :: (Patchy p, Merge p) => (p :\/: p) C(x y) -> TestResult-mergeCommute (x :\/: y) =- case merge (x :\/: y) of- y' :/\: x' ->- case commute (x :> y') of- Nothing -> failed $ redText "mergeCommute 1" $$- redText "x" $$ showPatch x $$- redText "y" $$ showPatch y $$- redText "x'" $$ showPatch x' $$- redText "y'" $$ showPatch y'- Just (y_ :> x'_)- | IsEq <- y_ =\/= y,- IsEq <- x'_ =\/= x' ->- case commute (y :> x') of- Nothing -> failed $ redText "mergeCommute 2 failed" $$- redText "x" $$ showPatch x $$- redText "y" $$ showPatch y $$- redText "x'" $$ showPatch x' $$- redText "y'" $$ showPatch y'- Just (x_ :> y'_)- | IsEq <- x_ =\/= x,- IsEq <- y'_ =\/= y' -> succeeded- | otherwise -> failed $ redText "mergeCommute 3" $$- redText "x" $$ showPatch x $$- redText "y" $$ showPatch y $$- redText "x'" $$ showPatch x' $$- redText "y'" $$ showPatch y' $$- redText "x_" $$ showPatch x_ $$- redText "y'_" $$ showPatch y'_- | otherwise -> failed $ redText "mergeCommute 4" $$- redText "x" $$ showPatch x $$- redText "y" $$ showPatch y $$- redText "x'" $$ showPatch x' $$- redText "y'" $$ showPatch y' $$- redText "x'_" $$ showPatch x'_ $$- redText "y_" $$ showPatch y_----- | join effect preserving-joinEffectPreserving :: (PrimPatch prim, RepoModel model, ApplyState prim ~ RepoState model )- => (FORALL(x y) (prim :> prim) C(x y) -> Maybe (FL prim C(x y)))- -> WithState model (prim :> prim) C(a b) -> TestResult-joinEffectPreserving j (WithState r (a :> b) r') =- case j (a :> b) of- Nothing -> rejected- Just x -> case maybeFail $ repoApply r x of- Nothing -> failed $ redText "x is not applicable to r."- Just r_x -> if r_x `eqModel` r'- then succeeded- else failed $ redText "r_x /= r'"--joinCommute :: (PrimPatch prim) => (FORALL(x y) (prim :> prim) C(x y) -> Maybe (FL prim C(x y)))- -> (prim :> prim :> prim) C(a b) -> TestResult-joinCommute j (a :> b :> c) =- case j (b :> c) of- Nothing -> rejected- Just x ->- case commuteFLorComplain (a :> b :>: c :>: NilFL) of- Right (b' :>: c' :>: NilFL :> a') ->- case commute (a:>:NilFL :> x) of- Just (x' :> a'':>:NilFL) ->- case a'' =/\= a' of- NotEq -> failed $ greenText "joinCommute 3"- IsEq -> case j (b' :> c') of- Nothing -> failed $ greenText "joinCommute 4"- Just x'' -> case x' =\/= x'' of- NotEq -> failed $ greenText "joinCommute 5"- IsEq -> succeeded- _ -> failed $ greenText "joinCommute 1"- _ -> rejected--show_read :: (Show2 p, Patchy p) => p C(a b) -> TestResult-show_read p = let ps = renderPS (showPatch p)- in case readPatch ps of- Nothing -> failed (redText "unable to read " $$ showPatch p)- Just (Sealed p' ) | IsEq <- p' =\/= p -> succeeded- | otherwise -> failed $ redText "trouble reading patch p" $$- showPatch p $$- redText "reads as p'" $$- showPatch p' $$- redText "aka" $$- greenText (show2 p) $$- redText "and" $$- greenText (show2 p')---- vim: fileencoding=utf-8 :
− src/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs
@@ -1,90 +0,0 @@-module Darcs.Test.Patch.Properties.GenericUnwitnessed where--import qualified Darcs.Test.Patch.Properties.Generic as W- ( permutivity, partialPermutivity- , mergeConsistent, mergeArgumentsConsistent, mergeEitherWay- , mergeCommute, patchAndInverseCommute, joinCommute, commuteInverses- , recommute- , show_read )-import Darcs.Test.Patch.Arbitrary.Generic ( Tree )-import Darcs.Test.Patch.RepoModel( RepoModel, RepoState )-import Darcs.Test.Patch.WithState( WithStartState )--import qualified Darcs.Test.Patch.Properties.Real as W ( propConsistentTreeFlattenings )-import Darcs.Test.Patch.WSub-import Darcs.Test.Util.TestResult--import Darcs.Patch.Prim.V1 ( Prim )-import Darcs.Patch.Patchy ( showPatch )-import Darcs.Witnesses.Show-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Sealed( Sealed )-import Darcs.Patch.Merge ( Merge )-import Darcs.Patch ( Patchy )-import Printer ( Doc, redText, ($$) )-import qualified Storage.Hashed.Tree as HST ( Tree )--#include "gadts.h"--permutivity :: (Patchy wp, WSub wp p) => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))- -> (p :> p :> p) C(a b) -> TestResult-permutivity f = W.permutivity (fmap toW . f . fromW) . toW--partialPermutivity :: (Patchy wp, WSub wp p) => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))- -> (p :> p :> p) C(a b) -> TestResult-partialPermutivity f = W.partialPermutivity (fmap toW . f . fromW) . toW--mergeEitherWay :: (Patchy wp, Merge wp, WSub wp p) => (p :\/: p) C(x y) -> TestResult-mergeEitherWay = W.mergeEitherWay . toW--commuteInverses :: (Patchy wp, WSub wp p) => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))- -> (p :> p) C(a b) -> TestResult-commuteInverses f = W.commuteInverses (fmap toW . f . fromW) . toW--recommute :: (Patchy wp, WSub wp p) => (FORALL(x y) ((p :> p) C(x y) -> Maybe ((p :> p) C(x y))))- -> (p :> p) C(a b) -> TestResult-recommute f = W.recommute (fmap toW . f . fromW) . toW--mergeCommute :: (Patchy wp, Merge wp, WSub wp p) => (p :\/: p) C(x y) -> TestResult-mergeCommute = W.mergeCommute . toW--mergeConsistent :: (Patchy wp, Merge wp, WSub wp p) =>- (FORALL(x y) p C(x y) -> Maybe Doc)- -> (p :\/: p) C(a b) -> TestResult-mergeConsistent f = W.mergeConsistent (f . fromW) . toW--mergeArgumentsConsistent :: (Patchy wp, WSub wp p) =>- (FORALL(x y) p C(x y) -> Maybe Doc)- -> (p :\/: p) C(a b) -> TestResult-mergeArgumentsConsistent f = W.mergeArgumentsConsistent (f . fromW) . toW--show_read :: (Patchy p, Show2 p) => p C(x y) -> TestResult-show_read = W.show_read--patchAndInverseCommute :: (Patchy wp, WSub wp p) =>- (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))- -> (p :> p) C(a b) -> TestResult-patchAndInverseCommute f = W.patchAndInverseCommute (fmap toW . f . fromW) . toW---joinCommute :: (FORALL(x y) (Prim :> Prim) C(x y) -> Maybe (FL Prim C(x y)))- -> (Prim :> Prim :> Prim) C(a b) -> TestResult-joinCommute f = W.joinCommute (fmap toW . f . fromW) . toW--consistentTreeFlattenings :: (RepoState model ~ HST.Tree, RepoModel model)- => Sealed (WithStartState model (Tree Prim)) -> TestResult-consistentTreeFlattenings = (\x -> if W.propConsistentTreeFlattenings x- then succeeded- else failed $ redText "oops")--commuteFails :: (MyEq p, Patchy p)- => ((p :> p) C(x y) -> Maybe ((p :> p) C(x y)))- -> (p :> p) C(x y)- -> TestResult-commuteFails c (x :> y) = case c (x :> y) of- Nothing -> succeeded- Just (y' :> x') ->- failed $ redText "x" $$ showPatch x $$- redText ":> y" $$ showPatch y $$- redText "y'" $$ showPatch y' $$- redText ":> x'" $$ showPatch x'
− src/Darcs/Test/Patch/Properties/Real.hs
@@ -1,35 +0,0 @@-module Darcs.Test.Patch.Properties.Real- ( propConsistentTreeFlattenings ) where--import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenTree, G2(..), mapTree )-import Darcs.Test.Patch.WithState-import Darcs.Test.Patch.RepoModel ( RepoModel, repoApply, showModel, eqModel, RepoState- , Fail, maybeFail )-import qualified Storage.Hashed.Tree as HST ( Tree )--import Darcs.Witnesses.Sealed( Sealed(..) )-import Darcs.Patch.V2.Real( prim2real )-import Darcs.Patch.Prim.V1 ( Prim )--#include "gadts.h"-#include "impossible.h"--assertEqualFst :: (RepoModel a, Show b, Show c) => (Fail (a x), b) -> (Fail (a x), c) -> Bool-assertEqualFst (x,bx) (y,by)- | Just x' <- maybeFail x, Just y' <- maybeFail y, x' `eqModel` y' = True- | Nothing <- maybeFail x, Nothing <- maybeFail y = True- | otherwise = error ("Not really equal:\n" ++ showx ++ "\nand\n" ++ showy- ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by)- where showx | Just x' <- maybeFail x = showModel x'- | otherwise = "Nothing"- showy | Just y' <- maybeFail y = showModel y'- | otherwise = "Nothing"--propConsistentTreeFlattenings :: (RepoState model ~ HST.Tree, RepoModel model)- => Sealed (WithStartState model (Tree Prim)) -> Bool-propConsistentTreeFlattenings (Sealed (WithStartState start t))- = fromJust $- do Sealed (G2 flat) <- return $ flattenTree $ mapTree prim2real t- rms <- return $ map (start `repoApply`) flat- return $ and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat)-
− src/Darcs/Test/Patch/Properties/V1Set1.hs
@@ -1,155 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Test.Patch.Properties.V1Set1- ( checkMerge, checkMergeEquiv, checkMergeSwap, checkCanon- , checkCommute, checkCantCommute- , tShowRead- , tMergeEitherWayValid, tTestCheck ) where--import Darcs.Patch- ( Patchy, commute, invert, merge, effect- , readPatch, showPatch- , fromPrim, canonize, sortCoalesceFL )-import Darcs.Patch.Prim.V1 ( Prim )-import Darcs.Patch.Merge ( Merge )-import qualified Darcs.Patch.V1 as V1 ( Patch )-import Darcs.Test.Patch.Properties.Check ( checkAPatch, Check )-import Printer ( renderPS )-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Show-import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-import Darcs.Witnesses.Unsafe( unsafeCoercePEnd )-import Darcs.Test.Util.TestResult-import Printer ( text )--#include "gadts.h"--type Patch = V1.Patch Prim---quickmerge :: (Patchy p, Merge p) => (p :\/: p ) C(x y) -> p C(y z)-quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of- _ :/\: p1' -> unsafeCoercePEnd p1'--instance Show2 p => Show ((p :/\: p) C(x y)) where- show (x :/\: y) = show2 x ++ " :/\\: " ++ show2 y-instance Show2 p => Show ((p :< p) C(x y)) where- show (x :< y) = show2 x ++ " :< " ++ show2 y-instance MyEq p => Eq ((p :/\: p) C(x y)) where- (x :/\: y) == (x' :/\: y') = isIsEq (x =\/= x') && isIsEq (y =\/= y')---- ------------------------------------------------------------------------------- A number of "comparison" properties: these carry out some operation on--- inputs (first value in the pair) and compare the results with a known--- expected value (the second value in the pair).-----checkMerge :: ((FL Patch:\/: FL Patch) C(x y), FL Patch C(y z)) -> TestResult-checkMerge (p1:\/:p2,p1') =- case merge (p1:\/:p2) of- _ :/\: p1a ->- if isIsEq (p1a `eqFL` p1')- then succeeded- else failed $ text $ "Merge gave wrong value!\n"++show p1++show p2- ++"I expected\n"++show p1'- ++"but found instead\n"++show p1a--checkMergeEquiv :: ((FL Patch:\/:FL Patch) C(x y),FL Patch C(y z)) -> TestResult-checkMergeEquiv (p1:\/: p2, pe) =- case quickmerge (p1:\/:p2) of- p1' -> if checkAPatch (invert p1 :>: p2 :>: p1' :>: invert pe :>: NilFL)- then succeeded- else failed $ text $ "Oh no, merger isn't equivalent...\n"++show p1++"\n"++show p2- ++"in other words\n" ++ show (p1 :\/: p2)- ++"merges as\n" ++ show (merge $ p1 :\/: p2)- ++"merges to\n" ++ show (quickmerge $ p1 :\/: p2)- ++"which is equivalent to\n" ++ show (effect p1')- ++ "should all work out to\n"- ++ show pe--checkMergeSwap :: (FL Patch C(x y), FL Patch C(x z)) -> TestResult-checkMergeSwap (p1, p2) =- case merge (p2:\/:p1) of- _ :/\: p2' ->- case merge (p1:\/:p2) of- _ :/\: p1' ->- case commute (p1:>p2') of- Just (_:>p1'b) ->- if not $ p1'b `eqFLUnsafe` p1'- then failed $ text $ "Merge swapping problem with...\np1 "++- show p1++"merged with\np2 "++- show p2++"p1' is\np1' "++- show p1'++"p1'b is\np1'b "++- show p1'b- else succeeded- Nothing -> failed $ text $ "Merge commuting problem with...\np1 "++- show p1++"merged with\np2 "++- show p2++"gives\np2' "++- show p2'++"which doesn't commute with p1.\n"--checkCanon :: FORALL(x y) (FL Patch C(x y), FL Patch C(x y)) -> TestResult-checkCanon (p1,p2) =- if isIsEq $ eqFL p1_ p2- then succeeded- else failed $ text $ "Canonization failed:\n"++show p1++"canonized is\n"- ++show (p1_ :: FL Patch C(x y))- ++"which is not\n"++show p2- where p1_ = mapFL_FL fromPrim $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1--checkCommute :: ((FL Patch:< FL Patch) C(x y), (FL Patch:< FL Patch) C(x y)) -> TestResult-checkCommute (p1:<p2,p2':<p1') =- case commute (p2:>p1) of- Just (p1a:>p2a) ->- if (p2a:< p1a) == (p2':< p1')- then succeeded- else failed $ text $ "Commute gave wrong value!\n"++show p1++"\n"++show p2- ++"should be\n"++show p2'++"\n"++show p1'- ++"but is\n"++show p2a++"\n"++show p1a- Nothing -> failed $ text $ "Commute failed!\n"++show p1++"\n"++show p2- <&&>- case commute (p1':>p2') of- Just (p2a:>p1a) ->- if (p1a:< p2a) == (p1:< p2)- then succeeded- else failed $ text $ "Commute gave wrong value!\n"++show p2a++"\n"++show p1a- ++"should have been\n"++show p2'++"\n"++show p1'- Nothing -> failed $ text $ "Commute failed!\n"++show p2'++"\n"++show p1'--checkCantCommute :: (FL Patch:< FL Patch) C(x y) -> TestResult-checkCantCommute (p1:<p2) =- case commute (p2:>p1) of- Nothing -> succeeded- _ -> failed $ text $ show p1 ++ "\n\n" ++ show p2 ++- "\nArgh, these guys shouldn't commute!\n"---- ------------------------------------------------------------------------------- A few "test" properties, doing things with input patches and giving a OK/not--- OK type of answer.--tShowRead :: (Show2 p, Patchy p) => (FORALL(x y w z) p C(x y) -> p C(w z) -> Bool) -> FORALL(x y) p C(x y) -> TestResult-tShowRead eq p =- case readPatch $ renderPS $ showPatch p of- Just (Sealed p') -> if p' `eq` p then succeeded- else failed $ text $ "Failed to read shown: "++(show2 p)++"\n"- Nothing -> failed $ text $ "Failed to read at all: "++(show2 p)++"\n"--tMergeEitherWayValid :: FORALL(x y p) (Check p, Show2 p, Merge p, Patchy p) => (p :\/: p) C(x y) -> TestResult-tMergeEitherWayValid (p1 :\/: p2) =- case p2 :>: quickmerge (p1:\/: p2) :>: NilFL of- combo2 ->- case p1 :>: quickmerge (p2:\/: p1) :>: NilFL of- combo1 ->- if not $ checkAPatch combo1- then failed $ text $ "oh my combo1 invalid:\n"++show2 p1++"and...\n"++show2 p2++show combo1- else- if checkAPatch (invert combo1 :>: combo2 :>: NilFL)- then succeeded- else failed $ text $ "merge both ways invalid:\n"++show2 p1++"and...\n"++show2 p2++- show combo1++- show combo2--tTestCheck :: FORALL(x y) FL Patch C(x y) -> TestResult-tTestCheck p = if checkAPatch p- then succeeded- else failed $ text $ "Failed the check: "++show p++"\n"
− src/Darcs/Test/Patch/Properties/V1Set2.hs
@@ -1,315 +0,0 @@--- Copyright (C) 2002-2003,2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Test.Patch.Properties.V1Set2- ( propCommuteInverse, propPatchAndInverseIsIdentity- , propSimpleSmartMergeGoodEnough, propCommuteEquivalency- , propMergeValid, propInverseValid, propOtherInverseValid- , propCommuteEitherOrder- , propCommuteEitherWay, propCommuteTwice- , propMergeIsCommutableAndCorrect, propMergeIsSwapable-- , checkSubcommutes- , subcommutesInverse, subcommutesNontrivialInverse, subcommutesFailure-- , propReadShow- -- TODO: these are exported temporarily to mark them as used- -- Figure out whether to enable or remove the tests.- , propUnravelThreeMerge, propUnravelSeqMerge- , propUnravelOrderIndependent, propResolveConflictsValid- ) where--import Prelude hiding ( pi )-import Test.QuickCheck-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.Framework ( Test )-import Data.Maybe ( isJust )--import Darcs.Test.Patch.Properties.Check ( Check, checkAPatch )--import Darcs.Patch ( invert, commute, merge,- readPatch, resolveConflicts,- fromPrim, showPatch )-import Darcs.Patch.Commute ( Commute )-import Darcs.Patch.Invert ( Invert )-import qualified Darcs.Patch.V1 as V1 ( Patch )-import Darcs.Patch.V1.Commute ( unravel, merger )-import Darcs.Patch.Prim.V1 ()-import Darcs.Patch.Prim.V1.Core ( Prim(..) )-import Darcs.Patch.Prim.V1.Commute ( WrappedCommuteFunction(..), Perhaps(..),- subcommutes )-import Printer ( renderPS )-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed ( Sealed(Sealed), unsafeUnseal, unseal, mapSeal, Sealed2(..) )-import Darcs.Witnesses.Unsafe--#include "impossible.h"--type Patch = V1.Patch Prim----- | Groups a set of tests by giving them the same prefix in their description.--- When this is called as @checkSubcommutes subcoms expl@, the prefix for a--- test becomes @"Checking " ++ expl ++ " for subcommute "@.-checkSubcommutes :: Testable a => [(String, a)] -> String- -> [Test]-checkSubcommutes subcoms expl = map check_subcommute subcoms- where check_subcommute (name, test) =- let testName = expl ++ " for subcommute " ++ name- in testProperty testName test--propInverseValid :: Sealed2 (FL Patch) -> Bool-propInverseValid (Sealed2 p1) = checkAPatch (invert p1:>:p1:>:NilFL)-propOtherInverseValid :: Sealed2 (FL Patch) -> Bool-propOtherInverseValid (Sealed2 p1) = checkAPatch (p1:>:invert p1:>:NilFL)--propCommuteTwice :: Sealed2 (FL Patch :> FL Patch) -> Property-propCommuteTwice (Sealed2 (p1:>p2)) =- (doesCommute p1 p2) ==> (Just (p1:>p2) == (commute (p1:>p2) >>= commute))-doesCommute :: (MyEq p, Invert p, Commute p, Check p) => p C(x y) -> p C(y z) -> Bool-doesCommute p1 p2 =- commute (p1:>p2) /= Nothing && checkAPatch (p1:>:p2:>:NilFL)-propCommuteEquivalency :: Sealed2 (FL Patch :> FL Patch) -> Property-propCommuteEquivalency (Sealed2 (p1:>p2)) =- (doesCommute p1 p2) ==>- case commute (p1:>p2) of- Just (p2':>p1') -> checkAPatch (p1:>:p2:>:invert p1':>:invert p2':>:NilFL)- _ -> impossible--propCommuteEitherWay :: Sealed2 (FL Patch :> FL Patch) -> Property-propCommuteEitherWay (Sealed2 (p1:>p2)) =- doesCommute p1 p2 ==> doesCommute (invert p2) (invert p1)--propCommuteEitherOrder :: Sealed2 (FL Patch :> FL Patch :> FL Patch) -> Property-propCommuteEitherOrder (Sealed2 (p1:>p2:>p3)) =- checkAPatch (p1:>:p2:>:p3:>:NilFL) &&- doesCommute p1 (p2+>+p3) &&- doesCommute p2 p3 ==>- case commute (p1:>p2) of- Nothing -> False- Just (p2':>p1') ->- case commute (p1':>p3) of- Nothing -> False- Just (p3':>_) ->- case commute (p2':>p3') of- Nothing -> False- Just (p3'' :> _) ->- case commute (p2:>p3) of- Nothing -> False- Just (p3'a:>_) ->- case commute (p1:>p3'a) of- Just (p3''a:>_) -> isIsEq (p3''a =\/= p3'')- Nothing -> False--propPatchAndInverseIsIdentity :: Sealed2 (FL Patch :> FL Patch) -> Property-propPatchAndInverseIsIdentity (Sealed2 (p1:>p2)) =- checkAPatch (p1:>:p2:>:NilFL) && (commute (p1:>p2) /= Nothing) ==>- case commute (p1:>p2) of- Just (p2':>_) -> case commute (invert p1:>p2') of- Nothing -> True -- This is a subtle distinction.- Just (p2'':>_) -> isIsEq (p2'' =\/= p2)- Nothing -> impossible--propMergeIsCommutableAndCorrect :: Sealed2 (FL Patch :\/: FL Patch) -> Property-propMergeIsCommutableAndCorrect (Sealed2 (p1:\/:p2)) =- checkAPatch (invert p1:>:p2:>:NilFL) ==>- case merge (p2:\/:p1) of- p1' :/\: p2' ->- case commute (p1:>p2') of- Nothing -> False- Just (p2'':>p1'') -> isIsEq (p2'' =\/= p2) && isIsEq (p1' =/\= p1'')-propMergeIsSwapable :: Sealed2 (FL Patch :\/: FL Patch) -> Property-propMergeIsSwapable (Sealed2 (p1:\/:p2)) =- checkAPatch (invert p1:>:p2:>:NilFL) ==>- case merge (p2:\/:p1) of- p1' :/\: p2' ->- case merge (p1:\/:p2) of- p2''' :/\: p1''' -> isIsEq (p1' =\/= p1''') && isIsEq (p2' =\/= p2''')--propMergeValid :: Sealed2 (FL Patch :\/: FL Patch) -> Property-propMergeValid (Sealed2 (p1:\/:p2)) =- checkAPatch (invert p1:>:p2:>:NilFL) ==>- case merge (p2:\/:p1) of- _ :/\: p2' ->- checkAPatch (invert p1:>:p2:>:invert p2:>:p1:>:p2':>:NilFL)--propSimpleSmartMergeGoodEnough :: Sealed2 (FL Patch :\/: FL Patch) -> Property-propSimpleSmartMergeGoodEnough (Sealed2 (p1:\/:p2)) =- checkAPatch (invert p1:>:p2:>:NilFL) ==>- case simpleSmartMerge (p1 :\/: p2) of- Nothing -> True- Just (Sealed p1'a)- -> isJust ((do- p1o :> _ <- commute (p2 :> p1'a)- IsEq <- return $ p1o =\/= p1- Sealed p2'a <- simpleSmartMerge (p2 :\/: p1)- p2b :> p1'b <- commute (p1 :> p2'a)- IsEq <- return $ p2 =\/= p2b- IsEq <- return $ p1'a =\/= p1'b- return ()) :: Maybe ())--simpleSmartMerge :: (Commute p, Invert p) => (p :\/: p) C(x y) -> Maybe (Sealed (p C(y)))-simpleSmartMerge (p1 :\/: p2) =- case commute (invert p2 :> p1) of- Just (p1':>_) -> Just (Sealed p1')- Nothing -> Nothing---- | The conflict resolution code (glump) begins by "unravelling" the merger--- into a set of sequences of patches. Each sequence of patches corresponds--- to one non-conflicted patch that got merged together with the others. The--- result of the unravelling of a series of merges must obviously be--- independent of the order in which those merges are performed. This--- unravelling code (which uses the unwind code mentioned above) uses probably--- the second most complicated algorithm. Fortunately, if we can successfully--- unravel the merger, almost any function of the unravelled merger satisfies--- the two constraints mentioned above that the conflict resolution code must--- satisfy.-propUnravelThreeMerge :: Patch C(x y) -> Patch C(x z) -> Patch C(x w) -> Property-propUnravelThreeMerge p1 p2 p3 =- checkAPatch (invert p1:>:p2:>:invert p2:>:p3:>:NilFL) ==>- (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal (merger "0.0" p2 p3)) (unsafeUnseal (merger "0.0" p2 p1))) ==- (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal (merger "0.0" p1 p3)) (unsafeUnseal (merger "0.0" p1 p2)))--propUnravelSeqMerge :: Patch C(x y) -> Patch C(x z) -> Patch C(z w) -> Property-propUnravelSeqMerge p1 p2 p3 =- checkAPatch (invert p1:>:p2:>:p3:>:NilFL) ==>- (unravel $ unsafeUnseal $ merger "0.0" p3 $ unsafeUnseal $ merger "0.0" p2 p1) ==- (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal $ merger "0.0" p2 p1) p3)--propUnravelOrderIndependent :: Patch C(x y) -> Patch C(x z) -> Property-propUnravelOrderIndependent p1 p2 =- checkAPatch (invert p1:>:p2:>:NilFL) ==>- (unravel $ unsafeCoercePStart $ unsafeUnseal $ merger "0.0" p2 p1) == (unravel $ unsafeUnseal $ merger "0.0" p1 p2)--propResolveConflictsValid :: Patch C(x y) -> Patch C(x z) -> Property-propResolveConflictsValid p1 p2 =- case merge (p1:\/:p2) of- _ :/\: p1' ->- let p = p2:>:p1':>:NilFL in- checkAPatch (invert p1:>:p2:>:NilFL) ==>- and $ map (\l -> (\ml -> checkAPatch (p+>+ml)) `unseal` mergeList l)- $ resolveConflicts p--mergeList :: [Sealed (FL Prim C(x))] -> Sealed (FL Patch C(x))-mergeList patches = mapFL_FL fromPrim `mapSeal` doml NilFL patches- where doml :: FL Prim C(x y) -> [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x))- doml mp (Sealed p:ps) =- case commute (invert p :> mp) of- Just (mp' :> _) -> doml (p +>+ mp') ps- Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions.- doml mp [] = Sealed mp--propReadShow :: FL Patch C(x y) -> Bool-propReadShow p = case readPatch $ renderPS $ showPatch p of- Just (Sealed p') -> isIsEq (p' =\/= p)- Nothing -> False---- |In order for merges to work right with commuted patches, inverting a patch--- past a patch and its inverse had golly well better give you the same patch--- back again.-propCommuteInverse :: Sealed2 (FL Patch :> FL Patch) -> Property-propCommuteInverse (Sealed2 (p1 :> p2)) =- doesCommute p1 p2 ==> case commute (p1 :> p2) of- Nothing -> impossible- Just (_ :> p1') ->- case commute (p1' :> invert p2) of- Nothing -> False- Just (_ :> p1'') -> isIsEq (p1'' =/\= p1)--type CommuteProperty = Sealed2 (Prim :> Prim) -> Property--subcommutesInverse :: [(String, CommuteProperty)]-subcommutesInverse = zip names (map prop_subcommute cs)- where (names, cs) = unzip subcommutes- prop_subcommute c (Sealed2 (p1:>p2)) =- does c p1 p2 ==>- case runWrappedCommuteFunction c (p2:< p1) of- Succeeded (p1':<p2') ->- case runWrappedCommuteFunction c (invert p2:< p1') of- Succeeded (p1'':<ip2x') -> isIsEq (p1'' =/\= p1) &&- case runWrappedCommuteFunction c (invert p1:< invert p2) of- Succeeded (ip2':< ip1') ->- case runWrappedCommuteFunction c (p2':< invert p1) of- Succeeded (ip1o':< p2o) -> isJust ((do- IsEq <- return $ invert ip1' =/\= p1'- IsEq <- return $ invert ip2' =/\= p2'- IsEq <- return $ ip1o' =/\= ip1'- IsEq <- return $ p2o =\/= p2- IsEq <- return $ p1'' =/\= p1- IsEq <- return $ ip2x' =\/= ip2'- return ()) :: Maybe ())- _ -> False- _ -> False- _ -> False- _ -> False--subcommutesNontrivialInverse :: [(String, CommuteProperty)]-subcommutesNontrivialInverse = zip names (map prop_subcommute cs)- where (names, cs) = unzip subcommutes- prop_subcommute c (Sealed2 (p1 :> p2)) =- nontrivial c p1 p2 ==>- case runWrappedCommuteFunction c (p2:< p1) of- Succeeded (p1':<p2') ->- case runWrappedCommuteFunction c (invert p2:< p1') of- Succeeded (p1'':<ip2x') -> isIsEq (p1'' =/\= p1) &&- case runWrappedCommuteFunction c (invert p1:< invert p2) of- Succeeded (ip2':< ip1') ->- case runWrappedCommuteFunction c (p2':< invert p1) of- Succeeded (ip1o':< p2o) -> isJust ((do- IsEq <- return $ invert ip1' =/\= p1'- IsEq <- return $ invert ip2' =/\= p2'- IsEq <- return $ ip1o' =/\= ip1'- IsEq <- return $ p2o =\/= p2- IsEq <- return $ p1'' =/\= p1- IsEq <- return $ ip2x' =\/= ip2'- return ()) :: Maybe ())- _ -> False- _ -> False- _ -> False- _ -> False--subcommutesFailure :: [(String, CommuteProperty)]-subcommutesFailure = zip names (map prop cs)- where (names, cs) = unzip subcommutes- prop c (Sealed2 (p1 :> p2)) =- doesFail c p1 p2 ==>- case runWrappedCommuteFunction c (invert p1 :< invert p2) of- Failed -> True- _ -> False--doesFail :: WrappedCommuteFunction -> Prim C(x y) -> Prim C(y z) -> Bool-doesFail c p1 p2 =- fails (runWrappedCommuteFunction c (p2:<p1)) && checkAPatch (p1 :>: p2 :>: NilFL)- where fails Failed = True- fails _ = False--does :: WrappedCommuteFunction -> Prim C(x y) -> Prim C(y z) -> Bool-does c p1 p2 =- succeeds (runWrappedCommuteFunction c (p2:<p1)) && checkAPatch (p1 :>: p2 :>: NilFL)- where succeeds (Succeeded _) = True- succeeds _ = False--nontrivial :: WrappedCommuteFunction -> Prim C(x y) -> Prim C(y z) -> Bool-nontrivial c p1 p2 =- succeeds (runWrappedCommuteFunction c (p2:<p1)) && checkAPatch (p1 :>: p2 :>: NilFL)- where succeeds (Succeeded (p1' :< p2')) = not (p1' `unsafeCompare` p1 && p2' `unsafeCompare` p2)- succeeds _ = False
− src/Darcs/Test/Patch/RepoModel.hs
@@ -1,23 +0,0 @@-module Darcs.Test.Patch.RepoModel where-import Darcs.Patch.Apply ( Apply, ApplyState )-import Test.QuickCheck ( Gen )--type Fail = Either String--unFail :: Either [Char] t -> t-unFail (Right x) = x-unFail (Left err) = error $ "unFail failed: " ++ err--maybeFail :: Either t a -> Maybe a-maybeFail (Right x) = Just x-maybeFail _ = Nothing--class RepoModel model where- type RepoState model :: (* -> *) -> *- showModel :: model x -> String- eqModel :: model x -> model x -> Bool- aSmallRepo :: Gen (model x)- repoApply :: (Apply p, ApplyState p ~ RepoState model) => model x -> p x y -> Fail (model y)--type family ModelOf (patch :: * -> * -> *) :: * -> *-
− src/Darcs/Test/Patch/Utils.hs
@@ -1,24 +0,0 @@-module Darcs.Test.Patch.Utils- ( testConditional, testStringList )- where--import Test.Framework ( Test, TestName )-import Test.Framework.Providers.HUnit ( testCase )-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.HUnit ( assertFailure )-import Test.QuickCheck ( Arbitrary, Testable, (==>) )---- | Turns a condition and a test function into a conditional quickcheck--- property that can be run by test-framework.-testConditional- :: (Arbitrary a, Show a, Testable prop) => TestName -- ^ Test name- -> (a -> Bool) -- ^ Condition- -> (a -> prop) -- ^ Test function- -> Test-testConditional name cond t = testProperty name t'- where t' x = cond x ==> t x---- | Utility function to run old tests that return a list of error messages,--- with the empty list meaning success.-testStringList :: String -> [String] -> Test-testStringList name test = testCase name $ mapM_ assertFailure test
− src/Darcs/Test/Patch/V1Model.hs
@@ -1,289 +0,0 @@-{-# LANGUAGE CPP #-}--#include "gadts.h"---- | Repository model-module Darcs.Test.Patch.V1Model- ( module Storage.Hashed.AnchoredPath- , V1Model, repoTree- , RepoItem, File, Dir, Content- , makeRepo, emptyRepo- , makeFile, emptyFile- , emptyDir- , nullRepo- , isFile, isDir- , fileContent, dirContent- , isEmpty- , root- , filterFiles, filterDirs- , find- , list- , ap2fp- , aFilename, aDirname- , aLine, aContent- , aFile, aDir- , aRepo- ) where---import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized )-import Darcs.Test.Patch.RepoModel--import Darcs.Patch.Apply( applyToTree )-import Darcs.Witnesses.Sealed ( Sealed, seal )-import Darcs.Witnesses.Show--import Storage.Hashed.AnchoredPath-import Storage.Hashed.Tree( Tree, TreeItem )-import Storage.Hashed.Darcs ( darcsUpdateHashes )-import qualified Storage.Hashed.Tree as T--import Control.Applicative ( (<$>) )-import Control.Arrow ( second )-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC-import Data.List ( intercalate )-import qualified Data.Map as M-import Test.QuickCheck- ( Arbitrary(..)- , Gen, choose, vectorOf, frequency )--#include "impossible.h"---------------------------------------------------------------------------- * Model definition---- | A repository is an abstraction build in top of a 'Tree'.--- NB: Repository preferences are not supported yet.-newtype V1Model C(x) = V1Model {- repoTree :: Tree Fail- }---- | Repository items may be text files or directories.--- NB: Binary files are not supported yet.-newtype RepoItem = RepoItem {- treeItem :: TreeItem Fail- }--type File = RepoItem-type Dir = RepoItem--type Content = [B.ByteString]--------------------------------------------- Instances--instance Show (V1Model C(x)) where- show repo = "V1Model{ "- ++ intercalate " " (map showEntry $ list repo)- ++ " }"- where- showPath = show . flatten- showContent content = "[" ++ intercalate " " (map show content) ++ "]"- showEntry (path,item)- | isDir item = showPath path- | isFile item = showPath path ++ showContent (fileContent item)- showEntry _ = impossible--instance Show1 V1Model where- showDict1 = ShowDictClass--------------------------------------------- Utils--bs2lbs :: B.ByteString -> BL.ByteString-bs2lbs bs = BL.fromChunks [bs]--lbs2bs :: BL.ByteString -> B.ByteString-lbs2bs = B.concat . BL.toChunks--content2lbs :: Content -> BL.ByteString-content2lbs = BLC.unlines . map bs2lbs--lbs2content :: BL.ByteString -> Content-lbs2content = map lbs2bs . BLC.lines--------------------------------------------------------------------------- ** Path conversion--ap2fp :: AnchoredPath -> FilePath-ap2fp = anchorPath ""--------------------------------------------------------------------------- * Constructors--makeRepo :: [(Name, RepoItem)] -> V1Model C(x)-makeRepo = V1Model . T.makeTree . map (second treeItem)--emptyRepo :: V1Model C(x)-emptyRepo = V1Model T.emptyTree--makeFile :: Content -> File-makeFile = RepoItem . T.File . T.makeBlob . content2lbs--emptyFile :: File-emptyFile = RepoItem $ T.File T.emptyBlob--emptyDir :: Dir-emptyDir = RepoItem $ T.SubTree T.emptyTree--------------------------------------------------------------------------- * Queries--nullRepo :: V1Model C(x) -> Bool-nullRepo = M.null . T.items . repoTree--isFile :: RepoItem -> Bool-isFile (RepoItem (T.File _)) = True-isFile _other = False--isDir :: RepoItem -> Bool-isDir (RepoItem (T.SubTree _)) = True-isDir _other = False--fileContent :: File -> Content-fileContent (RepoItem (T.File blob))- = lbs2content $ unFail $ T.readBlob blob-fileContent _other- = error "fileContent: Not a file."--dirContent :: Dir -> [(Name, RepoItem)]-dirContent (RepoItem (T.SubTree subtree))- = map (second RepoItem) $ M.toList $ T.items subtree-dirContent _other- = error "dirContent: Not a directory."---- | @isEmpty file@ <=> file content is empty--- @isEmpty dir@ <=> dir has no child-isEmpty :: RepoItem -> Bool-isEmpty item- | isFile item = null $ fileContent item- | isDir item = null $ dirContent item- | otherwise = undefined---- | The root directory of a repository.-root :: V1Model C(x) -> Dir-root = RepoItem . T.SubTree . repoTree--find :: V1Model C(x) -> AnchoredPath -> Maybe RepoItem-find (V1Model tree) path = RepoItem <$> T.find tree path---- | List repository items.--- NB: It does not include the root directory.-list :: V1Model C(x) -> [(AnchoredPath, RepoItem)]-list (V1Model tree) = map (second RepoItem) $ T.list tree--------------------------------------------------------------------------- ** Filtering--filterFiles :: [(n, RepoItem)] -> [(n, File)]-filterFiles = filter (isFile . snd)--filterDirs :: [(n, RepoItem)] -> [(n, Dir)]-filterDirs = filter (isDir . snd)--------------------------------------------------------------------------- * Comparing repositories--diffRepos :: V1Model C(x) -> V1Model C(y) -> (V1Model C(u), V1Model C(v))-diffRepos repo1 repo2 =- let (diff1,diff2) = unFail $ T.diffTrees hashedTree1 hashedTree2- in (V1Model diff1, V1Model diff2)- where- hashedTree1, hashedTree2 :: Tree Fail- hashedTree1 = unFail $ darcsUpdateHashes $ repoTree repo1- hashedTree2 = unFail $ darcsUpdateHashes $ repoTree repo2---------------------------------------------------------------------------- * Patch application--------------------------------------------------------------------------- * QuickCheck generators---- Testing code assumes that aFilename and aDirname generators--- will always be able to generate a unique name given a list of--- existing names. This should be OK as long as the number of possible--- file/dirnames is much bigger than the number of files/dirs per repository.---- 'Arbitrary' 'V1Model' instance is based on the 'aSmallRepo' generator.----- | Files are distinguish by ending their names with ".txt".-aFilename :: Gen Name-aFilename = do len <- choose (1,maxLength)- name <- vectorOf len alpha- return $ makeName (name ++ ".txt")- where- maxLength = 3--aDirname :: Gen Name-aDirname = do len <- choose (1,maxLength)- name <- vectorOf len alpha- return $ makeName name- where- maxLength = 3--aWord :: Gen B.ByteString-aWord = do c <- alpha- return $ BC.pack[c]--aLine :: Gen B.ByteString-aLine = do wordsNo <- choose (1,2)- ws <- vectorOf wordsNo aWord- return $ BC.unwords ws--aContent :: Gen Content-aContent = bSized 0 0.5 80 $ \k ->- do n <- choose (0,k)- vectorOf n aLine--aFile :: Gen File-aFile = makeFile <$> aContent---- | See 'aRepo', the same applies for 'aDir'.-aDir :: Int -- ^ Maximum number of files- -> Int -- ^ Maximum number of directories- -> Gen Dir-aDir filesL dirL = root <$> aRepo filesL dirL---- | @aRepo filesNo dirsNo@ produces repositories with *at most*--- @filesNo@ files and @dirsNo@ directories.--- The structure of the repository is aleatory.-aRepo :: Int -- ^ Maximum number of files- -> Int -- ^ Maximum number of directories- -> Gen (V1Model C(x))-aRepo maxFiles maxDirs- = do let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0- filesNo <- choose (minFiles,maxFiles)- let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0- dirsNo <- choose (minDirs,maxDirs)- -- NB: Thanks to laziness we don't need to care about division by zero- -- since if dirsNo == 0 then neither filesPerDirL nor subdirsPerDirL will- -- be evaluated.- let filesPerDirL = (maxFiles-filesNo) `div` dirsNo- subdirsPerDirL = (maxDirs-dirsNo) `div` dirsNo- files <- vectorOf filesNo aFile- filenames <- uniques filesNo aFilename- dirs <- vectorOf dirsNo (aDir filesPerDirL subdirsPerDirL)- dirnames <- uniques dirsNo aDirname- return $ makeRepo (filenames `zip` files ++ dirnames `zip` dirs)---- | Generate small repositories.--- Small repositories help generating (potentially) conflicting patches.-instance RepoModel V1Model where- type RepoState V1Model = Tree- showModel m = show m- aSmallRepo = do filesNo <- frequency [(3, return 1), (1, return 2)]- dirsNo <- frequency [(3, return 1), (1, return 0)]- aRepo filesNo dirsNo- repoApply (V1Model tree) patch = V1Model <$> applyToTree patch tree- eqModel repo1 repo2 = let (diff1,diff2) = diffRepos repo1 repo2- in nullRepo diff1 && nullRepo diff2---instance Arbitrary (Sealed V1Model) where- arbitrary = seal <$> aSmallRepo
− src/Darcs/Test/Patch/V3Model.hs
@@ -1,216 +0,0 @@-{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports -fno-warn-orphans #-}-{-# LANGUAGE CPP, OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-}--#include "gadts.h"---- | Repository model-module Darcs.Test.Patch.V3Model- ( module Storage.Hashed.AnchoredPath- , V3Model- , Object(..)- , repoApply- , emptyFile- , emptyDir- , nullRepo- , isEmpty- , root, repoObjects- , aFilename, aDirname- , aLine, aContent- , aFile, aDir- , aRepo- , anUUID- ) where---import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized )-import Darcs.Test.Patch.RepoModel--import Darcs.Patch.Apply( Apply(..), applyToState )-import Darcs.Patch.ApplyMonad( ApplyMonad(..) )-import Darcs.Patch.Prim.V3.Core( UUID(..), Hunk(..), Prim(..), Object(..) )-import Darcs.Patch.Prim.V3.Apply( ObjectMap(..) )-import Darcs.Witnesses.Sealed ( Sealed, seal )-import Darcs.Witnesses.Show--import Storage.Hashed.AnchoredPath-import Storage.Hashed.Tree( Tree, TreeItem )-import Storage.Hashed.Darcs ( darcsUpdateHashes )-import Storage.Hashed.Hash( Hash(..) )-import qualified Storage.Hashed.Tree as T--import Control.Applicative ( (<$>) )-import Control.Arrow ( second )-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC-import Data.List ( intercalate, sort )-import qualified Data.Map as M-import Test.QuickCheck- ( Arbitrary(..)- , Gen, choose, vectorOf, frequency, oneof )--#include "impossible.h"---------------------------------------------------------------------------- * Model definition--newtype V3Model C(x) = V3Model { repoMap :: ObjectMap Fail }--------------------------------------------- Instances--instance Show (Object Fail) where- show (Directory l) = show l- show (Blob c _) = show c--deriving instance Eq (Object Fail)--instance Show (V3Model x) where- show = showModel--instance Show1 V3Model where- showDict1 = ShowDictClass--------------------------------------------------------------------------- * Constructors--objectMap :: (Monad m) => M.Map UUID (Object m) -> ObjectMap m-objectMap map = ObjectMap { getObject = get, putObject = put, listObjects = list }- where list = return $ M.keys map- put k o = return $ objectMap (M.insert k o map)- get k = return $ M.lookup k map--emptyRepo :: V3Model C(x)-emptyRepo = V3Model (objectMap M.empty)--emptyFile :: (Monad m) => Object m-emptyFile = Blob (return BS.empty) NoHash--emptyDir :: Object m-emptyDir = Directory M.empty--------------------------------------------------------------------------- * Queries--nullRepo :: V3Model C(x) -> Bool-nullRepo = null . repoObjects---- | @isEmpty file@ <=> file content is empty--- @isEmpty dir@ <=> dir has no child-isEmpty :: Object Fail -> Bool-isEmpty (Directory d) = M.null d-isEmpty (Blob f _) = BS.null $ unFail f---- | The root directory of a repository.-root :: V3Model C(x) -> Object Fail-root (V3Model repo) = fromJust $ unFail $ getObject repo (UUID "ROOT")--repoObjects :: V3Model C(x) -> [(UUID, Object Fail)]-repoObjects (V3Model repo) = [ (id, obj id) |- id <- unFail $ listObjects repo, not $ isEmpty $ obj id ]- where obj id = fromJust $ unFail $ getObject repo id--------------------------------------------------------------------------- * Comparing repositories--------------------------------------------------------------------------- * QuickCheck generators---- Testing code assumes that aFilename and aDirname generators --- will always be able to generate a unique name given a list of--- existing names. This should be OK as long as the number of possible--- file/dirnames is much bigger than the number of files/dirs per repository.---- 'Arbitrary' 'V3Model' instance is based on the 'aSmallRepo' generator.----- | Files are distinguish by ending their names with ".txt".-aFilename :: Gen BS.ByteString-aFilename = do len <- choose (1,maxLength)- name <- vectorOf len alpha- return $ BC.pack $ name ++ ".txt"- where- maxLength = 3--aDirname :: Gen BS.ByteString-aDirname = do len <- choose (1,maxLength)- BC.pack <$> vectorOf len alpha- where- maxLength = 3--aWord :: Gen BS.ByteString-aWord = do c <- alpha- return $ BC.pack[c]--aLine :: Gen BS.ByteString-aLine = do wordsNo <- choose (1,2)- ws <- vectorOf wordsNo aWord- return $ BC.unwords ws--aContent :: Gen BS.ByteString-aContent = bSized 0 0.5 80 $ \k ->- do n <- choose (0,k)- BC.intercalate "\n" <$> vectorOf n aLine--aFile :: (Monad m) => Gen (Object m)-aFile = aContent >>= \c -> return $ Blob (return c) NoHash--aDir :: (Monad m) => [UUID] -> [UUID] -> Gen [(UUID, Object m)]-aDir [] _ = return []-aDir (dirid:dirids) fileids =- do dirsplit <- choose (1, length dirids)- filesplit <- choose (1, length fileids)- let ids = take filesplit fileids- rem = drop filesplit fileids- files <- vectorOf filesplit aFile- names <- vectorOf filesplit aFilename- dirnames <- vectorOf dirsplit aDirname- dirs <- subdirs (take dirsplit dirids)- (drop dirsplit dirids)- (drop filesplit fileids)- return $ (dirid, Directory $ M.fromList $ names `zip` ids ++ dirnames `zip` dirids)- : (fileids `zip` files) ++ dirs- where subdirs [] _ _ = return []- subdirs tomake dirs files = do- dirsplit <- choose (1, length dirs)- filesplit <- choose (1, length files)- dir <- aDir (head tomake : take dirsplit dirs) (take filesplit files)- rem <- subdirs (tail tomake) (drop dirsplit dirs) (drop filesplit files)- return $ dir ++ rem---anUUID :: Gen UUID-anUUID = UUID . BC.pack <$> vectorOf 32 (oneof $ map return "0123456789")---- | @aRepo filesNo dirsNo@ produces repositories with *at most* --- @filesNo@ files and @dirsNo@ directories. --- The structure of the repository is aleatory.-aRepo :: Int -- ^ Maximum number of files- -> Int -- ^ Maximum number of directories- -> Gen (V3Model C(x))-aRepo maxFiles maxDirs- = do let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0- filesNo <- choose (minFiles,maxFiles)- let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0- dirsNo <- choose (minDirs,maxDirs)- dirids <- (UUID "ROOT":) <$> uniques dirsNo anUUID- fileids <- uniques filesNo anUUID- objectmap <- aDir dirids fileids- return $ V3Model $ objectMap $ M.fromList objectmap---- | Generate small repositories.--- Small repositories help generating (potentially) conflicting patches.-instance RepoModel V3Model where- type RepoState V3Model = ObjectMap- aSmallRepo = do filesNo <- frequency [(3, return 1), (1, return 2)]- dirsNo <- frequency [(3, return 1), (1, return 0)]- aRepo filesNo dirsNo- repoApply (V3Model state) patch = V3Model <$> applyToState patch state- showModel model = "V3Model{\n" ++ unlines (map entry $ repoObjects model) ++ "}"- where entry (id, obj) = show id ++ " -> " ++ show obj- eqModel r1 r2 = repoObjects r1 == repoObjects r2--instance Arbitrary (Sealed V3Model) where- arbitrary = seal <$> aSmallRepo
− src/Darcs/Test/Patch/WSub.hs
@@ -1,138 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}-module Darcs.Test.Patch.WSub where--{--The Examples.Set2Unwitnessed module builds a lot of test cases by pattern matching-on the results of merge/commute in where clauses. This would-be very painful to switch to using witnesses properly, because-we'd have to make them use case in series.--So instead we give up on witnesses for this module, but instead-of preprocessor hacks which make incompatible code with the rest-of darcs, we build a fresh set of witnesses constructors (FL etc)-which aren't actually GADTs or existentials. So the pattern matching-works as before, but we need to translate back and forth a lot.--We call the normal darcs constructors the 'W' variants.--}--import qualified Darcs.Test.Patch.Arbitrary.Generic as W- ( getPairs, getTriples )--import qualified Darcs.Patch as W ( commute )-import qualified Darcs.Patch.Merge as W ( merge, mergeFL )-import qualified Darcs.Patch.Prim as W ( join )--import qualified Darcs.Witnesses.Ordered as W-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Show-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart, unsafeCoercePEnd )--import Darcs.Patch.Merge ( Merge )-import Darcs.Patch.Prim.V1 ( Prim )-import Darcs.Patch.V2 ( RealPatch )-import Darcs.Patch.Patchy ( Commute, Invert(..) )--#include "gadts.h"--infixr 5 :>:-infixr 5 +>+-infixr 1 :>-infix 1 :/\:-infix 1 :\/:--data FL p C(x y) where- NilFL :: FL p C(x y)- (:>:) :: p C(x y) -> FL p C(x y) -> FL p C(x y)--(+>+) :: FL p C(x y) -> FL p C(x y) -> FL p C(x y)-NilFL +>+ ps = ps-(p :>: ps) +>+ qs = p :>: (ps +>+ qs)--data (p :> q) C(x y) where- (:>) :: p C(x y) -> q C(x y) -> (p :> q) C(x y)--data (p :\/: q) C(x y) where- (:\/:) :: p C(x y) -> q C(x y) -> (p :\/: q) C(x y)--data (p :/\: q) C(x y) where- (:/\:) :: p C(x y) -> q C(x y) -> (p :/\: q) C(x y)--class WSub wp p | p -> wp, wp -> p where- fromW :: wp C(x y) -> p C(x y)- toW :: p C(x y) -> wp C(x y)--instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:\/: wp2) (p1 :\/: p2) where- fromW (x W.:\/: y) = unsafeCoerceP (fromW x) :\/: unsafeCoerceP (fromW y)- toW (x :\/: y) = unsafeCoerceP (toW x) W.:\/: unsafeCoerceP (toW y)--instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:/\: wp2) (p1 :/\: p2) where- fromW (x W.:/\: y) = unsafeCoerceP (fromW x) :/\: unsafeCoerceP (fromW y)- toW (x :/\: y) = unsafeCoerceP (toW x) W.:/\: unsafeCoerceP (toW y)--instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:> wp2) (p1 :> p2) where- fromW (x W.:> y) = unsafeCoercePEnd (fromW x) :> unsafeCoercePStart (fromW y)- toW (x :> y) = unsafeCoercePEnd (toW x) W.:> unsafeCoercePStart (toW y)--instance WSub wp p => WSub (W.FL wp) (FL p) where- fromW W.NilFL = unsafeCoerceP NilFL- fromW (x W.:>: xs) = unsafeCoercePEnd (fromW x) :>: unsafeCoercePStart (fromW xs)-- toW NilFL = unsafeCoerceP W.NilFL- toW (x :>: xs) = unsafeCoercePEnd (toW x) W.:>: unsafeCoercePStart (toW xs)--instance WSub prim prim => WSub (RealPatch prim) (RealPatch prim) where- fromW = id- toW = id--instance WSub Prim Prim where- fromW = id- toW = id--instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show ((p :> q) C(x y)) where- show = show . toW--instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :> q) where- showDict2 = ShowDictClass--instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show ((p :\/: q) C(x y)) where- show = show . toW--instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :\/: q) where- showDict2 = ShowDictClass--instance (WSub wp p, Show2 wp) => Show (FL p C(x y)) where- show = show . toW--instance (WSub wp p, Show2 wp) => Show2 (FL p) where- showDict2 = ShowDictClass--instance (WSub wp p, Commute wp, MyEq wp) => MyEq (FL p) where- unsafeCompare x y = unsafeCompare (toW x) (toW y)--instance (WSub wp p, Commute wp, Invert wp) => Invert (FL p) where- invert = fromW . invert . toW--instance (WSub wp p, Commute wp) => Commute (FL p) where- commute (xs W.:> ys) = do ys' W.:> xs' <- W.commute (toW xs W.:> toW ys)- return (fromW ys' W.:> fromW xs')--mergeFL :: (WSub wp p, Merge wp) => (p :\/: FL p) C(x y) -> (FL p :/\: p) C(x y)-mergeFL = fromW . W.mergeFL . toW--merge :: (WSub wp p, Merge wp) => (p :\/: p) C(x y) -> (p :/\: p) C(x y)-merge = fromW . W.merge . toW--commute :: (WSub wp p, Commute wp) => (p :> p) C(x y) -> Maybe ((p :> p) C(x y))-commute = fmap fromW . W.commute . toW--getPairs :: FL (RealPatch Prim) C(x y) -> [Sealed2 (RealPatch Prim :> RealPatch Prim)]-getPairs = map (mapSeal2 fromW) . W.getPairs . toW--getTriples :: FL (RealPatch Prim) C(x y) -> [Sealed2 (RealPatch Prim :> RealPatch Prim :> RealPatch Prim)]-getTriples = map (mapSeal2 fromW) . W.getTriples . toW--join :: (Prim :> Prim) C(x y) -> Maybe (FL Prim C(x y))-join = fmap fromW . W.join . toW-
− src/Darcs/Test/Patch/WithState.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}--#include "gadts.h"--module Darcs.Test.Patch.WithState- where---import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Show-import Test.QuickCheck ( Gen, sized, choose )----------------------------------------------------------------------------- * WithState--data WithState s p C(x y) = WithState {- wsStartState :: s C(x)- , wsPatch :: p C(x y)- , wsEndState :: s C(y)- }- deriving Eq--instance (Show1 s, Show2 p) => Show (WithState s p C(x y)) where- showsPrec d (WithState s p s')- = showParen (d > appPrec) $ showString "WithState "- . showsPrec1 (appPrec+1) s- . showString " "- . showsPrec2 (appPrec+1) p- . showString " "- . showsPrec1 (appPrec+1) s'--instance (Show1 s, Show2 p) => Show2 (WithState s p) where- showDict2 = ShowDictClass--data WithStartState s p C(x) = WithStartState {- wssStartState :: s C(x)- , wssPatch :: p C(x)- }- deriving Eq--instance (Show1 s, Show1 p) => Show (WithStartState s p C(x)) where- showsPrec d (WithStartState s p) = showParen (d > appPrec) $ showString "WithStartState " .- showsPrec1 (appPrec + 1) s . showString " " .- showsPrec1 (appPrec + 1) p--instance (Show1 s, Show1 p) => Show1 (WithStartState s p) where- showDict1 = ShowDictClass---- | A combination of a patch and its final state. The state, in this module, is--- typically represented by a 'RepoModel' value. The @px@ type is typically a--- patch type applied to its pre-state, e.g. @Prim x@.-data WithEndState s px C(y) = WithEndState {- wesPatch :: px C(y)- , wesEndState :: s C(y)- }- deriving Eq--instance (Show1 s, Show1 p) => Show (WithEndState s p C(x)) where- showsPrec d (WithEndState p s) = showParen (d > appPrec) $ showString "WithEndState " .- showsPrec1 (appPrec + 1) p . showString " " .- showsPrec1 (appPrec + 1) s---instance (Show1 s, Show1 p) => Show1 (WithEndState s p) where- showDict1 = ShowDictClass---------------------------------------------------------------------------- * ArbitraryState generators---- | A type class to generate arbitrary values, threading a state through the--- arbitrary calls. So this can be used to generate a patch that comes after--- another patch. The post-state of the generated patch is hidden by the--- 'Sealed'.-class ArbitraryState s p where- arbitraryState :: s C(x) -> Gen (Sealed (WithEndState s (p C(x))))- -- does a coarbitrary make sense?---instance ArbitraryState s p => ArbitraryState s (WithState s p) where- arbitraryState s = do Sealed (WithEndState x s') <- arbitraryState s- return $ seal $ WithEndState (WithState s x s') s'---instance ArbitraryState s p => ArbitraryState s (p :> p) where- arbitraryState s = do Sealed (WithEndState p1 s') <- arbitraryState s- Sealed (WithEndState p2 s'') <- arbitraryState s'- return $ seal $ WithEndState (p1 :> p2) s'' --instance ArbitraryState s p => ArbitraryState s (p :> p :> p) where- arbitraryState s0 = do Sealed (WithEndState p1 s1) <- arbitraryState s0- Sealed (WithEndState p2 s2) <- arbitraryState s1- Sealed (WithEndState p3 s3) <- arbitraryState s2- return $ seal $ WithEndState (p1 :> p2 :> p3) s3--arbitraryFL :: ArbitraryState s p => FORALL(x) Int -> s C(x) -> Gen (Sealed (WithEndState s (FL p C(x))))-arbitraryFL 0 s = return $ seal $ WithEndState NilFL s-arbitraryFL n s = do Sealed (WithEndState x s') <- arbitraryState s- Sealed (WithEndState xs s'') <- arbitraryFL (n-1) s'- return $ seal $ WithEndState (x :>: xs) s''--instance ArbitraryState s p => ArbitraryState s (FL p) where- arbitraryState s = sized $ \n -> do k <- choose (0, min 2 (n `div` 5))- arbitraryFL k s---makeS2Gen :: ArbitraryState s p => Gen (s C(x)) -> Gen (Sealed2 p)-makeS2Gen stGen = do s <- stGen- Sealed (WithEndState p _) <- arbitraryState s- return $ seal2 p--makeSGen :: ArbitraryState s p => Gen (s C(x)) -> Gen (Sealed (p C(x)))-makeSGen stGen = do s <- stGen- Sealed (WithEndState p _) <- arbitraryState s- return $ seal p--makeWS2Gen :: ArbitraryState s p => Gen (s C(x)) -> Gen (Sealed2 (WithState s p))-makeWS2Gen stGen = do s <- stGen- Sealed (WithEndState wsP _) <- arbitraryState s- return $ seal2 wsP--makeWSGen :: ArbitraryState s p => Gen (s C(x)) -> Gen (Sealed (WithState s p C(x)))-makeWSGen stGen = do s <- stGen- Sealed (WithEndState wsP _) <- arbitraryState s- return $ seal wsP--instance (Show2 p, Show1 s) => Show1 ((WithState s p) C(a)) where- showDict1 = ShowDictClass-
− src/Darcs/Test/Util/QuickCheck.hs
@@ -1,58 +0,0 @@--module Darcs.Test.Util.QuickCheck- ( upper- , lower- , alpha- , notIn- , uniques- , maybeOf- , bSized- )- where---import Control.Applicative-import Test.QuickCheck.Gen------ | An uppercase alphabetic character.-upper :: Gen Char-upper = choose ('A','Z')---- | A lowercase alphabetic character.-lower :: Gen Char-lower = choose ('a','z')---- | An alphabetic character.-alpha :: Gen Char-alpha = oneof [upper, lower]---- | @gen `notIn` xs@ generate a @x@ that is not in @xs@.-notIn :: Eq a => Gen a -> [a] -> Gen a-gen `notIn` xs = gen `suchThat` (`notElem` xs)---- | @uniques k gen@ generates a list of @k@ unique values.-uniques :: Eq a => Int -> Gen a -> Gen [a]-uniques k gen = go k []- where- go 0 xs = return xs- go n xs = do x <- gen `notIn` xs- go (n-1) (x:xs)---- | Try to arbitrarily pick some element of the list.-maybeOf :: [a] -> Gen (Maybe a)-maybeOf [] = return Nothing-maybeOf xs = Just <$> elements xs----- | A bounded sized combinator.-bSized :: Int -- ^ Lower bound- -> Double -- ^ Increment- -> Int -- ^ Upper bound- -> (Int -> Gen a) -> Gen a-bSized low inc upp mkGen = sized $ mkGen . resize'- where- resize' :: Int -> Int- resize' n = let x = fromIntegral n- in min upp (floor(inc*x) + low)
− src/Darcs/Test/Util/TestResult.hs
@@ -1,63 +0,0 @@--module Darcs.Test.Util.TestResult- ( TestResult- , succeeded- , failed- , rejected- , (<&&>)- , fromMaybe- , isOk- , isFailed- )- where---import Printer ( Doc, renderString )--import qualified Test.QuickCheck.Property as Q----data TestResult = TestSucceeded- | TestFailed Doc- | TestRejected -- ^ Rejects test case---succeeded :: TestResult-succeeded = TestSucceeded--failed :: Doc -- ^ Error message- -> TestResult-failed = TestFailed--rejected :: TestResult-rejected = TestRejected---- | @t <&&> s@ fails <=> t or s fails--- @t <&&> s@ succeeds <=> none fails and some succeeds--- @t <&&> s@ is rejected <=> both are rejected-(<&&>) :: TestResult -> TestResult -> TestResult-t@(TestFailed _) <&&> _s = t-_t <&&> s@(TestFailed _) = s-TestRejected <&&> s = s-t <&&> TestRejected = t-TestSucceeded <&&> TestSucceeded = TestSucceeded---- | 'Nothing' is considered success whilst 'Just' is considered failure.-fromMaybe :: Maybe Doc -> TestResult-fromMaybe Nothing = succeeded-fromMaybe (Just errMsg) = failed errMsg--isFailed :: TestResult -> Bool-isFailed (TestFailed _) = True-isFailed _other = False---- | A test is considered OK if it does not fail.-isOk :: TestResult -> Bool-isOk = not . isFailed-- -- 'Testable' instance is defined by converting 'TestResult' to 'QuickCheck.Property.Result'-instance Q.Testable TestResult where- property TestSucceeded = Q.property Q.succeeded- property (TestFailed errorMsg) = Q.property (Q.failed{Q.reason = renderString errorMsg})- property TestRejected = Q.property Q.rejected
− src/Darcs/TheCommands.hs
@@ -1,104 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}-module Darcs.TheCommands ( commandControlList ) where--import Prelude ()-import Darcs.Commands.Add ( add )-import Darcs.Commands.AmendRecord ( amendrecord, amendunrecord )-import Darcs.Commands.Annotate ( annotate )-import Darcs.Commands.Apply ( apply )-import Darcs.Commands.Changes ( changes, log )-import Darcs.Commands.Check ( check, repair )-import Darcs.Commands.Convert ( convert )-import Darcs.Commands.Diff ( diffCommand )-import Darcs.Commands.Dist ( dist )-import Darcs.Commands.Get ( get, clone )-import Darcs.Commands.GZCRCs ( gzcrcs )-import Darcs.Commands.Init ( initialize )-import Darcs.Commands.Show ( showCommand, list, query )-import Darcs.Commands.MarkConflicts ( markconflicts )-import Darcs.Commands.Move ( move, mv )-import Darcs.Commands.Optimize ( optimize )-import Darcs.Commands.Pull ( pull, fetch )-import Darcs.Commands.Push ( push )-import Darcs.Commands.Put ( put )-import Darcs.Commands.Record ( record, commit )-import Darcs.Commands.Remove ( remove, rm, unadd )-import Darcs.Commands.Replace ( replace )-import Darcs.Commands.Revert ( revert )-import Darcs.Commands.Rollback ( rollback )-import Darcs.Commands.Send ( send )-import Darcs.Commands.SetPref ( setpref )-import Darcs.Commands.Tag ( tag )-import Darcs.Commands.Test ( test )-import Darcs.Commands.TrackDown ( trackdown )-import Darcs.Commands.TransferMode ( transferMode )-import Darcs.Commands.Unrecord ( unrecord, unpull, obliterate )-import Darcs.Commands.Unrevert ( unrevert )-import Darcs.Commands.WhatsNew ( whatsnew, status )-import Darcs.Commands ( CommandControl(CommandData,HiddenCommand,GroupName) )---- | The commands that darcs knows about (e.g. whatsnew, record),--- organized into thematic groups. Note that hidden commands--- are also listed here.-commandControlList :: [CommandControl]-commandControlList = [GroupName "Changing and querying the working copy:",- CommandData add,- CommandData remove, HiddenCommand unadd, HiddenCommand rm,- CommandData move, HiddenCommand mv,- CommandData replace,- CommandData revert,- CommandData unrevert,- CommandData whatsnew, HiddenCommand status,- GroupName "Copying changes between the working copy and the repository:",- CommandData record, HiddenCommand commit,- CommandData unrecord,- CommandData amendrecord,- HiddenCommand amendunrecord,- CommandData markconflicts,- GroupName "Direct modification of the repository:",- CommandData tag,- CommandData setpref,- GroupName "Querying the repository:",- CommandData diffCommand,- CommandData changes, HiddenCommand log,- CommandData annotate,- CommandData dist,- CommandData test,- CommandData trackdown,- CommandData showCommand, HiddenCommand list, HiddenCommand query,- HiddenCommand transferMode,- GroupName "Copying patches between repositories with working copy update:",- CommandData pull,- CommandData fetch,- CommandData obliterate, HiddenCommand unpull,- CommandData rollback,- CommandData push,- CommandData send,- CommandData apply,- CommandData get, HiddenCommand clone,- CommandData put,- GroupName "Administrating repositories:",- CommandData initialize,- CommandData optimize,- CommandData check,- CommandData repair,- CommandData convert- ,HiddenCommand gzcrcs- ]
+ src/Darcs/UI/ApplyPatches.hs view
@@ -0,0 +1,179 @@+module Darcs.UI.ApplyPatches+ ( PatchApplier(..), PatchProxy(..)+ , StandardPatchApplier(..)+ ) where++import System.Exit ( ExitCode ( ExitSuccess ), exitSuccess )+import Prelude hiding ( catch )+import System.IO ( hClose, stdout, stderr )+import Control.Exception+ ( catch, fromException, SomeException, throwIO )+import Control.Monad ( when, unless )++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )+import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.UI.Commands+ ( putVerbose+ , putInfo+ , printDryRunMessageAndExit+ , setEnvDarcsPatches+ )+import Darcs.UI.CommandsAux ( checkPaths )+import Darcs.UI.Flags+ ( DarcsFlag, verbosity, compression, reorder, allowConflicts, externalMerge+ , wantGuiPause, diffingOpts, setScriptsExecutable, isInteractive, testChanges+ , hasXmlOutput, getReply, getCc, getSendmailCmd, hasSummary, dryRun+ )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands.Util ( testTentativeAndMaybeExit )+import Darcs.Repository.Flags ( UpdateWorking(..) )+import Darcs.Repository+ ( Repository+ , tentativelyMergePatches+ , finalizeRepositoryChanges+ , applyToWorking+ , invalidateIndex+ , setScriptsExecutablePatches+ )+import Darcs.Repository.Job ( RepoJob(RepoJob) )+import Darcs.Patch ( RepoPatch, description, PrimOf )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Witnesses.Ordered+ ( FL, mapFL, nullFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )++import Darcs.UI.External ( sendEmail )+import Darcs.Repository.Lock ( withStdoutTemp, readBinFile )+import Darcs.Util.Printer ( vcat, text )+import Storage.Hashed.Tree( Tree )++data PatchProxy (p :: * -> * -> *) = PatchProxy++-- |This class is a hack to abstract over pull/apply and rebase pull/apply.+class PatchApplier pa where++ -- |'CarrierType pa p' resolves to either 'p' or 'Rebasing p' + type CarrierType pa (p :: * -> * -> *) :: * -> * -> *++ repoJob+ :: pa+ -> [DarcsFlag]+ -> (forall p wR wU+ . ( RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree+ , RepoPatch (CarrierType pa p), ApplyState (CarrierType pa p) ~ Tree+ , ApplyState (PrimOf (CarrierType pa p)) ~ Tree+ )+ => (PatchProxy p -> Repository (CarrierType pa p) wR wU wR -> IO ()))+ -> RepoJob ()++ applyPatches+ :: forall p wR wU wT wX wZ+ . (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)+ => pa+ -> PatchProxy p+ -> String+ -> [DarcsFlag]+ -> String+ -> Repository (CarrierType pa p) wR wU wT+ -> FL (PatchInfoAnd (CarrierType pa p)) wX wT+ -> FL (PatchInfoAnd (CarrierType pa p)) wX wZ -> IO ()++data StandardPatchApplier = StandardPatchApplier++instance PatchApplier StandardPatchApplier where+ type CarrierType StandardPatchApplier p = p+ repoJob StandardPatchApplier _opts f = RepoJob (f PatchProxy)+ applyPatches StandardPatchApplier PatchProxy = standardApplyPatches++standardApplyPatches+ :: forall p wR wU wT wX wZ . (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)+ => String -> [DarcsFlag] -> String -> Repository p wR wU wT+ -> FL (PatchInfoAnd p) wX wT -> FL (PatchInfoAnd p) wX wZ -> IO ()+standardApplyPatches cmdName opts from_whom repository us' to_be_applied = do+ printDryRunMessageAndExit cmdName+ (verbosity opts)+ (hasSummary O.NoSummary opts)+ (dryRun opts)+ (hasXmlOutput opts)+ (isInteractive opts)+ to_be_applied+ when (nullFL to_be_applied && reorder opts == O.NoReorder) $ do + putStrLn $ "You don't want to " ++ cmdName ++ " any patches, so I'm exiting!"+ exitSuccess+ checkPaths opts to_be_applied+ redirectOutput opts from_whom $ do+ unless (nullFL to_be_applied) $ do+ putVerbose opts $ text $ "Will " ++ cmdName ++ " the following patches:"+ putVerbose opts . vcat $ mapFL description to_be_applied+ setEnvDarcsPatches to_be_applied+ Sealed pw <- tentativelyMergePatches repository cmdName+ (allowConflicts opts) YesUpdateWorking+ (externalMerge opts) (wantGuiPause opts)+ (compression opts) (verbosity opts)+ (reorder opts) (diffingOpts opts)+ us' to_be_applied+ invalidateIndex repository+ testTentativeAndMaybeExit repository+ (verbosity opts)+ (testChanges opts)+ (setScriptsExecutable opts)+ (isInteractive opts)+ "those patches do not pass the tests." (cmdName ++ " them") Nothing+ withSignalsBlocked $ do finalizeRepositoryChanges repository YesUpdateWorking (compression opts)+ _ <- applyToWorking repository (verbosity opts) pw `catch` \(e :: SomeException) ->+ fail ("Error applying patch to working dir:\n" ++ show e)+ when (setScriptsExecutable opts == O.YesSetScriptsExecutable) $+ setScriptsExecutablePatches pw+ return ()+ case (nullFL to_be_applied, reorder opts == O.Reorder) of+ (True,True) -> putInfo opts $ text $ "Nothing to " ++ cmdName ++ ", finished reordering."+ (False,True) -> putInfo opts $ text $ "Finished " ++ cmdName ++ "ing and reordering."+ _ -> putInfo opts $ text $ "Finished " ++ cmdName ++ "ing."++redirectOutput :: [DarcsFlag] -> String -> IO () -> IO ()+redirectOutput opts to doit = case getReply opts of+ Nothing -> doit+ Just from -> withStdoutTemp $ \tempf -> doitAndCleanup `catch` sendit tempf from+ where+ -- TODO: I suggest people writing such code should *at least* put in some comments.+ -- It is unclear how this works and how the intertwined exception handlers make+ -- this do what the author wanted.+ doitAndCleanup = doit >> hClose stdout >> hClose stderr+ sendit :: FilePath -> String -> SomeException -> IO a+ sendit tempf from e | Just ExitSuccess <- fromException e =+ do sendSanitizedEmail opts from to "Patch applied" cc tempf+ throwIO e+ sendit tempf from e | Just (_ :: ExitCode) <- fromException e =+ do sendSanitizedEmail opts from to "Patch failed!" cc tempf+ throwIO ExitSuccess+ sendit tempf from e =+ do sendSanitizedEmail opts from to "Darcs error applying patch!" cc $+ tempf ++ "\n\nCaught exception:\n"+++ show e++"\n"+ throwIO ExitSuccess+ cc = getCc opts++-- |sendSanitizedEmail sends a sanitized email using the given sendmailcmd+-- It takes @DacrsFlag@ options a file with the mail contents,+-- To:, Subject:, CC:, and mail body+sendSanitizedEmail :: [DarcsFlag] -> String -> String -> String -> String -> String -> IO ()+sendSanitizedEmail opts from to subject cc mailtext =+ do scmd <- getSendmailCmd opts+ body <- sanitizeFile mailtext+ sendEmail from to subject cc scmd body++-- sanitizeFile is used to clean up the stdout/stderr before sticking it in+-- an email.++sanitizeFile :: FilePath -> IO String+sanitizeFile f = sanitize `fmap` readBinFile f+ where sanitize s = wash $ remove_backspaces "" s+ wash ('\000':s) = "\\NUL" ++ wash s+ wash ('\026':s) = "\\EOF" ++ wash s+ wash (c:cs) = c : wash cs+ wash [] = []+ remove_backspaces rev_sofar "" = reverse rev_sofar+ remove_backspaces (_:rs) ('\008':s) = remove_backspaces rs s+ remove_backspaces "" ('\008':s) = remove_backspaces "" s+ remove_backspaces rs (s:ss) = remove_backspaces (s:rs) ss+
+ src/Darcs/UI/Commands.hs view
@@ -0,0 +1,504 @@+-- Copyright (C) 2002,2003,2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+module Darcs.UI.Commands+ ( CommandControl ( CommandData, HiddenCommand, GroupName )+ , DarcsCommand ( .. )+ , WrappedCommand(..)+ , wrappedCommandName+ , commandAlias+ , commandStub+ , commandOptions+ , commandAlloptions+ , withStdOpts+ , disambiguateCommands+ , CommandArgs(..)+ , getCommandHelp+ , getCommandMiniHelp+ , getSubcommands+ , usage+ , usageHelper+ , subusage+ , extractCommands+ , extractAllCommands+ , normalCommand+ , hiddenCommand+ , commandGroup+ , superName+ , nodefaults+ , putInfo+ , putVerbose+ , putWarning+ , putVerboseWarning+ , abortRun+ , printDryRunMessageAndExit+ , setEnvDarcsPatches+ , setEnvDarcsFiles+ , formatPath+ , defaultRepo+ , amInHashedRepository+ , amInRepository+ , amNotInRepository+ , findRepository+ ) where++import Prelude hiding ( (^) )+import Control.Monad ( when, unless )+import Data.List ( sort, isPrefixOf )+import Data.Maybe ( catMaybes )+import Storage.Hashed.Tree ( Tree )+import System.Console.GetOpt ( OptDescr )+import System.Exit ( exitSuccess )+import System.IO ( stderr )+#ifndef WIN32+import System.Posix.Env ( setEnv )++import Darcs.Patch ( listTouchedFiles )+import qualified Darcs.Patch ( summary )+#endif+import Darcs.Patch ( RepoPatch, xmlSummary, Patchy )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Info ( toXml )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefullyM )+import Darcs.Patch.Witnesses.Ordered ( FL, mapFL )++import qualified Darcs.Repository as R ( amInHashedRepository, amInRepository+ , amNotInRepository, findRepository )+import Darcs.Repository.Prefs ( defaultrepo )++import Darcs.UI.Options ( DarcsOption, DarcsOptDescr, (^), optDescr, odesc, parseFlags )+import Darcs.UI.Options.All+ ( StdCmdAction, stdCmdActions, anyVerbosity, UseCache, useCache, hooks+ , Verbosity(..), verbosity, Summary(..), DryRun(..), dryRun, XmlOutput(..) )++import Darcs.UI.Flags ( remoteRepos, workRepo, DarcsFlag )+import Darcs.UI.PrintPatch ( showFriendly )+import Darcs.UI.Usage ( usageInfo )++import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, putDocLn, hPutDocLn, text, (<+>), errorDoc+ , vsep, insertBeforeLastline, prefix, ($$), vcat+#ifndef WIN32+ , renderString+#endif+ , RenderMode(..)+ )+#ifndef WIN32+import Darcs.Util.Progress ( beginTedious, endTedious, tediousSize+ , finishedOneIO )+#endif+import Darcs.Util.Text ( chompTrailingNewline )++extractCommands :: [CommandControl] -> [WrappedCommand]+extractCommands ccl = [ cmd | CommandData cmd <- ccl ]++extractHiddenCommands :: [CommandControl] -> [WrappedCommand]+extractHiddenCommands ccl = [ cmd | HiddenCommand cmd <- ccl ]++extractAllCommands :: [CommandControl] -> [WrappedCommand]+extractAllCommands ccl = concatMap flatten (extractCommands ccl ++ extractHiddenCommands ccl)+ where flatten c@(WrappedCommand (DarcsCommand {})) = [c]+ flatten c@(WrappedCommand (SuperCommand { commandSubCommands = scs })) = c : extractAllCommands scs++-- |A 'WrappedCommand' is a 'DarcsCommand' where the options type has been hidden+data WrappedCommand where+ WrappedCommand :: DarcsCommand parsedFlags -> WrappedCommand++normalCommand :: DarcsCommand parsedFlags -> CommandControl+normalCommand c = CommandData (WrappedCommand c)++hiddenCommand :: DarcsCommand parsedFlags -> CommandControl+hiddenCommand c = HiddenCommand (WrappedCommand c)++commandGroup :: String -> CommandControl+commandGroup = GroupName++wrappedCommandName :: WrappedCommand -> String+wrappedCommandName (WrappedCommand c) = commandName c++wrappedCommandDescription :: WrappedCommand -> String+wrappedCommandDescription (WrappedCommand c) = commandDescription c++data CommandControl+ = CommandData WrappedCommand+ | HiddenCommand WrappedCommand+ | GroupName String++-- |A 'DarcsCommand' represents a command like add, record etc.+-- The 'parsedFlags' type represents the options that are+-- passed to the command's implementation+data DarcsCommand parsedFlags =+ DarcsCommand+ { commandProgramName -- programs that use libdarcs can change the name here+ , commandName+ , commandHelp+ , commandDescription :: String+ , commandExtraArgs :: Int+ , commandExtraArgHelp :: [String]+ , commandCommand :: -- First 'AbsolutePath' is the repository path,+ -- second one is the path where darcs was executed.+ (AbsolutePath, AbsolutePath)+ -> parsedFlags -> [String] -> IO ()+ , commandPrereq :: [DarcsFlag] -> IO (Either String ())+ , commandGetArgPossibilities :: IO [String]+ , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String]+ -> IO [String]+ , commandBasicOptions :: [DarcsOptDescr DarcsFlag]+ , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]+ , commandDefaults :: [DarcsFlag]+ , commandCheckOptions :: [DarcsFlag] -> [String]+ , commandParseOptions :: [DarcsFlag] -> parsedFlags+ }+ | SuperCommand+ { commandProgramName+ , commandName+ , commandHelp+ , commandDescription :: String+ , commandPrereq :: [DarcsFlag] -> IO (Either String ())+ , commandSubCommands :: [CommandControl]+ }++withStdOpts :: DarcsOption (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c+ -> DarcsOption (UseCache -> Maybe String -> Bool -> Maybe String -> Bool -> a) b+ -> DarcsOption a c+withStdOpts basicOpts advancedOpts =+ basicOpts ^ stdCmdActions ^ anyVerbosity ^ advancedOpts ^ useCache ^ hooks++commandAlloptions :: DarcsCommand pf -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])+commandAlloptions DarcsCommand { commandBasicOptions = opts1+ , commandAdvancedOptions = opts2 } =+ ( opts1 ++ odesc stdCmdActions+ , odesc anyVerbosity ++ opts2 ++ odesc useCache ++ odesc hooks )+commandAlloptions SuperCommand { } = (odesc stdCmdActions, [])++-- Obtain options suitable as input to System.Console.Getopt, including the+-- --disable option (which is not listed explicitly in the DarcsCommand+-- definitions).+commandOptions :: AbsolutePath -> DarcsCommand pf -> [OptDescr DarcsFlag]+commandOptions cwd = map (optDescr cwd) . uncurry (++) . commandAlloptions++nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]+nodefaults _ _ = return++getSubcommands :: DarcsCommand pf -> [CommandControl]+getSubcommands c@(SuperCommand {}) = commandSubCommands c+getSubcommands _ = []++commandAlias :: String -> Maybe (DarcsCommand pf) -> DarcsCommand pf -> DarcsCommand pf+commandAlias n msuper c =+ c { commandName = n+ , commandDescription = "Alias for `" ++ commandProgramName c ++ " "+ ++ cmdName ++ "'."+ , commandHelp = "The `" ++ commandProgramName c ++ " " ++ n+ ++ "' command is an alias for " ++ "`"+ ++ commandProgramName c ++ " " ++ cmdName ++ "'.\n"+ ++ commandHelp c+ }+ where+ cmdName = unwords . map commandName . maybe id (:) msuper $ [ c ]++commandStub :: String -> String -> String -> DarcsCommand pf -> DarcsCommand pf+commandStub n h d c = c { commandName = n+ , commandHelp = h+ , commandDescription = d+ , commandCommand = \_ _ _ -> putStr h+ }++usage :: [CommandControl] -> String+usage cs = unlines+ [ "Usage: darcs COMMAND ..."+ , ""+ , "Commands:"+ , usageHelper cs+ , "Use 'darcs COMMAND --help' for help on a single command."+ , "Use 'darcs --version' to see the darcs version number."+ , "Use 'darcs --exact-version' to see a detailed darcs version."+ , "Use 'darcs help patterns' for help on patch matching."+ , "Use 'darcs help environment' for help on environment variables."+ , ""+ , "Check bug reports at http://bugs.darcs.net/"+ ]++subusage :: DarcsCommand pf -> String+subusage super = usageInfo header (odesc stdCmdActions) ++ superHelp+ where+ header = unlines [ unwords [ "Usage:"+ , commandProgramName super+ , commandName super+ , "SUBCOMMAND ..."+ ]+ , ""+ , commandDescription super+ , ""+ , "Subcommands:"+ , usageHelper (getSubcommands super)+ , "Options:"+ ]+ superHelp = '\n' : commandHelp super++usageHelper :: [CommandControl] -> String+usageHelper xs = usageHelper' (maximum $ 15 : (catMaybes $ map f xs)) xs+ where+ -- returns length of necessary tabbing this command+ f (CommandData c) = Just ((+2) . length . wrappedCommandName $ c)+ f _ = Nothing++usageHelper' :: Int -> [CommandControl] -> String+usageHelper' _ [] = ""+usageHelper' x (HiddenCommand _ : cs) = usageHelper' x cs+usageHelper' x (CommandData c : cs) = " " ++ padSpaces (wrappedCommandName c) x+ ++ chompTrailingNewline (wrappedCommandDescription c)+ ++ "\n" ++ usageHelper' x cs+usageHelper' x (GroupName n : cs) = "\n" ++ n ++ "\n" ++ usageHelper' x cs++padSpaces :: String -> Int -> String+padSpaces s n = s ++ replicate (n - length s) ' '++superName :: Maybe (DarcsCommand pf) -> String+superName Nothing = ""+superName (Just x) = commandName x ++ " "++getCommandMiniHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String+getCommandMiniHelp msuper cmd = unlines+ [ getCommandHelpCore msuper cmd+ , ""+ , unwords [ "See"+ , commandProgramName cmd+ , "help"+ , maybe "" ((++ " ") . commandName) msuper ++ commandName cmd+ , "for details."+ ]+ ]++getCommandHelp :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String+getCommandHelp msuper cmd = basicHelp ++ advancedHelp ++ cmdHelp+ where+ basicHelp = unlines (reverse basicR)++ advancedHelp = if null advanced+ then ""+ else '\n' :+ unlines ("Advanced options:" : reverse advancedR)++ cmdHelp = '\n' : commandHelp cmd++ -- we could just call usageInfo twice, but then the advanced+ -- options might not line up with the basic ones (no short switches)+ (advancedR, basicR) = splitAt (length advanced) . reverse . lines $+ combinedUsage++ combinedUsage = let header = getCommandHelpCore msuper cmd ++ subcommands+ ++ "\n\nOptions:"+ in usageInfo header (basic ++ advanced)++ (basic, advanced) = commandAlloptions cmd++ subcommands = case msuper of+ Nothing -> case getSubcommands cmd of+ [] -> []+ s -> "\n\nSubcommands:\n"+ ++ usageHelper s+ -- we don't want to list subcommands if we're already+ -- specifying them+ Just _ -> ""++getCommandHelpCore :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> String+getCommandHelpCore msuper cmd =+ unwords [ "Usage:"+ , commandProgramName cmd+ , superName msuper ++ commandName cmd+ , "[OPTION]..."+ , unwords args_help+ ]+ ++ "\n" ++ commandDescription cmd+ where+ args_help = case cmd of+ (DarcsCommand {}) -> commandExtraArgHelp cmd+ _ -> []++data CommandArgs where+ CommandOnly :: DarcsCommand parsedFlags -> CommandArgs+ SuperCommandOnly :: DarcsCommand parsedFlags -> CommandArgs+ SuperCommandSub :: DarcsCommand parsedFlags1 -> DarcsCommand parsedFlags2 -> CommandArgs++-- Parses a darcs command line with potentially abbreviated commands+disambiguateCommands :: [CommandControl] -> String -> [String]+ -> Either String (CommandArgs, [String])+disambiguateCommands allcs cmd args = do+ WrappedCommand c <- extract cmd allcs+ case (getSubcommands c, args) of+ ([], _) -> return (CommandOnly c, args)+ (_, []) -> return (SuperCommandOnly c, args)+ (subcs, a : as) -> case extract a subcs of+ Left _ -> return (SuperCommandOnly c, args)+ Right (WrappedCommand sc) -> return (SuperCommandSub c sc, as)++extract :: String -> [CommandControl] -> Either String WrappedCommand+extract cmd cs = case potentials of+ [] -> Left $ "No such command '" ++ cmd ++ "'\n"+ [c] -> Right c+ cs' -> Left $ unlines [ "Ambiguous command..."+ , ""+ , "The command '" ++ cmd ++ "' could mean one of:"+ , unwords . sort . map wrappedCommandName $ cs'+ ]+ where+ potentials = [c | c <- extractCommands cs, cmd `isPrefixOf` wrappedCommandName c]+ ++ [h | h <- extractHiddenCommands cs, cmd == wrappedCommandName h]++amVerbose :: [DarcsFlag] -> Bool+amVerbose = (== Verbose) . parseFlags verbosity++amQuiet :: [DarcsFlag] -> Bool+amQuiet = (== Quiet) . parseFlags verbosity++putVerbose :: [DarcsFlag] -> Doc -> IO ()+putVerbose flags = when (amVerbose flags) . putDocLn++putInfo :: [DarcsFlag] -> Doc -> IO ()+putInfo flags = unless (amQuiet flags) . putDocLn++putWarning :: [DarcsFlag] -> Doc -> IO ()+putWarning flags = unless (amQuiet flags) . hPutDocLn Encode stderr++putVerboseWarning :: [DarcsFlag] -> Doc -> IO ()+putVerboseWarning flags = when (amVerbose flags) . hPutDocLn Encode stderr++abortRun :: [DarcsFlag] -> Doc -> IO ()+abortRun flags msg = if parseFlags dryRun flags == YesDryRun+ then putInfo flags $ text "NOTE:" <+> msg+ else errorDoc msg++-- | @'printDryRunMessageAndExit' action flags patches@ prints a string+-- representing the action that would be taken if the @--dry-run@ option had+-- not been passed to darcs. Then darcs exits successfully. @action@ is the+-- name of the action being taken, like @\"push\"@ @flags@ is the list of flags+-- which were sent to darcs @patches@ is the sequence of patches which would be+-- touched by @action@.+printDryRunMessageAndExit :: (RepoPatch p, ApplyState p ~ Tree)+ => String+ -> Verbosity -> Summary -> DryRun -> XmlOutput+ -> Bool -- interactive+ -> FL (PatchInfoAnd p) wX wY+ -> IO ()+printDryRunMessageAndExit action v s d x interactive patches = do+ when (d == YesDryRun) $ do+ putInfoX . text $ unwords [ "Would"+ , action+ , "the following changes:"+ ]+ putDocLn put_mode+ putInfoX $ text ""+ putInfoX $ text "Making no changes: this is a dry run."+ exitSuccess+ when (not interactive && s == YesSummary) $ do+ putInfoX . text $ unwords [ "Will"+ , action+ , "the following changes:"+ ]+ putDocLn put_mode+ where+ put_mode = if x == YesXml+ then text "<patches>" $$+ vcat (mapFL (indent . xml_info s) patches) $$+ text "</patches>"+ else vsep $ mapFL (showFriendly v s) patches++ putInfoX = if x == YesXml then const (return ()) else putDocLn++ xml_info YesSummary = xml_with_summary+ xml_info NoSummary = toXml . info++ xml_with_summary hp+ | Just p <- hopefullyM hp = insertBeforeLastline (toXml $ info hp)+ (indent $ xmlSummary p)+ xml_with_summary hp = toXml (info hp)++ indent = prefix " "++-- | Set the DARCS_PATCHES and DARCS_PATCHES_XML environment variables with+-- info about the given patches, for use in post-hooks.+setEnvDarcsPatches :: (RepoPatch p, ApplyState p ~ Tree)+ => FL (PatchInfoAnd p) wX wY -> IO ()+#ifndef WIN32+setEnvDarcsPatches ps = do+ let k = "Defining set of chosen patches"+ beginTedious k+ tediousSize k 3+ finishedOneIO k "DARCS_PATCHES"+ setEnvCautiously "DARCS_PATCHES" (renderString Encode $ Darcs.Patch.summary ps)+ finishedOneIO k "DARCS_PATCHES_XML"+ setEnvCautiously "DARCS_PATCHES_XML" . renderString Encode $+ text "<patches>" $$+ vcat (mapFL (toXml . info) ps) $$+ text "</patches>"+ finishedOneIO k "DARCS_FILES"+ setEnvCautiously "DARCS_FILES" $ unlines (listTouchedFiles ps)+ endTedious k++-- | Set some environment variable to the given value, unless said value is+-- longer than 10K characters, in which case do nothing.+setEnvCautiously :: String -> String -> IO ()+setEnvCautiously e v+ | toobig (10 * 1024) v = return ()+ | otherwise = setEnv e v True+ where+ toobig :: Int -> [a] -> Bool+ toobig 0 _ = True+ toobig _ [] = False+ toobig n (_ : xs) = toobig (n - 1) xs+#else+setEnvDarcsPatches _ = return ()+#endif++-- | Set the DARCS_FILES environment variable to the files touched by the+-- given patch, one per line, for use in post-hooks.+setEnvDarcsFiles :: (PatchInspect p, Patchy p) => p wX wY -> IO ()+#ifndef WIN32+setEnvDarcsFiles ps =+ setEnvCautiously "DARCS_FILES" $ unlines (listTouchedFiles ps)+#else+setEnvDarcsFiles _ = return ()+#endif++-- | Format a path for screen output, so that the user sees where the path+-- begins and ends. Could (should?) also warn about unprintable characters+-- here.+formatPath :: String -> String+formatPath path = "\"" ++ quote path ++ "\""+ where+ quote "" = ""+ quote (c:cs) = if c `elem` ['\\', '"']+ then '\\' : c : quote cs+ else c : quote cs++defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]+defaultRepo fs = defaultrepo (remoteRepos fs)++amInHashedRepository :: [DarcsFlag] -> IO (Either String ())+amInHashedRepository fs = R.amInHashedRepository (workRepo fs)++amInRepository :: [DarcsFlag] -> IO (Either String ())+amInRepository fs = R.amInRepository (workRepo fs)++amNotInRepository :: [DarcsFlag] -> IO (Either String ())+amNotInRepository fs = R.amNotInRepository (workRepo fs)++findRepository :: [DarcsFlag] -> IO (Either String ())+findRepository fs = R.findRepository (workRepo fs)
+ src/Darcs/UI/Commands/Add.hs view
@@ -0,0 +1,383 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Module : Darcs.UI.Commands.Add+-- Copyright : 2002-2004 David Roundy+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++{-# LANGUAGE CPP #-}+module Darcs.UI.Commands.Add+ (+ add+ , expandDirs+ ) where+++#include "impossible.h"++import Prelude hiding ( (^), catch )++import Control.Exception ( catch, IOException )+import Control.Monad ( when, unless, liftM )+import Data.List ( (\\), nub )+import Data.List.Ordered ( nubSort )+import Data.Maybe ( isNothing, maybeToList )+import Darcs.Util.Printer ( text )+import Storage.Hashed.Tree ( Tree, findTree, expand )+import Darcs.Util.Path ( floatPath, anchorPath, parents,+ SubPath, toFilePath, simpleSubPath, toPath, AbsolutePath )+import System.FilePath.Posix ( takeDirectory, (</>) )+import System.Posix.Files ( isRegularFile, isDirectory, isSymbolicLink )+import System.Directory ( getPermissions, readable )++import qualified System.FilePath.Windows as WindowsFilePath++import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts, putInfo, putWarning, putVerboseWarning+ , nodefaults, amInHashedRepository)+import Darcs.UI.Flags+ ( DarcsFlag+ , includeBoring, doAllowCaseOnly, doAllowWindowsReserved, useCache, dryRun, umask+ , fixSubPaths, verbosity )+import Darcs.UI.Options+ ( DarcsOption+ , (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase )+import Darcs.Repository.Flags ( UpdateWorking(..) )+import Darcs.Patch ( Patchy, PrimPatch, applyToTree, addfile, adddir )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Repository.State ( readRecordedAndPending, updateIndex )+import Darcs.Repository+ ( withRepoLock+ , RepoJob(..)+ , addToPending+ , listFiles+ , listUnregisteredFiles+ )+import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter )+import Darcs.Util.File ( getFileStatus, withCurrentDirectory )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )+++addDescription :: String+addDescription = "Add one or more new files or directories."+++addHelp :: String+addHelp =+ "Generally a repository contains both files that should be version\n" +++ "controlled (such as source code) and files that Darcs should ignore\n" +++ "(such as executables compiled from the source code). The `darcs add`\n" +++ "command is used to tell Darcs which files to version control.\n" +++ "\n" +++ "When an existing project is first imported into a Darcs repository, it\n" +++ "is common to run `darcs add -r *` or `darcs record -l` to add all\n" +++ "initial source files into darcs.\n"+++ "\n" +++ "Adding symbolic links (symlinks) is not supported.\n\n"+++addHelp' :: String+addHelp' =+ "Darcs will ignore all files and folders that look \"boring\". The\n" +++ "`--boring` option overrides this behaviour.\n" +++ "\n" +++ "Darcs will not add file if another file in the same folder has the\n" +++ "same name, except for case. The `--case-ok` option overrides this\n" +++ "behaviour. Windows and OS X usually use filesystems that do not allow\n" +++ "files a folder to have the same name except for case (for example,\n" +++ "`ReadMe` and `README`). If `--case-ok` is used, the repository might be\n" +++ "unusable on those systems!\n\n"++addBasicOpts :: DarcsOption a+ (Bool -> Bool -> Bool -> Bool -> Maybe String -> O.DryRun -> a)+addBasicOpts = O.includeBoring+ ^ O.allowProblematicFilenames+ ^ O.recursive+ ^ O.workingRepoDir+ ^ O.dryRun++addAdvancedOpts :: DarcsOption a (O.UMask -> a)+addAdvancedOpts = O.umask++addOpts :: DarcsOption a+ (Bool+ -> Bool+ -> Bool+ -> Bool+ -> Maybe String+ -> O.DryRun+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UMask+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+addOpts = withStdOpts addBasicOpts addAdvancedOpts++add :: DarcsCommand [DarcsFlag]+add = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "add"+ , commandHelp = addHelp ++ addHelp'+ , commandDescription = addDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = [ "<FILE or DIRECTORY> ..." ]+ , commandCommand = addCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = listUnregisteredFiles False+ -- bash completion should not offer boring files+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc addAdvancedOpts+ , commandBasicOptions = odesc addBasicOpts+ , commandDefaults = defaultFlags addOpts+ , commandCheckOptions = ocheck addOpts+ , commandParseOptions = onormalise addOpts+ }+++addCmd :: (AbsolutePath, AbsolutePath)+ -> [DarcsFlag]+ -> [String]+ -> IO ()+addCmd paths opts args+ | null args = putStrLn $ "Nothing specified, nothing added." +++ "Maybe you wanted to say `darcs add --recursive .'?"+ | otherwise = do+ fs <- fixSubPaths paths args+ case fs of+ [] -> fail "No valid arguments were given"+ _ -> addFiles opts fs+++addFiles :: [DarcsFlag] -- ^ Command options+ -> [SubPath]+ -> IO ()+addFiles opts origfiles = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ -- TODO do not expand here, and use findM/findIO or such later+ -- (needs adding to hashed-storage first though)+ cur <- expand =<< readRecordedAndPending repository+ let parlist = getParents cur (map toFilePath origfiles)+ flist' <- if parseFlags O.recursive opts+ then expandDirs (includeBoring opts) origfiles+ else return origfiles+ let flist = nubSort (parlist ++ toFilePath `map` flist')+ nboring <- if includeBoring opts+ then return darcsdirFilter+ else boringFileFilter+ mapM_ (putWarning opts . text . ((msgSkipping msgs ++ " boring file ")++)) $+ flist \\ nboring flist+ Sealed ps <- fmap unFreeLeft $ addp msgs opts cur $ nboring flist+ when (nullFL ps && not (null origfiles) && notQuiet) $+ fail "No files were added"+ unless gotDryRun $+ do addToPending repository YesUpdateWorking ps+ updateIndex repository+ where+ gotDryRun = dryRun opts == O.YesDryRun+ msgs | gotDryRun = dryRunMessages+ | otherwise = normalMessages+ notQuiet = verbosity opts /= O.Quiet+++addp :: forall prim . (Patchy prim, PrimPatch prim, ApplyState prim ~ Tree)+ => AddMessages+ -> [DarcsFlag]+ -> Tree IO+ -> [FilePath]+ -> IO (FreeLeft (FL prim))+addp msgs opts cur0 files = do+ (ps, dups) <-+ foldr+ (\f rest cur accPS accDups -> do+ addResult <- addp' cur f+ case addResult of+ -- If a single file fails to add, stop further processing.+ (_, Nothing, Nothing) -> return ([], [])+ (cur', mp, mdup) -> rest cur' (maybeToList mp ++ accPS) (maybeToList mdup ++ accDups))+ (\_ ps dups -> return (reverse ps, dups))+ files+ cur0 [] []+ let uniq_dups = nub dups+ caseMsg =+ if gotAllowCaseOnly then ":"+ else ";\nnote that to ensure portability we don't allow\n" +++ "files that differ only in case. Use --case-ok to override this:"+ unless (null dups) $ do+ dupMsg <-+ case uniq_dups of+ [f] -> do+ isDir <- doesDirectoryReallyExist f+ if isDir+ then return $+ "The following directory " +++ msgIs msgs ++ " already in the repository"+ else return $+ "The following file " +++ msgIs msgs ++ " already in the repository"+ fs -> do+ areDirs <- mapM doesDirectoryReallyExist fs+ if and areDirs+ then return $+ "The following directories " +++ msgAre msgs ++ " already in the repository"+ else+ (if or areDirs+ then return $+ "The following files and directories " +++ msgAre msgs ++ " already in the repository"+ else return $+ "The following files " +++ msgAre msgs ++ " already in the repository")+ putWarning opts . text $ "WARNING: Some files were not added because they are already in the repository."+ putVerboseWarning opts . text $ dupMsg ++ caseMsg+ mapM_ (putVerboseWarning opts . text) uniq_dups+ return $ foldr (joinGap (+>+)) (emptyGap NilFL) ps+ where+ addp' :: Tree IO+ -> FilePath+ -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)+ addp' cur f = do+ already_has <- (if gotAllowCaseOnly then treeHas else treeHasAnycase) cur f+ mstatus <- getFileStatus f+ case (already_has, is_badfilename, mstatus) of+ (True, _, _) -> return (cur, Nothing, Just f)+ (_, True, _) -> do+ putWarning opts . text $+ "The filename " ++ f ++ " is invalid under Windows.\n" +++ "Use --reserved-ok to allow it."+ return add_failure+ (_, _, Just s)+ | isDirectory s -> trypatch $ freeGap (adddir f :>: NilFL)+ | isRegularFile s -> trypatch $ freeGap (addfile f :>: NilFL)+ | isSymbolicLink s -> do+ putWarning opts . text $+ "Sorry, file " ++ f +++ " is a symbolic link, which is unsupported by darcs."+ return add_failure+ _ -> do+ putWarning opts . text $ "File "++ f ++" does not exist!"+ return add_failure+ where+ is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)+ add_failure = (cur, Nothing, Nothing)+ trypatch :: FreeLeft (FL prim)+ -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)+ trypatch p = do+ perms <- getPermissions f+ if not $ readable perms+ then do+ putWarning opts . text $+ msgSkipping msgs ++ " '" ++ f ++ "': permission denied "+ return (cur, Nothing, Nothing)+ else trypatch' p+ trypatch' p = do+ Sealed p' <- return $ unFreeLeft p+ ok <- treeHasDir cur parentdir+ if ok+ then do+ tree <- applyToTree p' cur+ putInfo opts . text $+ msgAdding msgs ++ " '" ++ f ++ "'"+ return (tree, Just p, Nothing)+ else do+ putWarning opts . text $+ msgSkipping msgs ++ " '" ++ f +++ "' ... couldn't add parent directory '" +++ parentdir ++ "' to repository"+ return (cur, Nothing, Nothing)+ `catch` \(e :: IOException) -> do+ putWarning opts . text $+ msgSkipping msgs ++ " '" ++ f ++ "' ... " ++ show e+ return (cur, Nothing, Nothing)+ parentdir = takeDirectory f+ gotAllowCaseOnly = doAllowCaseOnly opts+ gotAllowWindowsReserved = doAllowWindowsReserved opts+++data AddMessages = AddMessages+ {+ msgSkipping :: String+ , msgAdding :: String+ , msgIs :: String+ , msgAre :: String+ }+++normalMessages :: AddMessages+normalMessages = AddMessages+ {+ msgSkipping = "Skipping"+ , msgAdding = "Adding"+ , msgIs = "is"+ , msgAre = "are"+ }+++dryRunMessages :: AddMessages+dryRunMessages = AddMessages+ {+ msgSkipping = "Would skip"+ , msgAdding = "Would add"+ , msgIs = "would be"+ , msgAre = "would be"+ }+++doesDirectoryReallyExist :: FilePath -> IO Bool+doesDirectoryReallyExist f = maybe False isDirectory `fmap` getFileStatus f+++expandDirs :: Bool -> [SubPath]+ -> IO [SubPath]+expandDirs doIncludeBoring fs =+ do+ liftM (map (fromJust . simpleSubPath)) $+ concat `fmap` mapM (expandOne doIncludeBoring . toPath) fs+++expandOne :: Bool -> FilePath+ -> IO [FilePath]+expandOne doIncludeBoring "" = listFiles doIncludeBoring+expandOne doIncludeBoring f = do+ isdir <- doesDirectoryReallyExist f+ if not isdir+ then return [f]+ else do+ fs <- withCurrentDirectory f (listFiles doIncludeBoring)+ return $ f: map (f </>) fs+++getParents :: Tree IO+ -> [FilePath]+ -> [FilePath]+getParents cur = map (anchorPath "") . go . map floatPath+ where+ go fs = filter (isNothing . findTree cur) $ concatMap parents fs+
+ src/Darcs/UI/Commands/Amend.hs view
@@ -0,0 +1,476 @@+-- Copyright (C) 2004,2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Copyright : 2004, 2007 David Roundy+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++module Darcs.UI.Commands.Amend+ (+ amend+ , amendrecord+ , updatePatchHeader+ ) where++import Prelude hiding ( (^) )++import Data.Maybe ( isNothing, isJust )+import Control.Applicative ( (<$>) )+import Control.Monad ( unless, when )+import System.Exit ( exitSuccess )++import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts+ , commandAlias+ , nodefaults+ , setEnvDarcsFiles+ , setEnvDarcsPatches+ , amInHashedRepository+ )+import Darcs.UI.Commands.Record ( getLog )+import Darcs.UI.Commands.Util ( announceFiles, testTentativeAndMaybeExit )+import Darcs.UI.Flags+ ( DarcsFlag+ , diffOpts, fixSubPaths, getEasyAuthor, promptAuthor, getDate )+import Darcs.UI.Options ( DarcsOption, (^), oparse, odesc, ocheck, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) )+import Darcs.Patch ( RepoPatch, description, PrimOf, fromPrims,+ infopatch, getdeps, adddeps, effect, invert, invertFL+ )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Info ( piAuthor, piName, piLog, piDateString,+ patchinfo, isInverted, isTag, invertName,+ )+import Darcs.Patch.Prim ( canonizeFL )+import Darcs.Patch.Split ( primSplitter )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully, info, patchDesc )+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )+import Darcs.Patch.Rebase.Name ( RebaseName(..) )+import Darcs.Util.Path ( toFilePath, SubPath(), AbsolutePath )+import Darcs.Repository+ ( Repository+ , withRepoLock+ , RepoJob(..)+ , tentativelyRemovePatches+ , tentativelyAddPatch+ , withManualRebaseUpdate+ , finalizeRepositoryChanges+ , invalidateIndex+ , unrecordedChangesWithPatches+ , readRecorded+ , listRegisteredFiles+ )+import Darcs.Repository.Prefs ( globalPrefsDirDoc )+import Darcs.Repository.Util ( getMovesPs, getReplaces )+import Darcs.UI.SelectChanges+ ( selectChanges+ , WhichChanges(..)+ , selectionContextPrim+ , runSelection+ , withSelectedPatchFromRepo+ , askAboutDepends+ )+import qualified Darcs.UI.SelectChanges as S+ ( PatchSelectionOptions(..)+ )+import Darcs.Util.Exception ( clarifyErrors )+import Darcs.Util.Prompt ( askUser )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), (:>)(..), (+>+), nullFL, reverseRL, mapFL_FL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )++import Darcs.Util.Printer ( putDocLn )+import Storage.Hashed.Tree( Tree )+import Darcs.Repository.Internal ( tentativelyRemoveFromPending )+++amendDescription :: String+amendDescription = "Improve a patch before it leaves your repository."+++amendHelp :: String+amendHelp =+ "Amend updates a \"draft\" patch with additions or improvements,\n" +++ "resulting in a single \"finished\" patch.\n" +++ "\n" +++ "By default `amend` proposes you to record additional changes.\n" +++ "If instead you want to remove changes, use the flag `--unrecord`.\n" +++ "\n" +++ "When recording a draft patch, it is a good idea to start the name with\n" +++ "`DRAFT:`. When done, remove it with `darcs amend --edit-long-comment`.\n" +++ "Alternatively, to change the patch name without starting an editor, \n" +++ "use the `--name`/`-m` flag:\n" +++ "\n" +++ " darcs amend --match 'name \"DRAFT: foo\"' --name 'foo2'\n" +++ "\n" +++ "Like `darcs record`, if you call amend with files as arguments,\n" +++ "you will only be asked about changes to those files. So to amend a\n" +++ "patch to foo.c with improvements in bar.c, you would run:\n" +++ "\n" +++ " darcs amend --match 'touch foo.c' bar.c\n" +++ "\n" +++ "It is usually a bad idea to amend another developer's patch. To make\n" +++ "amend only ask about your own patches by default, you can add\n" +++ "something like `amend match David Roundy` to `" ++ globalPrefsDirDoc +++ "defaults`, \n" +++ "where `David Roundy` is your name.\n"++amendBasicOpts :: DarcsOption a+ (Bool+ -> [O.MatchFlag]+ -> O.TestChanges+ -> Maybe Bool+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> Maybe O.AskLongComment+ -> Bool+ -> O.LookFor+ -> Maybe String+ -> O.WithContext+ -> O.DiffAlgorithm+ -> a)+amendBasicOpts+ = O.amendUnrecord+ ^ O.matchOneNontag+ ^ O.testChanges+ ^ O.interactive --True+ ^ O.author+ ^ O.selectAuthor+ ^ O.patchname+ ^ O.askdeps+ ^ O.askLongComment+ ^ O.keepDate+ ^ O.lookfor+ ^ O.workingRepoDir+ ^ O.withContext+ ^ O.diffAlgorithm++amendAdvancedOpts :: DarcsOption a+ (O.Compression+ -> O.UseIndex+ -> O.UMask+ -> O.SetScriptsExecutable+ -> a)+amendAdvancedOpts = O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable++amendOpts :: DarcsOption a+ (Bool+ -> [O.MatchFlag]+ -> O.TestChanges+ -> Maybe Bool+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> Maybe O.AskLongComment+ -> Bool+ -> O.LookFor+ -> Maybe String+ -> O.WithContext+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.Compression+ -> O.UseIndex+ -> O.UMask+ -> O.SetScriptsExecutable+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+amendOpts = withStdOpts amendBasicOpts amendAdvancedOpts++data AmendConfig = AmendConfig+ { amendUnrecord :: Bool+ , matchFlags :: [O.MatchFlag]+ , testChanges :: O.TestChanges+ , interactive :: Maybe Bool+ , author :: Maybe String+ , selectAuthor :: Bool+ , patchname :: Maybe String+ , askDeps :: Bool+ , askLongComment :: Maybe O.AskLongComment+ , keepDate :: Bool+ , lookfor :: O.LookFor+ , _workingRepoDir :: Maybe String+ , withContext :: O.WithContext+ , diffAlgorithm :: O.DiffAlgorithm+ , verbosity :: O.Verbosity+ , compress :: O.Compression+ , useIndex :: O.UseIndex+ , umask :: O.UMask+ , sse :: O.SetScriptsExecutable+ , useCache :: O.UseCache+ }++amendConfig :: [DarcsFlag] -> AmendConfig+amendConfig =+ oparse (amendBasicOpts ^ O.verbosity ^ amendAdvancedOpts ^ O.useCache) AmendConfig++amend :: DarcsCommand AmendConfig+amend = DarcsCommand+ {+ commandProgramName = "darcs"+ , commandName = "amend"+ , commandHelp = amendHelp+ , commandDescription = amendDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+ , commandCommand = amendCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = listRegisteredFiles+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc amendAdvancedOpts+ , commandBasicOptions = odesc amendBasicOpts+ , commandDefaults = defaultFlags amendOpts+ , commandCheckOptions = ocheck amendOpts+ , commandParseOptions = amendConfig+ }+++amendrecord :: DarcsCommand AmendConfig+amendrecord = commandAlias "amend-record" Nothing amend++amendCmd :: (AbsolutePath, AbsolutePath)+ -> AmendConfig+ -> [String]+ -> IO ()+amendCmd _ cfg [] = doAmend cfg Nothing+amendCmd fps cfg args = do+ files <- fixSubPaths fps args+ if null files+ then fail "No valid arguments were given, nothing to do."+ else doAmend cfg $ Just files++doAmend :: AmendConfig -> Maybe [SubPath] -> IO ()+doAmend cfg files =+ withRepoLock NoDryRun (useCache cfg) YesUpdateWorking (umask cfg) $+ RebaseAwareJob (compress cfg) (verbosity cfg) YesUpdateWorking $ \(repository :: Repository p wR wU wR) ->+ withSelectedPatchFromRepo "amend" repository (patchSelOpts cfg) $ \ (_ :> oldp) -> do+ announceFiles files "Amending changes in"+ -- auxiliary function needed because the witness types differ for the isTag case+ pristine <- readRecorded repository+ let go :: forall wU1 . FL (PrimOf p) wR wU1 -> IO ()+ go NilFL | not (hasEditMetadata cfg) = putStrLn "No changes!"+ go ch =+ do let context = selectionContextPrim First "record"+ (patchSelOpts cfg)+ --([All,Unified] `intersect` opts)+ (Just primSplitter)+ (map toFilePath <$> files)+ (Just pristine)+ (chosenPatches :> _) <- runSelection (selectChanges ch) context+ addChangesToPatch cfg repository oldp chosenPatches+ if not (isTag (info oldp))+ -- amending a normal patch+ then if amendUnrecord cfg+ then do let sel = selectChanges (effect oldp)+ context = selectionContextPrim Last "unrecord"+ (patchSelOpts cfg)+ -- ([All,Unified] `intersect` opts)+ (Just primSplitter)+ (map toFilePath <$> files)+ (Just pristine)+ (_ :> chosenPrims) <- runSelection sel context+ let invPrims = reverseRL (invertFL chosenPrims)+ addChangesToPatch cfg repository oldp invPrims+ else do Sealed replacePs <- if O.replaces (lookfor cfg) == O.YesLookForReplaces+ then getReplaces (diffingOpts cfg) repository files+ else return (Sealed NilFL)+ movesPs <- if O.moves (lookfor cfg) == O.YesLookForMoves+ then getMovesPs repository files+ else return NilFL+ go =<< unrecordedChangesWithPatches (diffingOpts cfg) repository files+ movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR)+ -- amending a tag+ else if hasEditMetadata cfg && isNothing files+ -- the user is not trying to add new changes to the tag so there is+ -- no reason to warn.+ then go NilFL+ -- the user is trying to add new changes to a tag.+ else do if hasEditMetadata cfg+ -- the user already knows that it is possible to edit tag metadata,+ -- note that s/he is providing editing options!+ then putStrLn "You cannot add new changes to a tag."+ -- the user may not be aware that s/he can edit tag metadata.+ else putStrLn "You cannot add new changes to a tag, but you are allowed to edit tag's metadata (see darcs help amend)."+ go NilFL+++addChangesToPatch :: forall p wR wU wT wX wY . (RepoPatch p, ApplyState p ~ Tree)+ => AmendConfig+ -> Repository p wR wU wT+ -> PatchInfoAnd p wX wT+ -> FL (PrimOf p) wT wY+ -> IO ()+addChangesToPatch cfg repository oldp chs =+ if nullFL chs && not (hasEditMetadata cfg)+ then putStrLn "You don't want to record anything!"+ else do+ invalidateIndex repository+ -- If a rebase is in progress, we want to manually update the rebase state, using+ -- the amendments directly as rebase fixups. This is necessary because otherwise+ -- the normal commute rules for the rebase state will first remove the original+ -- patch then add the amended patch, and this can lead to more conflicts than using+ -- the amendment as a fixup directly. For example, if a rename operation is amended in,+ -- the rename can be propagated to any edits to the file in the rebase state, whereas+ -- a delete then add would just cause a conflict.+ --+ -- We can also signal that any explicit dependencies of the old patch should be rewritten+ -- for the new patch using a 'NameFixup'.+ (repository''', (mlogf, newp)) <- withManualRebaseUpdate (compress cfg) (verbosity cfg) YesUpdateWorking repository $ \repository' -> do++ repository'' <- tentativelyRemovePatches repository' (compress cfg) YesUpdateWorking (oldp :>: NilFL)+ (mlogf, newp) <- updatePatchHeader+ (askDeps cfg)+ (patchSelOpts cfg)+ (keepDate cfg)+ (selectAuthor cfg)+ (author cfg)+ (patchname cfg)+ (askLongComment cfg)+ repository'' oldp chs+ let fixups =+ mapFL_FL PrimFixup (invert chs) +>++ NameFixup (Rename (info newp) (info oldp)) :>:+ NilFL+ setEnvDarcsFiles newp+ repository''' <- tentativelyAddPatch repository'' (compress cfg) (verbosity cfg) YesUpdateWorking newp+ return (repository''', fixups, (mlogf, newp))+ let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf+ testTentativeAndMaybeExit repository''' (verbosity cfg) (testChanges cfg) (sse cfg) (isInteractive True cfg)+ ("you have a bad patch: '" ++ patchDesc newp ++ "'") "amend it"+ (Just failmsg)+ when (O.moves (lookfor cfg) == O.YesLookForMoves || O.replaces (lookfor cfg) == O.YesLookForReplaces)+ $ tentativelyRemoveFromPending repository''' YesUpdateWorking oldp+ finalizeRepositoryChanges repository''' YesUpdateWorking (compress cfg) `clarifyErrors` failmsg+ putStrLn "Finished amending patch:"+ putDocLn $ description newp+ setEnvDarcsPatches (newp :>: NilFL)+++updatePatchHeader :: forall p wX wY wR wU wT . (RepoPatch p, ApplyState p ~ Tree)+ => Bool -- askDeps+ -> S.PatchSelectionOptions+ -> Bool -- keepDate+ -> Bool -- selectAuthor+ -> Maybe String -- author+ -> Maybe String -- patchname+ -> Maybe O.AskLongComment+ -> Repository p wR wU wT+ -> PatchInfoAnd p wT wX+ -> FL (PrimOf p) wX wY+ -> IO (Maybe String, PatchInfoAnd p wT wY)+updatePatchHeader ask_deps pSelOpts nKeepDate nSelectAuthor nAuthor nPatchname nAskLongComment repository oldp chs = do++ let newchs = canonizeFL (S.diffAlgorithm pSelOpts) (effect oldp +>+ chs)++ let old_pdeps = getdeps $ hopefully oldp+ newdeps <- if ask_deps+ then askAboutDepends repository newchs pSelOpts old_pdeps+ else return old_pdeps++ let old_pinf = info oldp+ prior = (piName old_pinf, piLog old_pinf)+ old_author = piAuthor old_pinf+ date <- if nKeepDate then return (piDateString old_pinf) else getDate False+ (new_author,edit_author) <- getAuthor nSelectAuthor nAuthor old_author+ warnIfHijacking old_author edit_author+ (new_name, new_log, mlogf) <- getLog + nPatchname False (O.Logfile Nothing False) nAskLongComment (Just prior) chs+ let maybe_invert = if isInverted old_pinf then invertName else id+ new_pinf <- maybe_invert `fmap` patchinfo date new_name+ new_author new_log++ let newp = n2pia (adddeps (infopatch new_pinf (fromPrims newchs)) newdeps)++ return (mlogf, newp)+++warnIfHijacking :: String -- Original author+ -> Bool -- Author change requested by options+ -> IO ()+warnIfHijacking old_author edit_author = do+ authors_here <- getEasyAuthor+ unless (edit_author || old_author `elem` authors_here) $ do+ yorn <- askUser $+ "You're not " ++ old_author ++"! Amend anyway? "+ case yorn of ('y':_) -> return ()+ _ -> exitSuccess+++hasEditMetadata :: AmendConfig -> Bool+hasEditMetadata cfg = isJust (author cfg)+ || selectAuthor cfg+ || isJust (patchname cfg)+ || askLongComment cfg == Just O.YesEditLongComment+ || askLongComment cfg == Just O.PromptLongComment+ || askDeps cfg++-- hasEditMetadata [] = False+-- hasEditMetadata (Author _:_) = True+-- hasEditMetadata (SelectAuthor:_) = True+-- hasEditMetadata (LogFile _:_) = True -- ??? not listed as an option for amend+-- hasEditMetadata (PatchName _:_) = True+-- hasEditMetadata (EditLongComment:_) = True+-- hasEditMetadata (PromptLongComment:_) = True+-- hasEditMetadata (AskDeps:_) = True+-- hasEditMetadata (_:fs) = hasEditMetadata fs+++getAuthor :: Bool -> Maybe String -> String -> IO (String,Bool)+getAuthor True _ _ = do+ a <- promptAuthor False True+ return (a,True)+getAuthor False (Just a) _ = return (a,True)+getAuthor False Nothing old = return (old,False)++-- getAuthor (SelectAuthor:_) _ = do+-- a <- promptAuthor False True+-- return (a,True)+-- getAuthor (Author a:_) _ = return (a,True)+-- getAuthor (_:as) old = getAuthor as old+-- getAuthor [] old = return (old,False)++patchSelOpts :: AmendConfig -> S.PatchSelectionOptions+patchSelOpts cfg = S.PatchSelectionOptions+ { S.verbosity = verbosity cfg+ , S.matchFlags = matchFlags cfg+ , S.diffAlgorithm = diffAlgorithm cfg+ , S.interactive = isInteractive True cfg+ , S.selectDeps = O.PromptDeps -- option not supported, use default+ , S.summary = O.NoSummary -- option not supported, use default+ , S.withContext = withContext cfg+ }++diffingOpts :: AmendConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)+diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) False (diffAlgorithm cfg)++isInteractive :: Bool -> AmendConfig -> Bool+isInteractive def = maybe def id . interactive
+ src/Darcs/UI/Commands/Annotate.hs view
@@ -0,0 +1,218 @@+-- Copyright (C) 2003 David Roundy, 2010-2011 Petr Rockai+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.+{-# LANGUAGE CPP, OverloadedStrings #-}++module Darcs.UI.Commands.Annotate ( annotate ) where++import Prelude hiding ( (^) )++import Control.Arrow ( first )+import Control.Monad ( unless )++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Flags ( DarcsFlag(NoPatchIndexFlag), isUnified, useCache, fixSubPaths, hasSummary, umask )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise+ , defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Storage.Hashed.Plain( readPlainTree )+import Darcs.Repository.State ( readRecorded )+import Darcs.Repository+ ( withRepository+ , withRepoLockCanFail+ , RepoJob(..)+ , readRepo+ , repoPatchType+ , listRegisteredFiles+ )+import Darcs.Repository.Flags ( UpdateWorking(..) )+import Darcs.Repository.PatchIndex ( attemptCreatePatchIndex )+import Darcs.Patch.Set ( newset2RL )+import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, invertRL )+import qualified Darcs.Patch ( summary )+import Darcs.Patch.Type ( PatchType(..) )+import Darcs.Patch.Dummy ( DummyPatch )+import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate )+import Data.ByteString.Lazy ( toChunks )+import Darcs.UI.PrintPatch ( printPatch, contextualPrintPatch )+import Darcs.Patch.ApplyMonad( withFileNames )+import System.FilePath.Posix ( (</>) )+import Darcs.Patch.Info ( showPatchInfoUI, showPatchInfo )+import Darcs.Patch.Match ( matchPatch, haveNonrangeMatch, getNonrangeMatchS )+import Darcs.Repository.Match ( getFirstMatch, getOnePatchset )+import Darcs.Repository.Lock ( withTempDir )+import Darcs.Repository.PatchIndex ( getRelevantSubsequence, canUsePatchIndex )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal )+import qualified Darcs.Patch.Annotate as A+import Darcs.Util.Printer ( putDocLn, Doc )++import Storage.Hashed.Tree( TreeItem(..), readBlob, list, expand )+import Storage.Hashed.Monad( findM, virtualTreeIO )+import Darcs.Util.Path( floatPath, anchorPath, fp2fn, toFilePath+ , AbsolutePath )+import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )++#include "impossible.h"++annotateDescription :: String+annotateDescription = "Display which patch last modified something."++annotateHelp :: String+annotateHelp = unlines+ [ "The `darcs annotate` command provides two unrelated operations. When"+ , "called on a file, it will find the patch that last modified each line"+ , "in that file. When called on a patch (e.g. using `--patch`), it will"+ , "print the internal representation of that patch."+ , ""+ , "The `--summary` option will result in a summarized patch annotation,"+ , "similar to `darcs whatsnew`. It has no effect on file annotations."+ , ""+ , "By default, output is in a human-readable format. The `--machine-readable`"+ , "option can be used to generate output for machine postprocessing."+ ]++annotateBasicOpts :: DarcsOption a+ (Maybe O.Summary+ -> O.WithContext+ -> Bool+ -> [O.MatchFlag]+ -> Maybe String+ -> a)+annotateBasicOpts = O.summary+ ^ O.withContext+ ^ O.machineReadable+ ^ O.matchOne+ ^ O.workingRepoDir++annotateAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> a)+annotateAdvancedOpts = O.patchIndexYes++annotateOpts :: DarcsOption a+ (Maybe O.Summary+ -> O.WithContext+ -> Bool+ -> [O.MatchFlag]+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.WithPatchIndex+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+annotateOpts = annotateBasicOpts `withStdOpts` annotateAdvancedOpts++annotate :: DarcsCommand [DarcsFlag]+annotate = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "annotate"+ , commandHelp = annotateHelp+ , commandDescription = annotateDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+ , commandCommand = annotateCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = listRegisteredFiles+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc annotateAdvancedOpts+ , commandBasicOptions = odesc annotateBasicOpts+ , commandDefaults = defaultFlags annotateOpts+ , commandCheckOptions = ocheck annotateOpts+ , commandParseOptions = onormalise annotateOpts+}++annotateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+annotateCmd fps opts [""] = annotate' fps opts [] -- when does that happen?+annotateCmd fps opts [] = do+ let matchFlags = parseFlags O.matchOne opts+ unless (haveNonrangeMatch (PatchType :: PatchType DummyPatch) matchFlags) $+ fail $ "Annotate requires either a patch pattern or a " +++ "file or directory argument."+ annotate' fps opts []+annotateCmd fps opts args = annotate' fps opts args++annotate' :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+annotate' _ opts [] = -- annotating a patch (ie, showing its contents)+ withRepository (useCache opts) $ RepoJob $ \repository -> do+ let matchFlags = parseFlags O.matchOne opts+ Sealed2 p <- matchPatch matchFlags `fmap` readRepo repository+ if hasSummary O.NoSummary opts == O.YesSummary+ then do putDocLn $ showpi $ patch2patchinfo p+ putDocLn $ show_summary p+ else if isUnified opts == O.YesContext+ then withTempDir "context" $ \_ ->+ do getFirstMatch repository matchFlags+ c <- readPlainTree "."+ contextualPrintPatch c p+ else printPatch p+ where showpi | parseFlags O.machineReadable opts = showPatchInfo+ | otherwise = showPatchInfoUI+ show_summary :: RepoPatch p => Named p wX wY -> Doc+ show_summary = Darcs.Patch.summary++annotate' fps opts args@[_] = do -- annotating a file or a directory+ unless (NoPatchIndexFlag `elem` opts)+ $ withRepoLockCanFail (useCache opts) YesUpdateWorking (umask opts) $ RepoJob attemptCreatePatchIndex+ withRepository (useCache opts) $ RepoJob $ \repository -> do+ let matchFlags = parseFlags O.matchOne opts+ r <- readRepo repository+ (origpath:_) <- fixSubPaths fps args+ recorded <- readRecorded repository++ (patches, initial, path') <-+ if haveNonrangeMatch (repoPatchType repository) matchFlags+ then do Sealed x <- getOnePatchset repository matchFlags+ let fn = [fp2fn $ toFilePath origpath]+ nonRangeMatch = getNonrangeMatchS matchFlags r+ (_, [path], _) = withFileNames Nothing fn nonRangeMatch+ initial <- snd `fmap` virtualTreeIO (getNonrangeMatchS matchFlags r) recorded+ return (seal $ newset2RL x, initial, toFilePath path)+ else return (seal $ newset2RL r, recorded, toFilePath origpath)+ let path = "./" ++ path'++ found <- findM initial (floatPath $ toFilePath path)+ -- TODO need to decide about the --machine flag+ let fmt = if parseFlags O.machineReadable opts then A.machineFormat else A.format+ case found of+ Nothing -> fail $ "No such file or directory: " ++ toFilePath path+ Just (SubTree s) -> do+ s' <- expand s+ let subs = map (fp2fn . (path </>) . anchorPath "" . fst) $ list s'+ showPath (n, File _) = BC.pack (path </> n)+ showPath (n, _) = BC.concat [BC.pack (path </> n), "/"]+ (Sealed ans_patches) <- do+ upi <- canUsePatchIndex repository+ if not upi+ then return patches+ else getRelevantSubsequence patches repository subs+ putStrLn $ fmt (BC.intercalate "\n" $+ map (showPath . first (anchorPath "")) $ list s') $+ A.annotateDirectory D.MyersDiff (invertRL ans_patches) (fp2fn path) subs+ Just (File b) -> do (Sealed ans_patches) <- do+ upi <- canUsePatchIndex repository+ if not upi+ then return patches+ else getRelevantSubsequence patches repository [fp2fn path]+ con <- BC.concat `fmap` toChunks `fmap` readBlob b+ putStrLn $ fmt con $ A.annotate D.MyersDiff (invertRL ans_patches) (fp2fn path) con+ Just (Stub _ _) -> impossible++annotate' _ _ _ = fail "annotate accepts at most one argument"
+ src/Darcs/UI/Commands/Apply.hs view
@@ -0,0 +1,432 @@+-- Copyright (C) 2003-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, PatternGuards #-}++module Darcs.UI.Commands.Apply+ ( apply, applyCmd+ , getPatchBundle -- used by darcsden+ ) where++import System.Exit ( exitSuccess )+import Prelude hiding ( (^), catch )+import Control.Monad ( when )++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefullyM, info )+import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts+ , putVerbose+ , amInHashedRepository+ )+import Darcs.UI.Flags+ ( DarcsFlag+ , doHappyForwarding, doReverse, verbosity, useCache, dryRun+ , reorder, umask+ , fixUrl, getCc, getSendmailCmd+ , diffAlgorithm, isUnified, getReply+ )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( UpdateWorking(..) )+import Darcs.Util.Path ( toFilePath, AbsolutePath )+import Darcs.Repository+ ( Repository+ , SealedPatchSet+ , withRepoLock+ , readRepo+ , filterOutConflicts+ )+import Darcs.Patch.Set ( Origin, newset2RL )+import Darcs.Patch ( RepoPatch, PrimOf )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI )+import Darcs.Patch.Witnesses.Ordered+ ( RL(..), (:\/:)(..), (:>)(..)+ , mapRL, nullFL, reverseFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Util.ByteString ( linesPS, unlinesPS, gzReadStdin )+import Data.List( (\\) )+import qualified Data.ByteString as B (ByteString, null, init, take, drop)+import qualified Data.ByteString.Char8 as BC (unpack, last, pack)++import Darcs.Util.Download ( Cachable(Uncachable) )+import Darcs.Repository.External ( gzFetchFilePS )+import Darcs.UI.External+ ( sendEmailDoc+ , resendEmail+ , verifyPS+ )+import Darcs.UI.Email ( readEmail )+import Darcs.Patch.Depends ( findUncommon, findCommonWithThem )+import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..), PatchProxy )+import Darcs.UI.SelectChanges+ ( selectChanges+ , WhichChanges(..)+ , runSelection+ , selectionContext+ )+import qualified Darcs.UI.SelectChanges as S+import Darcs.Patch.Bundle ( scanBundle )+import Darcs.Util.Printer+ ( packedString, vcat, text, empty+ , renderString, RenderMode(..)+ )+import Storage.Hashed.Tree( Tree )++#include "impossible.h"+++applyDescription :: String+applyDescription = "Apply a patch bundle created by `darcs send'."++applyHelp :: String+applyHelp = unlines+ [ "The `darcs apply` command takes a patch bundle and attempts to insert"+ , "it into the current repository. In addition to invoking it directly"+ , "on bundles created by `darcs send`, it is used internally by `darcs"+ , "push` and `darcs put` on the remote end of an SSH connection."+ , ""+ , "If no file is supplied, the bundle is read from standard input."+ , ""+ , "If given an email instead of a patch bundle, Darcs will look for the"+ , "bundle as a MIME attachment to that email. Currently this will fail"+ , "if the MIME boundary is rewritten, such as in Courier and Mail.app."+ , ""+ , "If the `--reply noreply@example.net` option is used, and the bundle is"+ , "attached to an email, Darcs will send a report (indicating success or"+ , "failure) to the sender of the bundle (the `To` field). The argument to"+ , "noreply is the address the report will appear to originate FROM."+ , ""+ , "The `--cc` option will cause the report to be CC'd to another address,"+ , "for example `--cc reports@lists.example.net,admin@lists.example.net`."+ , "Using `--cc` without `--reply` is undefined."+ , ""+ , "If you want to use a command different from the default one for sending mail,"+ , "you need to specify a command line with the `--sendmail-command` option."+ , "The command line can contain the format specifier `%t` for to"+ , "and you can add `%<` to the end of the command line if the command"+ , "expects the complete mail on standard input. For example, the command line"+ , "for msmtp looks like this:"+ , ""+ , " msmtp -t %<"+ , ""+ , "If gpg(1) is installed, you can use `--verify pubring.gpg` to reject"+ , "bundles that aren't signed by a key in `pubring.gpg`."+ , ""+ , "If `--test` is supplied and a test is defined (see `darcs setpref`), the"+ , "bundle will be rejected if the test fails after applying it. In that"+ , "case, the rejection email from `--reply` will include the test output."+ ]++stdindefault :: a -> [String] -> IO [String]+stdindefault _ [] = return ["-"]+stdindefault _ x = return x++conflictsOpt :: DarcsOption a (Maybe O.AllowConflicts -> a)+conflictsOpt = O.conflicts O.NoAllowConflicts++applyBasicOpts :: DarcsOption a+ (O.Verify+ -> O.Reorder+ -> Maybe Bool+ -> O.DryRun+ -> O.XmlOutput+ -> [O.MatchFlag]+ -> Maybe O.AllowConflicts+ -> O.ExternalMerge+ -> O.RunTest+ -> O.LeaveTestDir+ -> Maybe String+ -> O.DiffAlgorithm+ -> a)+applyBasicOpts+ = O.verify+ ^ O.reorder+ ^ O.interactive+ ^ O.dryRunXml+ ^ O.matchSeveral+ ^ conflictsOpt+ ^ O.useExternalMerge+ ^ O.test+ ^ O.leaveTestDir+ ^ O.workingRepoDir+ ^ O.diffAlgorithm++applyAdvancedOpts :: DarcsOption a+ (Maybe String+ -> Maybe String+ -> Bool+ -> (Bool, Maybe String)+ -> O.UseIndex+ -> O.Compression+ -> O.SetScriptsExecutable+ -> O.UMask+ -> Bool+ -> Bool+ -> O.WantGuiPause+ -> a)+applyAdvancedOpts+ = O.reply+ ^ O.ccApply+ ^ O.happyForwarding+ ^ O.sendmail+ ^ O.useIndex+ ^ O.compress+ ^ O.setScriptsExecutable+ ^ O.umask+ ^ O.restrictPaths+ ^ O.changesReverse+ ^ O.pauseForGui++applyOpts :: DarcsOption a+ (O.Verify+ -> O.Reorder+ -> Maybe Bool+ -> O.DryRun+ -> O.XmlOutput+ -> [O.MatchFlag]+ -> Maybe O.AllowConflicts+ -> O.ExternalMerge+ -> O.RunTest+ -> O.LeaveTestDir+ -> Maybe String+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> Maybe String+ -> Maybe String+ -> Bool+ -> (Bool, Maybe String)+ -> O.UseIndex+ -> O.Compression+ -> O.SetScriptsExecutable+ -> O.UMask+ -> Bool+ -> Bool+ -> O.WantGuiPause+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts++apply :: DarcsCommand [DarcsFlag]+apply = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "apply"+ , commandHelp = applyHelp ++ "\n" ++ applyHelp'+ , commandDescription = applyDescription+ , commandExtraArgs = 1+ , commandExtraArgHelp = ["<PATCHFILE>"]+ , commandCommand = applyCmd StandardPatchApplier+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = const stdindefault+ , commandAdvancedOptions = odesc applyAdvancedOpts+ , commandBasicOptions = odesc applyBasicOpts+ , commandDefaults = defaultFlags applyOpts+ , commandCheckOptions = ocheck applyOpts+ , commandParseOptions = onormalise applyOpts+ }++applyCmd :: PatchApplier pa => pa -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+applyCmd _ _ _ [""] = fail "Empty filename argument given to apply!"+applyCmd patchApplier _ opts ["-"] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ repoJob patchApplier opts $ \patchProxy repository -> do+ -- for darcs users who try out 'darcs apply' without any arguments+ putVerbose opts $ text "reading patch bundle from stdin..."+ bundle <- gzReadStdin+ applyCmdCommon patchApplier patchProxy opts bundle repository++applyCmd patchApplier (_,o) opts [unfixed_patchesfile] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ repoJob patchApplier opts $ \patchProxy repository -> do+ patchesfile <- fixUrl o unfixed_patchesfile+ bundle <- gzFetchFilePS (toFilePath patchesfile) Uncachable+ applyCmdCommon patchApplier patchProxy opts bundle repository++applyCmd _ _ _ _ = impossible++applyCmdCommon+ :: forall pa p wR wU+ . ( PatchApplier pa, RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree+ , RepoPatch (CarrierType pa p), ApplyState (CarrierType pa p) ~ Tree + )+ => pa+ -> PatchProxy p+ -> [DarcsFlag]+ -> B.ByteString+ -> Repository (CarrierType pa p) wR wU wR+ -> IO ()+applyCmdCommon patchApplier patchProxy opts bundle repository = do+ let from_whom = getFrom bundle+ us <- readRepo repository+ either_them <- getPatchBundle opts bundle+ Sealed them+ <- case either_them of+ Right t -> return t+ Left er -> do forwarded <- considerForwarding opts bundle+ if forwarded+ then exitSuccess+ else fail er+ common :> _ <- return $ findCommonWithThem us them++ -- all patches that are in "them" and not in "common" need to be available; check that+ let common_i = mapRL info $ newset2RL common+ them_i = mapRL info $ newset2RL them+ required = them_i \\ common_i -- FIXME quadratic?+ check :: RL (PatchInfoAnd (CarrierType pa p)) wX wY -> [PatchInfo] -> IO ()+ check (p :<: ps') bad = case hopefullyM p of+ Nothing | info p `elem` required -> check ps' (info p : bad)+ _ -> check ps' bad+ check NilRL [] = return ()+ check NilRL bad = fail . renderString Encode $ vcat $ map showPatchInfoUI bad +++ [ text "\nFATAL: Cannot apply this bundle. We are missing the above patches." ]++ check (newset2RL them) []++ (us':\/:them') <- return $ findUncommon us them+ (hadConflicts, Sealed their_ps)+ <- if parseFlags conflictsOpt opts == Nothing -- skip conflicts+ then filterOutConflicts (reverseFL us') repository them'+ else return (False, Sealed them')+ when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."+ when (nullFL their_ps) $+ do if hadConflicts+ then putStrLn ("All new patches of the bundle cause conflicts. " +++ "Nothing to do.") >> exitSuccess+ else putStrLn ("All these patches have already been applied. " +++ "Nothing to do.") >> when (reorder opts /= O.Reorder) exitSuccess+ + let direction = if doReverse opts then FirstReversed else First+ context = selectionContext direction "apply" (patchSelOpts opts) Nothing Nothing+ (to_be_applied :> _) <- runSelection (selectChanges their_ps) context+ applyPatches patchApplier patchProxy "apply" opts from_whom repository us' to_be_applied+-- see the default (False) for the option+-- where fixed_opts = if Interactive `elem` opts+-- then opts+-- else All : opts++getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString+ -> IO (Either String (SealedPatchSet p Origin))+getPatchBundle opts fps = do+ let opt_verify = parseFlags O.verify opts+ mps <- verifyPS opt_verify $ readEmail fps+ mops <- verifyPS opt_verify fps+ case (mps, mops) of+ (Nothing, Nothing) ->+ return $ Left "Patch bundle not properly signed, or gpg failed."+ (Just bundle, Nothing) -> return $ scanBundle bundle+ (Nothing, Just bundle) -> return $ scanBundle bundle+ -- We use careful_scan_bundle only below because in either of the two+ -- above case we know the patch was signed, so it really shouldn't+ -- need stripping of CRs.+ (Just ps1, Just ps2) -> case careful_scan_bundle ps1 of+ Left _ -> return $ careful_scan_bundle ps2+ Right x -> return $ Right x+ where careful_scan_bundle bundle =+ case scanBundle bundle of+ Left e -> case scanBundle $ stripCrPS bundle of+ Right x -> Right x+ _ -> Left e+ x -> x+ stripCrPS :: B.ByteString -> B.ByteString+ stripCrPS bundle = unlinesPS $ map stripline $ linesPS bundle+ stripline p | B.null p = p+ | BC.last p == '\r' = B.init p+ | otherwise = p++applyHelp' :: String+applyHelp' =+ "A patch bundle may introduce unresolved conflicts with existing\n" +++ "patches or with the working tree. By default, Darcs will add conflict\n" +++ "markers (see `darcs mark-conflicts`).\n" +++ "\n" +++ "The `--external-merge` option lets you resolve these conflicts\n" +++ "using an external merge tool. In the option, `%a` is replaced with\n" +++ "the common ancestor (merge base), `%1` with the first version, `%2`\n" +++ "with the second version, and `%o` with the path where your resolved\n" +++ "content should go. For example, to use the xxdiff visual merge tool\n" +++ "you'd specify: `--external-merge='xxdiff -m -O -M %o %1 %a %2'`\n" +++ "\n" +++ "The `--allow-conflicts` option will skip conflict marking; this is\n" +++ "useful when you want to treat a repository as just a bunch of patches,\n" +++ "such as using `darcs pull --union` to download of your co-workers\n" +++ "patches before going offline.\n" +++ "\n" +++ "This can mess up unrecorded changes in the working tree, forcing you\n" +++ "to resolve the conflict immediately. To simply reject bundles that\n" +++ "introduce unresolved conflicts, using the `--dont-allow-conflicts`\n" +++ "option. Making this the default in push-based workflows is strongly\n" +++ "recommended.\n" +++ "\n" +++ "Unlike most Darcs commands, `darcs apply` defaults to `--all`. Use the\n" +++ "`--interactive` option to pick which patches to apply from a bundle.\n"++getFrom :: B.ByteString -> String+getFrom bundle = readFrom $ linesPS bundle+ where readFrom [] = ""+ readFrom (x:xs)+ | B.take 5 x == fromStart = BC.unpack $ B.drop 5 x+ | otherwise = readFrom xs++forwardingMessage :: B.ByteString+forwardingMessage = BC.pack $+ "The following patch was either unsigned, or signed by a non-allowed\n"+++ "key, or there was a GPG failure.\n"++considerForwarding :: [DarcsFlag] -> B.ByteString -> IO Bool+considerForwarding opts bundle = case getReply opts of+ Nothing -> return False+ Just from -> case break is_from (linesPS bundle) of+ (m1, f:m2) ->+ let m_lines = forwardingMessage:m1 ++ m2+ m' = unlinesPS m_lines+ f' = BC.unpack (B.drop 5 f) in+ if from == f' || from == init f'+ then return False -- Refuse possible email loop.+ else do+ scmd <- getSendmailCmd opts+ if doHappyForwarding opts+ then resendEmail from scmd bundle+ else sendEmailDoc f' from "A forwarded darcs patch" cc+ scmd (Just (empty,empty))+ (packedString m')+ return True+ _ -> return False -- Don't forward emails lacking headers!+ where+ cc = getCc opts+ is_from l = B.take 5 l == fromStart++fromStart :: B.ByteString+fromStart = BC.pack "From:"++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = parseFlags O.matchSeveral flags+ , S.diffAlgorithm = diffAlgorithm flags+ , S.interactive = maybeIsInteractive flags+ , S.selectDeps = O.PromptDeps -- option not supported, use default+ , S.summary = O.NoSummary -- option not supported, use default+ , S.withContext = isUnified flags+ }++maybeIsInteractive :: [DarcsFlag] -> Bool+maybeIsInteractive = maybe False id . parseFlags O.interactive
+ src/Darcs/UI/Commands/Clone.hs view
@@ -0,0 +1,347 @@+-- Copyright (C) 2002-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.UI.Commands.Clone+ ( get+ , put+ , clone+ , makeRepoName+ , cloneToSSH+ ) where++import Prelude hiding ( (^), catch )++import System.Directory ( doesDirectoryExist, doesFileExist+ , setCurrentDirectory )+import System.Exit ( ExitCode(..) )+import Control.Exception ( catch, SomeException )+import Control.Monad ( when, unless )+import Data.Maybe ( listToMaybe )++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts+ , nodefaults+ , commandStub+ , commandAlias+ , putInfo+ )+import Darcs.UI.Flags( DarcsFlag( NewRepo+ , UpToPattern+ , UpToPatch+ , OnePattern+ , OnePatch+ )+ , toMatchFlags, useCache, umask, remoteRepos+ , setDefault , DarcsFlag(Quiet), usePacks+ , remoteDarcs, cloneKind, verbosity, setScriptsExecutable+ , withWorkingDir, runPatchIndex )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands.Util ( getUniqueRepositoryName )+import Darcs.Repository ( cloneRepository )+import Darcs.Repository.Format ( identifyRepoFormat+ , RepoProperty ( HashedInventory+ , RebaseInProgress+ )+ , formatHas+ )+import Darcs.Repository.Lock ( withTempDir )+import Darcs.Repository.Ssh ( getSSH, SSHCmd(SCP) )+import Darcs.Repository.Flags+ ( CloneKind(CompleteClone), SetDefault(NoSetDefault), ForgetParent(..) )+import Darcs.Patch.Bundle ( scanContextFile )+import Darcs.Patch.Dummy ( DummyPatch )+import Darcs.Patch.Set ( PatchSet, Origin )+import Darcs.Repository.Motd ( showMotd )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Printer ( text, ($$) )+import Darcs.Util.Path ( toFilePath, toPath, ioAbsoluteOrRemote, AbsolutePath )+import Darcs.Util.Workaround ( getCurrentDirectory )+import Darcs.Util.URL ( isSshUrl )+import Darcs.Util.Exec ( exec, Redirect(..), )++cloneDescription :: String+cloneDescription = "Make a copy of an existing repository."++cloneHelp :: String+cloneHelp =+ unlines+ [ "Clone creates a copy of a repository. The optional second"+ , "argument specifies a destination directory for the new copy;"+ , "if omitted, it is inferred from the source location."+ , ""+ , "By default Darcs will copy every patch from the original repository."+ , "This means the copy is completely independent of the original; you can"+ , "operate on the new repository even when the original is inaccessible."+ , "If you expect the original repository to remain accessible, you can"+ , "use `--lazy` to avoid copying patches until they are needed (`copy on"+ , "demand'). This is particularly useful when copying a remote"+ , "repository with a long history that you don't care about."+ , ""+ , "When cloning locally, Darcs automatically uses hard linking where"+ , "possible. As well as saving time and space, this enables to move or"+ , "delete the original repository without affecting the copy."+ , "Hard linking requires that the copy be on the same filesystem as the"+ , "original repository, and that the filesystem support hard linking."+ , "This includes NTFS, HFS+ and all general-purpose Unix filesystems"+ , "(such as ext, UFS and ZFS). FAT does not support hard links."+ , ""+ , "When cloning from a remote location, Darcs will look for and attempt"+ , "to use packs created by `darcs optimize http` in the remote repository."+ , "Packs are single big files that can be downloaded instead of many"+ , "little files, which makes cloning faster over HTTP."+ , ""+ , "Darcs clone will not copy unrecorded changes to the source repository's"+ , "working tree."+ , ""+ , "You can copy a repository to a ssh url, in which case the new repository"+ , "will always be complete."+ , ""+ ] ++ cloneHelpTag+ ++ cloneHelpSSE++cloneBasicOpts :: DarcsOption a+ (Maybe String+ -> CloneKind+ -> [O.MatchFlag]+ -> Maybe Bool+ -> O.SetScriptsExecutable+ -> O.WithWorkingDir+ -> a)+cloneBasicOpts = O.reponame+ ^ O.partial+ ^ O.matchOneContext+ ^ O.setDefault+ ^ O.setScriptsExecutable+ ^ O.useWorkingDir++cloneAdvancedOpts :: DarcsOption a (Bool -> O.WithPatchIndex -> O.NetworkOptions -> a)+cloneAdvancedOpts = O.usePacks ^ O.patchIndex ^ O.network++cloneOpts :: DarcsOption a+ (Maybe String+ -> CloneKind+ -> [O.MatchFlag]+ -> Maybe Bool+ -> O.SetScriptsExecutable+ -> O.WithWorkingDir+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> Bool+ -> O.WithPatchIndex+ -> O.NetworkOptions+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+cloneOpts = cloneBasicOpts `withStdOpts` cloneAdvancedOpts++clone :: DarcsCommand [DarcsFlag]+clone = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "clone"+ , commandHelp = cloneHelp+ , commandDescription = cloneDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["<REPOSITORY>", "[<DIRECTORY>]"]+ , commandCommand = cloneCmd+ , commandPrereq = validContextFile+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc cloneAdvancedOpts+ , commandBasicOptions = odesc cloneBasicOpts+ , commandDefaults = defaultFlags cloneOpts+ , commandCheckOptions = ocheck cloneOpts+ , commandParseOptions = onormalise cloneOpts+ }++get :: DarcsCommand [DarcsFlag]+get = commandAlias "get" Nothing clone++putDescription :: String+putDescription = "Deprecated command, replaced by clone."++putHelp :: String+putHelp = unlines+ [ "This command is deprecated."+ , ""+ , "To clone the current repository to a ssh destination,"+ , "use the syntax `darcs clone . user@server:path` ."+ ]++put :: DarcsCommand [DarcsFlag]+put = commandStub "put" putHelp putDescription clone++cloneCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+cloneCmd fps opts [inrepodir, outname] = cloneCmd fps (NewRepo outname:opts) [inrepodir]+cloneCmd _ opts [inrepodir] = do+ debugMessage "Starting work on clone..."+ typed_repodir <- ioAbsoluteOrRemote inrepodir+ let repodir = toPath typed_repodir+ unless (Quiet `elem` opts) $ showMotd repodir+ rfsource <- identifyRepoFormat repodir+ debugMessage $ "Found the format of "++repodir++"..."++ -- there's no fundamental reason for banning gets of repositories with+ -- rebase in progress, but it seems a bit dubious to actually copy the+ -- rebase state, and removing it is a bit of work since the current+ -- implementation just copies the inventory file+ when (formatHas RebaseInProgress rfsource) $+ fail "Can't clone a repository with a rebase in progress"++ unless (formatHas HashedInventory rfsource) $ putInfo opts $+ text "***********************************************************************"+ $$ text " _______ Sorry for the wait! The repository you are cloning is"+ $$ text " | | using the DEPRECATED 'old-fashioned' format. I'm doing a"+ $$ text " | O O | hashed copy instead, but this may take a while."+ $$ text " | ___ |"+ $$ text " | / \\ | We recommend that the maintainer upgrade the remote copy"+ $$ text " |_______| as well. See http://wiki.darcs.net/OF for more information."+ $$ text ""+ $$ text "***********************************************************************"++ case cloneToSSH opts of+ Just repo -> do+ withTempDir "clone" $ \_ -> do+ putInfo opts $ text "Creating local clone..."+ currentDir <- getCurrentDirectory+ cloneRepository repodir "local" (verbosity opts) (useCache opts)+ CompleteClone (umask opts) (remoteDarcs opts)+ (setScriptsExecutable opts)+ (remoteRepos opts) (NoSetDefault True)+ (toMatchFlags $ map convertUpToToOne opts)+ rfsource+ (withWorkingDir opts)+ (runPatchIndex opts)+ (usePacks opts)+ (not $ null [p | UpToPattern p <- opts] ) -- --to-match given+ YesForgetParent+ setCurrentDirectory currentDir+ (scp, args) <- getSSH SCP+ putInfo opts $ text "Transferring clone by SCP..."+ r <- exec scp (args ++ ["-r", "local", repo]) (AsIs,AsIs,AsIs)+ when (r /= ExitSuccess) $ fail $ "Problem during SCP transfer."+ putInfo opts $ text "Cloning and transferring successful."+ Nothing -> do+ mysimplename <- makeRepoName True opts repodir+ cloneRepository repodir mysimplename (verbosity opts) (useCache opts)+ (cloneKind opts) (umask opts) (remoteDarcs opts)+ (setScriptsExecutable opts)+ (remoteRepos opts) (setDefault True opts)+ (toMatchFlags $ map convertUpToToOne opts)+ rfsource+ (withWorkingDir opts)+ (runPatchIndex opts)+ (usePacks opts)+ (not $ null [p | UpToPattern p <- opts] ) -- --to-match given+ NoForgetParent+ putInfo opts $ text "Finished cloning."++cloneCmd _ _ _ = fail "You must provide 'clone' with either one or two arguments."++cloneToSSH :: [DarcsFlag] -> Maybe String+cloneToSSH fs = case parseFlags O.reponame fs of+ Nothing -> Nothing+ Just r -> if isSshUrl r then Just r else Nothing++makeRepoName :: Bool -> [DarcsFlag] -> FilePath -> IO String+makeRepoName talkative dfs d =+ case [ n | NewRepo n <- dfs] of+ (n:_) ->+ do exists <- doesDirectoryExist n+ file_exists <- doesFileExist n+ if exists || file_exists+ then fail $ "Directory or file named '" ++ n ++ "' already exists."+ else return n+ [] ->+ case dropWhile (=='.') $ reverse $+ takeWhile (\c -> c /= '/' && c /= ':') $+ dropWhile (=='/') $ reverse d of+ "" -> getUniqueRepositoryName talkative "anonymous_repo"+ base@('/':_) -> getUniqueRepositoryName talkative base -- Absolute+ base -> do -- Relative+ cwd <- getCurrentDirectory+ getUniqueRepositoryName talkative (cwd ++ "/" ++ base)++cloneHelpTag :: String+cloneHelpTag =+ unlines+ [ "It is often desirable to make a copy of a repository that excludes"+ , "some patches. For example, if releases are tagged then `darcs clone"+ , "--tag .` would make a copy of the repository as at the latest release."+ , ""+ , "An untagged repository state can still be identified unambiguously by"+ , "a context file, as generated by `darcs changes --context`. Given the"+ , "name of such a file, the `--context` option will create a repository"+ , "that includes only the patches from that context. When a user reports"+ , "a bug in an unreleased version of your project, the recommended way to"+ , "find out exactly what version they were running is to have them" + , "include a context file in the bug report."+ , ""+ , "You can also make a copy of an untagged state using the `--to-patch` or"+ , "`--to-match` options, which exclude patches *after* the first matching"+ , "patch. Because these options treat the set of patches as an ordered"+ , "sequence, you may get different results after reordering with `darcs"+ , "optimize`, so tagging is preferred."+ , ""+ ]++cloneHelpSSE :: String+cloneHelpSSE =+ unlines+ [ "The `--set-scripts-executable` option causes scripts to be made"+ , "executable in the working tree. A script is any file that starts"+ , "with a shebang (\"#!\")."+ ]++validContextFile :: [DarcsFlag] -> IO (Either String ())+validContextFile opts =+ case getContext opts of+ Nothing -> return $ Right ()+ Just ctxAbsolutePath -> do+ let ctxFilePath = toFilePath ctxAbsolutePath+ exists <- doesFileExist ctxFilePath+ if exists+ then do+ (ps :: PatchSet DummyPatch Origin wX) <-+ scanContextFile ctxFilePath+ (ps `seq` return $ Right ()) `catch` \(_ :: SomeException) ->+ return . Left $ "File " ++ ctxFilePath+ ++ " is not a valid context file"+ else return . Left $+ "Context file " ++ ctxFilePath ++ " does not exist"++-- | 'getContext' takes a list of flags and returns the context+-- specified by @Context c@ in that list of flags, if any.+-- This flag is present if darcs was invoked with @--context=FILE@+getContext :: [DarcsFlag] -> Maybe AbsolutePath+getContext fs = listToMaybe [ f | O.Context f <- toMatchFlags fs ]++-- The 'clone' command takes --to-patch and --to-match as arguments,+-- but internally wants to handle them as if they were --patch and --match+-- TODO: remove this when we get rid of directly looking at [DarcsFlag]+-- for this command.+convertUpToToOne :: DarcsFlag -> DarcsFlag+convertUpToToOne (UpToPattern p) = OnePattern p+convertUpToToOne (UpToPatch p) = OnePatch p+convertUpToToOne f = f
+ src/Darcs/UI/Commands/Convert.hs view
@@ -0,0 +1,971 @@+-- Copyright (C) 2002-2014 David Roundy, Petr Rockai, Owen Stephens+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, MagicHash, OverloadedStrings, DeriveDataTypeable #-}++module Darcs.UI.Commands.Convert ( convert ) where++import Prelude hiding ( (^), readFile, log, lex )++import System.FilePath.Posix ( (</>) )+import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,+ createDirectory, removeFile )+import System.IO ( stdin )+import Data.IORef ( newIORef, modifyIORef, readIORef )+import Data.Char ( isSpace )+import Control.Monad ( when, unless, void, forM_ )+import Control.Monad.Trans ( liftIO )+import Control.Monad.State.Strict ( gets, modify )+import Control.Exception ( finally )+import Control.Applicative ( (<|>) )++import GHC.Base ( unsafeCoerce# )+import System.Time ( toClockTime )+import Data.Maybe ( catMaybes, fromMaybe )+import qualified Data.IntMap as M++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.ByteString.Lazy.UTF8 as BLU++import qualified Data.Attoparsec.ByteString.Char8 as A+import Data.Attoparsec.ByteString.Char8( (<?>) )++import qualified Storage.Hashed.Tree as T+import qualified Storage.Hashed.Monad as TM+import Storage.Hashed.Monad hiding ( createDirectory, exists, rename )+import Storage.Hashed.Darcs ( hashedTreeIO, darcsAddMissingHashes )+import Storage.Hashed.Tree( Tree, treeHash, readBlob, TreeItem(..)+ , emptyTree, listImmediate, findTree )+import Storage.Hashed.AnchoredPath( anchorPath, appendPath, floatPath+ , AnchoredPath(..), Name(..) )+import Storage.Hashed.Hash( encodeBase16, sha256, Hash(..) )++import Darcs.Util.DateTime ( formatDateTime, fromClockTime, parseDateTime, startOfTime )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Path ( ioAbsoluteOrRemote, toPath, AbsolutePath )+import Darcs.Util.Exception ( clarifyErrors )+import Darcs.Util.Prompt ( askUser )+import Darcs.Util.Printer ( text, ($$) )+import Darcs.Util.Printer.Color ( traceDoc )+import Darcs.Util.Workaround ( getCurrentDirectory )++import Darcs.Patch.Depends ( getUncovered )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, info, hopefully )+import Darcs.Patch ( Named, showPatch, patch2patchinfo, fromPrim, fromPrims,+ infopatch, adddeps, getdeps, effect, patchcontents,+ RepoPatch, apply, listTouchedFiles )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Effect ( Effect )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=/\=) )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), RL(..), bunchFL, mapFL, mapFL_FL,+ concatFL, mapRL, nullFL, (+>+) )+import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), Sealed(..), unFreeLeft+ , flipSeal, unsafeUnsealFlipped )+import Darcs.Patch.Info ( piRename, piTag, isTag, PatchInfo, patchinfo,+ piName, piLog, piDate, piAuthor, makePatchname )+import Darcs.Patch.V1 ( Patch )+import Darcs.Patch.V2 ( RealPatch )+import Darcs.Patch.V1.Commute ( publicUnravel )+import Darcs.Patch.V1.Core ( Patch(PP), isMerger )+import Darcs.Patch.V2.Real ( mergeUnravelled )+import Darcs.Patch.Prim ( sortCoalesceFL )+import Darcs.Patch.Prim.V1 ( Prim )+import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2RL, newset2FL )+import Darcs.Patch.Progress ( progressFL )++import Darcs.Repository.Flags ( UpdateWorking(..), Reorder (..), UseIndex(..), ScanKnown(..)+ , AllowConflicts(..), ExternalMerge(..), WantGuiPause(..)+ , Compression(..), DryRun(NoDryRun), DiffAlgorithm(MyersDiff, PatienceDiff) )+import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), withRepositoryDirectory,+ createRepository, invalidateIndex,+ tentativelyMergePatches, patchSetToPatches,+ createPristineDirectoryTree,+ revertRepositoryChanges, finalizeRepositoryChanges,+ applyToWorking+ , readRepo, readTentativeRepo, cleanRepository )+import qualified Darcs.Repository as R( setScriptsExecutable )+import Darcs.Repository.State( readRecorded )+import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) )+import Darcs.Repository.InternalTypes ( extractCache )+import Darcs.Repository.HashedRepo ( readHashedPristineRoot, addToTentativeInventory )+import Darcs.Repository.HashedIO ( cleanHashdir )+import Darcs.Repository.Prefs( FileType(..) )+import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2))+import Darcs.Repository.Motd ( showMotd )+import Darcs.Repository.Lock ( writeBinFile )+import Darcs.Repository.External ( fetchFilePS, Cachable(Uncachable) )+import Darcs.Repository.Diff( treeDiff )+++import Darcs.UI.External ( catchall )+import Darcs.UI.Flags+ ( verbosity, useCache, umask, withWorkingDir, runPatchIndex+ , DarcsFlag ( NewRepo )+ , getRepourl, patchFormat+ )+import Darcs.UI.Commands ( DarcsCommand(..), amInRepository, nodefaults, putInfo+ , normalCommand, withStdOpts )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O++#include "impossible.h"++convertDescription :: String+convertDescription = "Convert repositories between various formats."++convertHelp :: String+convertHelp = unlines+ [ "This command converts a repository that uses the old patch semantics"+ , "`darcs-1` to a new repository with current `darcs-2` semantics."+ , ""+ , convertHelp'+ ]++-- | This part of the help is split out because it is used twice: in+-- the help string, and in the prompt for confirmation.+convertHelp' :: String+convertHelp' = unlines+ [ "WARNING: the repository produced by this command is not understood by"+ , "Darcs 1.x, and patches cannot be exchanged between repositories in"+ , "darcs-1 and darcs-2 formats."+ , ""+ , "Furthermore, repositories created by different invocations of"+ , "this command SHOULD NOT exchange patches."+ ]++convertExportHelp :: String+convertExportHelp = unlines+ [ "This command enables you to export darcs repositories into git."+ , ""+ , "For a one-time export you can use the recipe:"+ , ""+ , " $ cd repo"+ , " $ git init ../mirror"+ , " $ darcs convert export | (cd ../mirror && git fast-import)"+ , ""+ , "For incremental export using marksfiles:"+ , ""+ , " $ cd repo"+ , " $ git init ../mirror"+ , " $ touch ../mirror/git.marks"+ , " $ darcs convert export --read-marks darcs.marks --write-marks darcs.marks"+ , " | (cd ../mirror && git fast-import --import-marks=git.marks --export-marks=git.marks)"+ , ""+ , "In the case of incremental export, be careful to never amend, delete or"+ , "reorder patches in the source darcs repository."+ , ""+ , "Also, be aware that exporting a darcs repo to git will not be exactly"+ , "faithful in terms of history if the darcs repository contains conflicts."+ , ""+ , "Limitations:"+ , ""+ , "* Empty directories are not supported by the fast-export protocol."+ , "* Unicode filenames are currently not correctly handled."+ , " See http://bugs.darcs.net/issue2359 ."+ ]++convertImportHelp :: String+convertImportHelp = unlines+ [ "This command imports git repositories into new darcs repositories."+ , "Further options are accepted (see `darcs help init`)."+ , ""+ , "To convert a git repo to a new darcs one you may run:"+ , " $ (cd gitrepo && git fast-export --all) | darcs convert import darcsmirror"+ , ""+ , "WARNING: git repositories with branches will produce weird results,"+ , " use at your own risks."+ , ""+ , "Incremental import with marksfiles is currently not supported."+ ]++convert :: DarcsCommand [DarcsFlag]+convert = SuperCommand {+ commandProgramName = "darcs"+ , commandName = "convert"+ , commandHelp = ""+ , commandDescription = convertDescription+ , commandPrereq = amInRepository+ , commandSubCommands = [ normalCommand convertDarcs2,+ normalCommand convertExport,+ normalCommand convertImport+ ]+ }++convertDarcs2BasicOpts :: DarcsOption a (Maybe String -> O.SetScriptsExecutable -> O.WithWorkingDir -> a)+convertDarcs2BasicOpts = O.reponame ^ O.setScriptsExecutable ^ O.useWorkingDir++convertDarcs2AdvancedOpts :: DarcsOption a (O.NetworkOptions -> O.WithPatchIndex -> a)+convertDarcs2AdvancedOpts = O.network ^ O.patchIndex++convertDarcs2Opts :: DarcsOption a+ (Maybe String+ -> O.SetScriptsExecutable+ -> O.WithWorkingDir+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.NetworkOptions+ -> O.WithPatchIndex+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+convertDarcs2Opts = convertDarcs2BasicOpts `withStdOpts` convertDarcs2AdvancedOpts++convertDarcs2SilentOpts :: DarcsOption a (O.PatchFormat -> a)+convertDarcs2SilentOpts = O.patchFormat++convertDarcs2 :: DarcsCommand [DarcsFlag]+convertDarcs2 = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "darcs-2"+ , commandHelp = convertHelp+ , commandDescription = "Convert darcs-1 repository to the darcs-2 patch format"+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["<SOURCE>", "[<DESTINATION>]"]+ , commandCommand = toDarcs2+ , commandPrereq = \_ -> return $ Right ()+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc convertDarcs2AdvancedOpts+ , commandBasicOptions = odesc convertDarcs2BasicOpts+ , commandDefaults = defaultFlags (convertDarcs2Opts ^ convertDarcs2SilentOpts)+ , commandCheckOptions = ocheck convertDarcs2Opts+ , commandParseOptions = onormalise convertDarcs2Opts+ }++convertExportBasicOpts :: DarcsOption a+ (Maybe String -> Maybe String -> Maybe String -> a)+convertExportBasicOpts = O.reponame ^ O.marks++convertExportAdvancedOpts :: DarcsOption a (O.NetworkOptions -> a)+convertExportAdvancedOpts = O.network++convertExportOpts :: DarcsOption a+ (Maybe String+ -> Maybe String+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.NetworkOptions+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+convertExportOpts = convertExportBasicOpts `withStdOpts` convertExportAdvancedOpts++convertExport :: DarcsCommand [DarcsFlag]+convertExport = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "export"+ , commandHelp = convertExportHelp+ , commandDescription = "Export a darcs repository to a git-fast-import stream"+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = fastExport+ , commandPrereq = amInRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc convertExportAdvancedOpts+ , commandBasicOptions = odesc convertExportBasicOpts+ , commandDefaults = defaultFlags convertExportOpts+ , commandCheckOptions = ocheck convertExportOpts+ , commandParseOptions = onormalise convertExportOpts+ }++convertImportBasicOpts :: DarcsOption a+ (Maybe String+ -> O.SetScriptsExecutable+ -> O.PatchFormat+ -> O.WithWorkingDir+ -> a)+convertImportBasicOpts+ = O.reponame+ ^ O.setScriptsExecutable+ ^ O.patchFormat+ ^ O.useWorkingDir++convertImportAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> a)+convertImportAdvancedOpts = O.patchIndex++convertImportOpts :: DarcsOption a+ (Maybe String+ -> O.SetScriptsExecutable+ -> O.PatchFormat+ -> O.WithWorkingDir+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.WithPatchIndex+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+convertImportOpts = convertImportBasicOpts `withStdOpts` convertImportAdvancedOpts++convertImport :: DarcsCommand [DarcsFlag]+convertImport = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "import"+ , commandHelp = convertImportHelp+ , commandDescription = "Import from a git-fast-export stream into darcs"+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[<DIRECTORY>]"]+ , commandCommand = fastImport+ , commandPrereq = \_ -> return $ Right ()+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc convertImportAdvancedOpts+ , commandBasicOptions = odesc convertImportBasicOpts+ , commandDefaults = defaultFlags convertImportOpts+ , commandCheckOptions = ocheck convertImportOpts+ , commandParseOptions = onormalise convertImportOpts+ }++toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+toDarcs2 fps opts [inrepodir, outname] = toDarcs2 fps (NewRepo outname:opts) [inrepodir]+toDarcs2 _ opts [inrepodir] = do++ typed_repodir <- ioAbsoluteOrRemote inrepodir+ let repodir = toPath typed_repodir++ --test for converting darcs-2 repository+ format <- identifyRepoFormat repodir+ when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format."++ putStrLn convertHelp'+ let vow = "I understand the consequences of my action"+ putStrLn "Please confirm that you have read and understood the above"+ vow' <- askUser ("by typing `" ++ vow ++ "': ")+ when (vow' /= vow) $ fail "User didn't understand the consequences."++ unless (parseFlags O.verbosity opts == O.Quiet) $ showMotd repodir+ mysimplename <- makeRepoName opts repodir+ createDirectory mysimplename+ setCurrentDirectory mysimplename+ createRepository False (withWorkingDir opts) (runPatchIndex opts)+ writeBinFile (darcsdir++"/hashed_inventory") ""+ withRepoLock NoDryRun (useCache opts) NoUpdateWorking (umask opts) $ V2Job $ \repository ->+ withRepositoryDirectory (useCache opts) repodir $ V1Job $ \themrepo -> do+ theirstuff <- readRepo themrepo+ let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff+ outOfOrderTags = catMaybes $ mapRL oot $ newset2RL theirstuff+ where oot t = if isTag (info t) && info t `notElem` inOrderTags theirstuff+ then Just (info t, getdeps $ hopefully t)+ else Nothing+ fixDep p = case lookup p outOfOrderTags of+ Just d -> p : concatMap fixDep d+ Nothing -> [p]+ convertOne :: Patch Prim wX wY -> FL (RealPatch Prim) wX wY+ convertOne x | isMerger x = case mergeUnravelled $ publicUnravel x of+ Just (FlippedSeal y) ->+ case effect y =/\= effect x of+ IsEq -> y :>: NilFL+ NotEq ->+ traceDoc (text "lossy conversion:" $$+ showPatch x)+ fromPrims (effect x)+ Nothing -> traceDoc (text+ "lossy conversion of complicated conflict:" $$+ showPatch x)+ fromPrims (effect x)+ convertOne (PP x) = fromPrim x :>: NilFL+ convertOne _ = impossible+ convertFL :: FL (Patch Prim) wX wY -> FL (RealPatch Prim) wX wY+ convertFL = concatFL . mapFL_FL convertOne+ convertNamed :: Named (Patch Prim) wX wY -> PatchInfoAnd (RealPatch Prim) wX wY+ convertNamed n = n2pia $+ adddeps (infopatch (convertInfo $ patch2patchinfo n) $+ convertFL $ patchcontents n)+ (map convertInfo $ concatMap fixDep $ getdeps n)+ convertInfo n | n `elem` inOrderTags theirstuff = n+ | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n+ applySome xs = do -- TODO this unsafeCoerce hack is because we don't keep track of the repository state properly+ -- Really sequence_ $ mapFL applySome below should instead be a repeated add operation -+ -- there doesn't seem to be any reason we need to do a merge here.+ let repository2 = unsafeCoerce# repository :: Repository (RealPatch Prim) wA wB wA+ Sealed pw <- tentativelyMergePatches repository2 "convert"+ YesAllowConflicts NoUpdateWorking+ NoExternalMerge NoWantGuiPause+ GzipCompression (verbosity opts)+ NoReorder+ (UseIndex, ScanKnown, MyersDiff)+ NilFL xs+ finalizeRepositoryChanges repository2 NoUpdateWorking GzipCompression -- this is to clean out pristine.hashed+ revertRepositoryChanges repository2 NoUpdateWorking+ _ <- revertable $ applyToWorking repository2 (verbosity opts) pw+ invalidateIndex repository2+ sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches+ invalidateIndex repository+ revertable $ createPristineDirectoryTree repository "." (withWorkingDir opts)+ when (parseFlags O.setScriptsExecutable opts == O.YesSetScriptsExecutable)+ R.setScriptsExecutable++ -- Copy over the prefs file+ let prefsRelPath = darcsdir </> "prefs" </> "prefs"+ (fetchFilePS (repodir </> prefsRelPath) Uncachable >>= B.writeFile prefsRelPath)+ `catchall` return ()++ putInfo opts $ text "Finished converting."+ where revertable x = x `clarifyErrors` unlines+ ["An error may have left your new working directory an inconsistent",+ "but recoverable state. You should be able to make the new",+ "repository consistent again by running darcs revert -a."]++toDarcs2 _ _ _ = fail "You must provide either one or two arguments."++makeRepoName :: [DarcsFlag] -> FilePath -> IO String+makeRepoName (NewRepo n:_) _ =+ do exists <- doesDirectoryExist n+ file_exists <- doesFileExist n+ if exists || file_exists+ then fail $ "Directory or file named '" ++ n ++ "' already exists."+ else return n+makeRepoName (_:as) d = makeRepoName as d+makeRepoName [] d =+ case dropWhile (=='.') $ reverse $+ takeWhile (\c -> c /= '/' && c /= ':') $+ dropWhile (=='/') $ reverse d of+ "" -> modifyRepoName "anonymous_repo"+ base -> modifyRepoName base++modifyRepoName :: String -> IO String+modifyRepoName name =+ if head name == '/'+ then mrn name (-1)+ else do cwd <- getCurrentDirectory+ mrn (cwd ++ "/" ++ name) (-1)+ where+ mrn :: String -> Int -> IO String+ mrn n i = do+ exists <- doesDirectoryExist thename+ file_exists <- doesFileExist thename+ if not exists && not file_exists+ then do when (i /= -1) $+ putStrLn $ "Directory '"++ n +++ "' already exists, creating repository as '"+++ thename ++"'"+ return thename+ else mrn n $ i+1+ where thename = if i == -1 then n else n++"_"++show i++fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+fastExport _ opts _ = do+ let repodir = fromMaybe "." $ getRepourl opts+ marks <- case parseFlags O.readMarks opts of+ Nothing -> return emptyMarks+ Just f -> readMarks f+ newMarks <- withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo -> fastExport' repo marks+ case parseFlags O.writeMarks opts of+ Nothing -> return ()+ Just f -> writeMarks f newMarks++fastExport' :: (RepoPatch p, ApplyState p ~ Tree) => Repository p r u r -> Marks -> IO Marks+fastExport' repo marks = do+ putStrLn "progress (reading repository)"+ patchset <- readRepo repo+ marksref <- newIORef marks+ let patches = newset2FL patchset+ tags = inOrderTags patchset+ mark :: (PatchInfoAnd p) x y -> Int -> TreeIO ()+ mark p n = liftIO $ do putStrLn $ "mark :" ++ show n+ modifyIORef marksref $ \m -> addMark m n (patchHash p)+ -- apply a single patch to build the working tree of the last exported version+ checkOne :: (RepoPatch p, ApplyState p ~ Tree)+ => Int -> (PatchInfoAnd p) x y -> TreeIO ()+ checkOne n p = do apply p+ unless (inOrderTag tags p ||+ (getMark marks n == Just (patchHash p))) $+ fail $ "FATAL: Marks do not correspond: expected " +++ (show $ getMark marks n) ++ ", got " ++ (BC.unpack $ patchHash p)+ -- build the working tree of the last version exported by convert --export+ check :: (RepoPatch p, ApplyState p ~ Tree)+ => Int -> FL (PatchInfoAnd p) x y -> TreeIO (Int, FlippedSeal( FL (PatchInfoAnd p)) y) + check _ NilFL = return (1, flipSeal NilFL)+ check n allps@(p:>:ps)+ | n <= lastMark marks = checkOne n p >> check (next tags n p) ps+ | n > lastMark marks = return (n, flipSeal allps)+ | lastMark marks == 0 = return (1, flipSeal allps)+ | otherwise = undefined+ ((n, patches'), tree') <- hashedTreeIO (check 1 patches) emptyTree $ darcsdir </> "pristine.hashed"+ let patches'' = unsafeUnsealFlipped patches'+ void $ hashedTreeIO (dumpPatches tags mark n patches'') tree' $ darcsdir </> "pristine.hashed"+ readIORef marksref+ `finally` do+ putStrLn "progress (cleaning up)"+ current <- readHashedPristineRoot repo+ cleanHashdir (extractCache repo) HashedPristineDir $ catMaybes [current]+ putStrLn "progress done"++dumpPatches :: (RepoPatch p, ApplyState p ~ Tree)+ => [PatchInfo]+ -> (forall p0 x0 y0 . (PatchInfoAnd p0) x0 y0 -> Int -> TreeIO ())+ -> Int -> FL (PatchInfoAnd p) x y -> TreeIO ()+dumpPatches _ _ _ NilFL = liftIO $ putStrLn "progress (patches converted)"+dumpPatches tags mark n (p:>:ps) = do+ apply p+ if inOrderTag tags p && n > 0+ then dumpTag p n+ else do dumpPatch mark p n+ dumpFiles $ map floatPath $ listTouchedFiles p+ dumpPatches tags mark (next tags n p) ps++dumpTag :: (PatchInfoAnd p) x y -> Int -> TreeIO () +dumpTag p n =+ dumpBits [ BLU.fromString $ "progress TAG " ++ cleanTagName p+ , BLU.fromString $ "tag " ++ cleanTagName p -- FIXME is this valid?+ , BLU.fromString $ "from :" ++ show (n - 1)+ , BLU.fromString $ unwords ["tagger", patchAuthor p, patchDate p]+ -- -3 == (-4 for "TAG " and +1 for newline)+ , BLU.fromString $ "data "+ ++ show (BL.length (patchMessage p) - 3)+ , BL.drop 4 $ patchMessage p ]+ where+ -- FIXME forbidden characters and subsequences in tags:+ -- https://www.kernel.org/pub/software/scm/git/docs/git-check-ref-format.html+ cleanTagName = map cleanup . drop 4 . piName . info+ where cleanup x | x `elem` bad = '_'+ | otherwise = x+ bad :: String+ bad = " ~^:"++dumpFiles :: [AnchoredPath] -> TreeIO ()+dumpFiles files = forM_ files $ \file -> do+ isfile <- fileExists file+ isdir <- directoryExists file+ when isfile $ do bits <- readFile file+ dumpBits [ BLU.fromString $ "M 100644 inline " ++ anchorPath "" file+ , BLU.fromString $ "data " ++ show (BL.length bits)+ , bits ]+ when isdir $ do -- Always delete directory before dumping its contents. This fixes+ -- a corner case when a same patch moves dir1 to dir2, and creates+ -- another directory dir1.+ -- As we always dump its contents anyway this is not more costly.+ liftIO $ putStrLn $ "D " ++ anchorPath "" file+ tt <- gets tree -- ick+ let subs = [ file `appendPath` n | (n, _) <-+ listImmediate $ fromJust $ findTree tt file ]+ dumpFiles subs+ when (not isfile && not isdir) $ liftIO $ putStrLn $ "D " ++ anchorPath "" file++dumpPatch :: (forall p0 x0 y0 . (PatchInfoAnd p0) x0 y0 -> Int -> TreeIO ())+ -> (PatchInfoAnd p) x y -> Int+ -> TreeIO ()+dumpPatch mark p n =+ do dumpBits [ BLC.pack $ "progress " ++ show n ++ ": " ++ piName (info p)+ , "commit refs/heads/master" ]+ mark p n+ dumpBits [ BLU.fromString $ "committer " ++ patchAuthor p ++ " " ++ patchDate p+ , BLU.fromString $ "data " ++ show (BL.length $ patchMessage p)+ , patchMessage p ]+ when (n > 1) $ dumpBits [ BLU.fromString $ "from :" ++ show (n - 1) ]++dumpBits :: [BL.ByteString] -> TreeIO ()+dumpBits = liftIO . BLC.putStrLn . BL.intercalate "\n"++-- patchAuthor attempts to fixup malformed author strings+-- into format: "Name <Email>"+-- e.g.+-- <john@home> -> john <john@home>+-- john@home -> john <john@home>+-- john <john@home> -> john <john@home>+-- john <john@home -> john <john@home>+-- <john> -> john <unknown>+patchAuthor :: (PatchInfoAnd p) x y -> String+patchAuthor p+ | null author = unknownEmail "unknown"+ | otherwise = case span (/='<') author of+ -- No name, but have email (nothing spanned)+ ("", email) -> case span (/='@') (tail email) of+ -- Not a real email address (no @).+ (n, "") -> case span (/='>') n of+ (name, _) -> unknownEmail name+ -- A "real" email address.+ (user, rest) -> case span (/= '>') (tail rest) of+ (dom, _) -> mkAuthor user $ emailPad (user ++ "@" ++ dom)+ -- No email (everything spanned)+ (_, "") -> case span (/='@') author of+ (n, "") -> unknownEmail n+ (name, _) -> mkAuthor name $ emailPad author+ -- Name and email+ (n, rest) -> case span (/='>') $ tail rest of+ (email, _) -> n ++ emailPad email+ where+ author = dropWhile isSpace $ piAuthor (info p)+ unknownEmail = flip mkAuthor "<unknown>"+ emailPad email = "<" ++ email ++ ">"+ mkAuthor name email = name ++ " " ++ email++patchDate :: (PatchInfoAnd p) x y -> String+patchDate = formatDateTime "%s +0000" . fromClockTime . toClockTime .+ piDate . info++patchMessage :: (PatchInfoAnd p) x y -> BLU.ByteString+patchMessage p = BL.concat [ BLU.fromString (piName $ info p)+ , case unlines . piLog $ info p of+ "" -> BL.empty+ plog -> BLU.fromString ("\n\n" ++ plog)+ ]++type Marked = Maybe Int+type Branch = B.ByteString+type AuthorInfo = B.ByteString+type Message = B.ByteString+type Content = B.ByteString++data RefId = MarkId Int | HashId B.ByteString | Inline+ deriving Show++data Object = Blob (Maybe Int) Content+ | Reset Branch (Maybe RefId)+ | Commit Branch Marked AuthorInfo Message+ | Tag Int AuthorInfo Message+ | Modify (Either Int Content) B.ByteString -- (mark or content), filename+ | Gitlink B.ByteString+ | Delete B.ByteString -- filename+ | From Int+ | Merge Int+ | Progress B.ByteString+ | End+ deriving Show++type Ancestors = (Marked, [Int])+data State = Toplevel Marked Branch+ | InCommit Marked Ancestors Branch (Tree IO) PatchInfo+ | Done++instance Show State where+ show (Toplevel _ _) = "Toplevel"+ show (InCommit _ _ _ _ _) = "InCommit"+ show Done = "Done"++fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+fastImport _ opts [outrepo] =+ do createDirectory outrepo+ withCurrentDirectory outrepo $ do+ createRepository (patchFormat opts == O.PatchFormat1) (withWorkingDir opts) (runPatchIndex opts)+ withRepoLock NoDryRun (useCache opts) NoUpdateWorking (umask opts) $ V2Job $ \repo -> do+ -- TODO implement --dry-run, which would be read-only?+ marks <- fastImport' repo emptyMarks+ createPristineDirectoryTree repo "." (withWorkingDir opts)+ return marks+fastImport _ _ _ = fail "I need exactly one output repository."++fastImport' :: forall p r u . (RepoPatch p, ApplyState p ~ Tree) =>+ Repository p r u r -> Marks -> IO ()+fastImport' repo marks = do+ pristine <- readRecorded repo+ marksref <- newIORef marks+ let initial = Toplevel Nothing $ BC.pack "refs/branches/master"++ go :: State -> B.ByteString -> TreeIO ()+ go state rest = do (rest', item) <- parseObject rest+ state' <- process state item+ case state' of+ Done -> return ()+ _ -> go state' rest'++ -- sort marks into buckets, since there can be a *lot* of them+ markpath :: Int -> AnchoredPath+ markpath n = floatPath (darcsdir </> "marks")+ `appendPath` (Name $ BC.pack $ show (n `div` 1000))+ `appendPath` (Name $ BC.pack $ show (n `mod` 1000))++ makeinfo author message tag = do+ let (name:log) = lines $ BC.unpack message+ (author'', date'') = span (/='>') $ BC.unpack author+ date' = dropWhile (`notElem` ("0123456789" :: String)) date''+ author' = author'' ++ ">"+ date = formatDateTime "%Y%m%d%H%M%S" $ case (parseDateTime "%s %z" date') of+ Just x -> x+ Nothing -> startOfTime+ liftIO $ patchinfo date (if tag then "TAG " ++ name else name) author' log++ addtag author msg =+ do info_ <- makeinfo author msg True+ gotany <- liftIO $ doesFileExist $ darcsdir </> "tentative_hashed_pristine"+ deps <- if gotany then liftIO $ getUncovered `fmap` readTentativeRepo repo+ else return []+ let ident = NilFL :: FL (RealPatch Prim) cX cX+ patch = adddeps (infopatch info_ ident) deps+ void $ liftIO $ addToTentativeInventory (extractCache repo)+ GzipCompression (n2pia patch)++ -- processing items+ updateHashes = do+ let nodarcs = (\(AnchoredPath (Name x:_)) _ -> x /= BC.pack darcsdir)+ hashblobs (File blob@(T.Blob con NoHash)) =+ do hash <- sha256 `fmap` readBlob blob+ return $ File (T.Blob con hash)+ hashblobs x = return x+ tree' <- liftIO . T.partiallyUpdateTree hashblobs nodarcs =<< gets tree+ modify $ \s -> s { tree = tree' }+ return $ T.filter nodarcs tree'++ process :: State -> Object -> TreeIO State+ process s (Progress p) = do+ liftIO $ putStrLn ("progress " ++ BC.unpack p)+ return s++ process (Toplevel _ _) End = do+ tree' <- (liftIO . darcsAddMissingHashes) =<< updateHashes+ modify $ \s -> s { tree = tree' } -- lets dump the right tree, without _darcs+ let root = encodeBase16 $ treeHash tree'+ liftIO $ do+ putStrLn $ "\\o/ It seems we survived. Enjoy your new repo."+ B.writeFile (darcsdir </> "tentative_pristine") $+ BC.concat [BC.pack "pristine:", root]+ return Done++ process (Toplevel n b) (Tag what author msg) = do+ if Just what == n+ then addtag author msg+ else liftIO $ putStrLn $ "WARNING: Ignoring out-of-order tag " +++ (head $ lines $ BC.unpack msg)+ return (Toplevel n b)++ process (Toplevel n _) (Reset branch from) =+ do case from of+ (Just (MarkId k)) | Just k == n ->+ addtag (BC.pack "Anonymous Tagger <> 0 +0000") branch+ _ -> liftIO $ putStrLn $ "WARNING: Ignoring out-of-order tag " +++ BC.unpack branch+ return $ Toplevel n branch++ process (Toplevel n b) (Blob (Just m) bits) = do+ TM.writeFile (markpath m) $ (BLC.fromChunks [bits])+ return $ Toplevel n b++ process x (Gitlink link) = do+ liftIO $ putStrLn $ "WARNING: Ignoring gitlink " ++ BC.unpack link+ return x++ process (Toplevel previous pbranch) (Commit branch mark author message) = do+ when (pbranch /= branch) $ do+ liftIO $ putStrLn ("Tagging branch: " ++ BC.unpack pbranch)+ addtag author pbranch+ info_ <- makeinfo author message False+ startstate <- updateHashes+ return $ InCommit mark (previous, []) branch startstate info_++ process s@(InCommit _ _ _ _ _) (Modify (Left m) path) = do+ TM.copy (markpath m) (floatPath $ BC.unpack path)+ return s++ process s@(InCommit _ _ _ _ _) (Modify (Right bits) path) = do+ TM.writeFile (floatPath $ BC.unpack path) (BLC.fromChunks [bits])+ return s++ process s@(InCommit _ _ _ _ _) (Delete path) = do+ TM.unlink (floatPath $ BC.unpack path)+ return s++ process (InCommit mark (prev, current) branch start info_) (From from) = do+ return $ InCommit mark (prev, from:current) branch start info_++ process (InCommit mark (prev, current) branch start info_) (Merge from) = do+ return $ InCommit mark (prev, from:current) branch start info_++ process (InCommit mark ancestors branch start info_) x = do+ case ancestors of+ (_, []) -> return () -- OK, previous commit is the ancestor+ (Just n, list)+ | n `elem` list -> return () -- OK, we base off one of the ancestors+ | otherwise -> liftIO $ putStrLn $+ "WARNING: Linearising non-linear ancestry:" +++ " currently at " ++ show n ++ ", ancestors " ++ show list+ (Nothing, list) ->+ liftIO $ putStrLn $ "WARNING: Linearising non-linear ancestry " ++ show list++ current <- updateHashes+ Sealed diff+ <- unFreeLeft `fmap` (liftIO $ treeDiff PatienceDiff (const TextFile) start current)+ prims <- return $ fromPrims $ sortCoalesceFL diff+ let patch = infopatch info_ ((NilFL :: FL p cX cX) +>+ prims)+ void $ liftIO $ addToTentativeInventory (extractCache repo)+ GzipCompression (n2pia patch)+ case mark of+ Nothing -> return ()+ Just n -> case getMark marks n of+ Nothing -> liftIO $ modifyIORef marksref $ \m -> addMark m n (patchHash $ n2pia patch)+ Just n' -> fail $ "FATAL: Mark already exists: " ++ BC.unpack n'+ process (Toplevel mark branch) x++ process state obj = do+ liftIO $ print obj+ fail $ "Unexpected object in state " ++ show state++ void $ hashedTreeIO (go initial B.empty) pristine $ darcsdir </> "pristine.hashed"+ finalizeRepositoryChanges repo YesUpdateWorking GzipCompression+ cleanRepository repo++parseObject :: BC.ByteString -> TreeIO ( BC.ByteString, Object )+parseObject = next' mbObject+ where mbObject = A.parse p_maybeObject++ p_maybeObject = Just `fmap` p_object+ <|> (A.endOfInput >> return Nothing)++ lex p = p >>= \x -> A.skipSpace >> return x+ lexString s = A.string (BC.pack s) >> A.skipSpace+ line = lex $ A.takeWhile (/='\n')++ optional p = Just `fmap` p <|> return Nothing++ p_object = p_blob+ <|> p_reset+ <|> p_commit+ <|> p_tag+ <|> p_modify+ <|> p_from+ <|> p_merge+ <|> p_delete+ <|> (lexString "progress" >> Progress `fmap` line)++ p_author name = lexString name >> line++ p_reset = do lexString "reset"+ branch <- line+ refid <- optional $ lexString "from" >> p_refid+ return $ Reset branch refid++ p_commit = do lexString "commit"+ branch <- line+ mark <- optional p_mark+ _ <- optional $ p_author "author"+ committer <- p_author "committer"+ message <- p_data+ return $ Commit branch mark committer message++ p_tag = do _ <- lexString "tag" >> line -- FIXME we ignore branch for now+ lexString "from"+ mark <- p_marked+ author <- p_author "tagger"+ message <- p_data+ return $ Tag mark author message++ p_blob = do lexString "blob"+ mark <- optional p_mark+ Blob mark `fmap` p_data+ <?> "p_blob"++ p_mark = do lexString "mark"+ p_marked+ <?> "p_mark"++ p_refid = MarkId `fmap` p_marked+ <|> (lexString "inline" >> return Inline)+ <|> HashId `fmap` p_hash++ p_data = do lexString "data"+ len <- A.decimal+ _ <- A.char '\n'+ lex $ A.take len+ <?> "p_data"++ p_marked = lex $ A.char ':' >> A.decimal+ p_hash = lex $ A.takeWhile1 (A.inClass "0123456789abcdefABCDEF")+ p_from = lexString "from" >> From `fmap` p_marked+ p_merge = lexString "merge" >> Merge `fmap` p_marked+ p_delete = lexString "D" >> Delete `fmap` line+ p_modify = do lexString "M"+ mode <- lex $ A.takeWhile (A.inClass "01234567890")+ mark <- p_refid+ path <- line+ case mark of+ HashId hash | mode == BC.pack "160000" -> return $ Gitlink hash+ | otherwise -> fail ":(("+ MarkId n -> return $ Modify (Left n) path+ Inline -> do bits <- p_data+ return $ Modify (Right bits) path++ next' :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)+ next' parser rest =+ do chunk <- if B.null rest then liftIO $ B.hGet stdin (64 * 1024)+ else return rest+ next_chunk parser chunk++ next_chunk :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)+ next_chunk parser chunk =+ case parser chunk of+ A.Done rest result -> return (rest, maybe End id result) -- not sure about the maybe+ A.Partial cont -> next' cont B.empty+ A.Fail _ ctx err -> do+ liftIO $ putStrLn $ "=== chunk ===\n" ++ BC.unpack chunk ++ "\n=== end chunk ===="+ fail $ "Error parsing stream. " ++ err ++ "\nContext: " ++ show ctx+++patchHash :: PatchInfoAnd p cX cY -> BC.ByteString+patchHash p = BC.pack $ show $ makePatchname (info p)++inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd p wX wZ -> Bool+inOrderTag tags p = isTag (info p) && info p `elem` tags && nullFL (effect p)++next :: (Effect p) => [PatchInfo] -> Int -> PatchInfoAnd p x y -> Int+next tags n p = if inOrderTag tags p then n else n + 1++inOrderTags :: PatchSet p wS wX -> [PatchInfo]+inOrderTags (PatchSet _ ts) = go ts+ where go :: RL(Tagged t1) wT wY -> [PatchInfo]+ go (Tagged t _ _ :<: ts') = info t : go ts'+ go NilRL = []++type Marks = M.IntMap BC.ByteString++emptyMarks :: Marks+emptyMarks = M.empty++lastMark :: Marks -> Int+lastMark m = if M.null m then 0 else fst $ M.findMax m++getMark :: Marks -> Int -> Maybe BC.ByteString+getMark marks key = M.lookup key marks++addMark :: Marks -> Int -> BC.ByteString -> Marks+addMark marks key value = M.insert key value marks++readMarks :: FilePath -> IO Marks+readMarks p = do lines' <- BC.split '\n' `fmap` BC.readFile p+ return $ foldl merge M.empty lines'+ `catchall` return emptyMarks+ where merge set line = case (BC.split ':' line) of+ [i, hash] -> M.insert (read $ BC.unpack i) (BC.dropWhile (== ' ') hash) set+ _ -> set -- ignore, although it is maybe not such a great idea...++writeMarks :: FilePath -> Marks -> IO ()+writeMarks fp m = do removeFile fp `catchall` return () -- unlink+ BC.writeFile fp marks+ where marks = BC.concat $ map format $ M.assocs m+ format (k, s) = BC.concat [BC.pack $ show k, BC.pack ": ", s, BC.pack "\n"]
+ src/Darcs/UI/Commands/Diff.hs view
@@ -0,0 +1,273 @@+-- Copyright (C) 2003-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.UI.Commands.Diff ( diffCommand ) where++import Prelude hiding ( (^), all )+import System.FilePath.Posix ( takeFileName, (</>) )+import Darcs.Util.Workaround ( getCurrentDirectory )+import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Prompt ( askEnter )+import Control.Monad ( when )+import Data.List ( (\\) )+import Storage.Hashed.Plain( writePlainTree )+import Storage.Hashed.Darcs( hashedTreeIO )++import Darcs.Util.CommandLine ( parseCmd )+import Darcs.UI.External+ ( diffProgram+ , execPipeIgnoreError+ )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Flags+ ( DarcsFlag ( AfterPatch, DiffCmd, LastN )+ , wantGuiPause, useCache, fixSubPaths )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( WantGuiPause (..), DiffAlgorithm(MyersDiff) )+import Darcs.Patch.PatchInfoAnd ( info, n2pia )+import Darcs.Util.Path ( toFilePath, SubPath, simpleSubPath, isSubPathOf, AbsolutePath )+import Darcs.Util.Global ( darcsdir )+import Darcs.Patch.Match+ ( firstMatch+ , secondMatch+ , matchFirstPatchset+ , matchSecondPatchset+ )+import Darcs.Repository ( withRepository, RepoJob(..), readRepo )+import Darcs.Repository.State ( readUnrecorded, restrictSubpaths+ , readRecorded, unrecordedChanges+ , UseIndex(..), ScanKnown(..), applyTreeFilter )+import Darcs.Patch.Witnesses.Ordered ( mapRL, (:>)(..), (+>+), RL(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd )+import Darcs.Patch.Witnesses.Sealed ( unseal, Sealed(..), seal )+import Darcs.Patch ( RepoPatch, apply, listTouchedFiles, invert, fromPrims, anonymous )+import Darcs.Patch.Depends ( findCommonWithThem )+import Darcs.Patch.Set ( PatchSet(..), newset2RL )+import Darcs.Patch.Info ( PatchInfo, showPatchInfoUI )+import Darcs.Repository.Lock ( withTempDir )+import Darcs.Util.Printer ( Doc, putDoc, putDocLn, vcat, empty, RenderMode(..) )++#include "impossible.h"+++diffDescription :: String+diffDescription = "Create a diff between two versions of the repository."++diffHelp :: String+diffHelp =+ "The `darcs diff` command compares two versions of the working tree of\n" +++ "the current repository. Without options, the pristine (recorded) and\n" +++ "unrecorded working trees are compared. This is lower-level than\n" +++ "the `darcs whatsnew` command, since it outputs a line-by-line diff,\n" +++ "and it is also slower. As with `darcs whatsnew`, if you specify\n" +++ "files or directories, changes to other files are not listed.\n" +++ "The command always uses an external diff utility.\n" +++ "\n" +++ "With the `--patch` option, the comparison will be made between working\n" +++ "trees with and without that patch. Patches *after* the selected patch\n" +++ "are not present in either of the compared working trees. The\n" +++ "`--from-patch` and `--to-patch` options allow the set of patches in the\n" +++ "`old' and `new' working trees to be specified separately.\n" +++ "\n" +++ "The associated tag and match options are also understood, e.g. `darcs\n" +++ "diff --from-tag 1.0 --to-tag 1.1`. All these options assume an\n" +++ "ordering of the patch set, so results may be affected by operations\n" +++ "such as `darcs optimize --reorder`.\n" +++ "\n" +++ "diff(1) is called with the arguments `-rN`. The `--unified` option causes\n" +++ "`-u` to be passed to diff(1). An additional argument can be passed\n" +++ "using `--diff-opts`, such as `--diff-opts=-ud` or `--diff-opts=-wU9`.\n" +++ "\n" +++ "The `--diff-command` option can be used to specify an alternative\n" +++ "utility, such as meld (GNOME) or opendiff (OS X). Arguments may be\n" +++ "included, separated by whitespace. The value is not interpreted by a\n" +++ "shell, so shell constructs cannot be used. The arguments %1 and %2\n" +++ "MUST be included, these are substituted for the two working trees\n" +++ "being compared. If this option is used, `--diff-opts` is ignored.\n"++diffBasicOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.ExternalDiff+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+diffBasicOpts+ = O.matchRange+ ^ O.extDiff+ ^ O.unidiff+ ^ O.workingRepoDir+ ^ O.storeInMemory++diffAdvancedOpts :: DarcsOption a (WantGuiPause -> a)+diffAdvancedOpts = O.pauseForGui++diffOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.ExternalDiff+ -> Bool+ -> Maybe String+ -> Bool+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> WantGuiPause+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+diffOpts = diffBasicOpts `withStdOpts` diffAdvancedOpts++diffCommand :: DarcsCommand [DarcsFlag]+diffCommand = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "diff"+ , commandHelp = diffHelp+ , commandDescription = diffDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+ , commandCommand = diffCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc diffAdvancedOpts+ , commandBasicOptions = odesc diffBasicOpts+ , commandDefaults = defaultFlags diffOpts+ , commandCheckOptions = ocheck diffOpts+ , commandParseOptions = onormalise diffOpts+ }++getDiffOpts :: [DarcsFlag] -> [String]+getDiffOpts fs = addUnified $ otherDiffOpts fs where+ addUnified = if parseFlags O.unidiff fs then ("-u":) else id+ otherDiffOpts = O._diffOpts . parseFlags O.extDiff++-- | Returns the command we should use for diff as a tuple (command, arguments).+-- This will either be whatever the user specified via --diff-command or the+-- default 'diffProgram'. Note that this potentially involves parsing the+-- user's diff-command, hence the possibility for failure with an exception.+getDiffCmdAndArgs :: String -> [DarcsFlag] -> String -> String+ -> Either String (String, [String])+getDiffCmdAndArgs cmd opts f1 f2 = helper opts where+ helper (DiffCmd c:_) =+ case parseCmd [ ('1', f1) , ('2', f2) ] c of+ Left err -> Left $ show err+ Right ([],_) -> bug "parseCmd should never return empty list"+ Right (h:t,_) -> Right (h,t)+ helper [] = -- if no command specified, use 'diff'+ Right (cmd, "-rN":getDiffOpts opts++[f1,f2])+ helper (_:t) = helper t++diffCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+diffCmd fps opts args+ | not (null [i | LastN i <- opts]) &&+ not (null [p | AfterPatch p <- opts]) =+ fail $ "using --patch and --last at the same time with the 'diff'" +++ " command doesn't make sense. Use --from-patch to create a diff" +++ " from this patch to the present, or use just '--patch' to view" +++ " this specific patch."+ | null args = doDiff opts Nothing+ | otherwise = doDiff opts . Just =<< fixSubPaths fps args++doDiff :: [DarcsFlag] -> Maybe [SubPath] -> IO ()+doDiff opts msubpaths = withRepository (useCache opts) $ RepoJob $ \repository -> do+ formerdir <- getCurrentDirectory++ let thename = takeFileName formerdir++ patchset <- readRepo repository++ unrecorded <- fromPrims `fmap` unrecordedChanges (UseIndex, ScanKnown, MyersDiff) repository msubpaths+ unrecorded' <- n2pia `fmap` anonymous unrecorded++ let matchFlags = parseFlags O.matchRange opts+ Sealed all <- return $ case (secondMatch matchFlags, patchset) of+ (True, _) -> seal patchset+ (False, PatchSet untagged tagged) -> seal $ PatchSet (unrecorded' :<: untagged) tagged++ Sealed ctx <- return $ if firstMatch matchFlags+ then matchFirstPatchset matchFlags patchset+ else seal patchset++ Sealed match <- return $ if secondMatch matchFlags+ then matchSecondPatchset matchFlags patchset+ else seal all++ (_ :> todiff) <- return $ findCommonWithThem match ctx+ (_ :> tounapply) <- return $ findCommonWithThem all match++ base <- if secondMatch matchFlags+ then readRecorded repository+ else readUnrecorded repository Nothing++ let touched = map (fromJust . simpleSubPath) $ listTouchedFiles todiff+ files = case msubpaths of+ Nothing -> touched+ Just subpaths -> concatMap (\s -> filter (isSubPathOf s) touched) subpaths+ relevant <- restrictSubpaths repository files+ let filt = applyTreeFilter relevant . snd+ ppath = darcsdir </> "pristine.hashed"++ oldtree <- filt `fmap` hashedTreeIO+ (apply . invert $ unsafeCoercePEnd todiff +>+ tounapply) base ppath+ newtree <- filt `fmap` hashedTreeIO+ (apply . invert $ tounapply) base ppath++ withTempDir ("old-"++thename) $ \odir ->+ withTempDir ("new-"++thename) $ \ndir ->+ withCurrentDirectory formerdir $ do+ writePlainTree oldtree (toFilePath odir)+ writePlainTree newtree (toFilePath ndir)+ thediff <- withCurrentDirectory (toFilePath odir ++ "/..") $+ rundiff (takeFileName $ toFilePath odir) (takeFileName $ toFilePath ndir)+ morepatches <- readRepo repository+ putDocLn $ changelog (getDiffInfo opts morepatches)+ putDoc $ thediff+ where rundiff :: String -> String -> IO Doc+ rundiff f1 f2 = do+ cmd <- diffProgram+ case getDiffCmdAndArgs cmd opts f1 f2 of+ Left err -> fail err+ Right (d_cmd, d_args) ->+ let pausingForGui = (wantGuiPause opts == YesWantGuiPause) in+ do when pausingForGui $ putStrLn $+ "Running command '" ++ unwords (d_cmd:d_args) ++ "'"+ output <- execPipeIgnoreError Encode d_cmd d_args empty+ when pausingForGui $+ askEnter "Hit return to move on..."+ return output++getDiffInfo :: RepoPatch p => [DarcsFlag] -> PatchSet p wStart wX -> [PatchInfo]+getDiffInfo opts ps =+ let matchFlags = parseFlags O.matchRange opts+ infos = mapRL info . newset2RL+ handle (match_cond, do_match)+ | match_cond matchFlags = unseal infos (do_match matchFlags ps)+ | otherwise = infos ps+ in handle (secondMatch, matchSecondPatchset)+ \\ handle (firstMatch, matchFirstPatchset)++changelog :: [PatchInfo] -> Doc+changelog pis = vcat $ map showPatchInfoUI pis+
+ src/Darcs/UI/Commands/Dist.hs view
@@ -0,0 +1,232 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Module : Darcs.UI.Commands.Dist+-- Copyright : 2003 David Roundy+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++module Darcs.UI.Commands.Dist+ (+ dist+ , doFastZip -- libdarcs export+ ) where++import Prelude hiding ( (^), writeFile )++import Data.ByteString.Lazy ( writeFile )+import Data.Char ( isAlphaNum )+import Control.Monad ( when )+import System.Directory ( setCurrentDirectory )+import System.Process ( system )+import System.Exit ( ExitCode(..), exitWith )+import System.FilePath.Posix ( takeFileName, (</>) )++import Darcs.Util.Workaround ( getCurrentDirectory )+import Codec.Archive.Tar ( pack, write )+import Codec.Archive.Tar.Entry ( entryPath )+import Codec.Compression.GZip ( compress )++import Codec.Archive.Zip ( emptyArchive, fromArchive, addEntryToArchive, toEntry )+import Darcs.Repository.External ( fetchFilePS, Cachable( Uncachable ) )+import Darcs.Util.Global ( darcsdir )+import Darcs.Repository.HashedRepo ( inv2pris )+import Darcs.Repository.HashedIO ( pathsAndContents )+import Darcs.Repository.InternalTypes ( Repository (..) )+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as B+import Darcs.UI.Flags+ ( DarcsFlag(Verbose, Quiet, DistName, DistZip, SetScriptsExecutable), useCache )+import Darcs.UI.Options+ ( DarcsOption, (^), oid, odesc, ocheck, onormalise+ , defaultFlags, parseFlags+ )+import qualified Darcs.UI.Options.All as O++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.Repository.Lock ( withTempDir )+import Darcs.Patch.Match+ ( haveNonrangeMatch+ , firstMatch+ )+import Darcs.Repository.Match+ ( getFirstMatch+ , getNonrangeMatch+ )+import Darcs.Repository ( withRepository, RepoJob(..),+ setScriptsExecutable, repoPatchType,+ createPartialsPristineDirectoryTree )+import Darcs.Repository.Prefs ( getPrefval )++import Darcs.Util.DateTime ( getCurrentTime, toSeconds )+import Darcs.Util.Path ( AbsolutePath, toFilePath )+import Darcs.Util.File ( withCurrentDirectory )+++distDescription :: String+distDescription = "Create a distribution archive."+++distHelp :: String+distHelp = unlines+ [ "`darcs dist` creates a compressed archive in the repository's root"+ , "directory, containing the recorded state of the working tree"+ , "(unrecorded changes and the `_darcs` directory are excluded)."+ , "The command accepts matchers to create an archive of some past"+ , "repository state, for instance `--tag`."+ , ""+ , "By default, the archive (and the top-level directory within the"+ , "archive) has the same name as the repository, but this can be"+ , "overridden with the `--dist-name` option."+ , ""+ , "If a predist command is set (see `darcs setpref`), that command will"+ , "be run on the recorded state prior to archiving. For example,"+ , "autotools projects would set it to `autoconf && automake`."+ , ""+ , "If `--zip` is used, matchers and the predist command are ignored."+ ]++distBasicOpts :: DarcsOption a+ (Maybe String+ -> Bool+ -> Maybe String+ -> [O.MatchFlag]+ -> O.SetScriptsExecutable+ -> Bool+ -> a)+distBasicOpts+ = O.distname+ ^ O.distzip+ ^ O.workingRepoDir+ ^ O.matchOne+ ^ O.setScriptsExecutable+ ^ O.storeInMemory++distOpts :: DarcsOption a+ (Maybe String+ -> Bool+ -> Maybe String+ -> [O.MatchFlag]+ -> O.SetScriptsExecutable+ -> Bool+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+distOpts = distBasicOpts `withStdOpts` oid++dist :: DarcsCommand [DarcsFlag]+dist = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "dist"+ , commandHelp = distHelp+ , commandDescription = distDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = distCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = odesc distBasicOpts+ , commandDefaults = defaultFlags distOpts+ , commandCheckOptions = ocheck distOpts+ , commandParseOptions = onormalise distOpts+ }++distCmd :: (AbsolutePath, AbsolutePath)+ -> [DarcsFlag]+ -> [String]+ -> IO ()+distCmd _ opts _ | DistZip `elem` opts = doFastZip opts+distCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ \repository -> do+ let matchFlags = parseFlags O.matchOne opts+ formerdir <- getCurrentDirectory+ let distname = getDistName formerdir [x | DistName x <- opts]+ predist <- getPrefval "predist"+ let resultfile = formerdir </> distname ++ ".tar.gz"+ withTempDir "darcsdist" $ \tempdir -> do+ setCurrentDirectory formerdir+ withTempDir (toFilePath tempdir </> takeFileName distname) $ \ddir -> do+ if haveNonrangeMatch (repoPatchType repository) matchFlags+ then+ if firstMatch matchFlags+ then withCurrentDirectory ddir $ getFirstMatch repository matchFlags+ else withCurrentDirectory ddir $ getNonrangeMatch repository matchFlags+ else createPartialsPristineDirectoryTree repository [""] (toFilePath ddir)+ ec <- case predist of Nothing -> return ExitSuccess+ Just pd -> system pd+ if ec == ExitSuccess+ then+ do+ withCurrentDirectory ddir $+ when (SetScriptsExecutable `elem` opts) setScriptsExecutable+ doDist opts tempdir ddir resultfile+ else+ do+ putStrLn "Dist aborted due to predist failure"+ exitWith ec+++-- | This function performs the actual distribution action itself.+-- NB - it does /not/ perform the pre-dist, that should already+-- have completed successfully before this is invoked.+doDist :: [DarcsFlag] -> AbsolutePath -> AbsolutePath -> FilePath -> IO ()+doDist opts tempdir ddir resultfile = do+ setCurrentDirectory (toFilePath tempdir)+ let safeddir = safename $ takeFileName $ toFilePath ddir+ entries <- pack "." [safeddir]+ when (Verbose `elem` opts) $ putStr $ unlines $ map entryPath entries+ writeFile resultfile $ compress $ write entries+ when (Quiet `notElem` opts) $ putStrLn $ "Created dist as " ++ resultfile+ where+ safename n@(c:_) | isAlphaNum c = n+ safename n = "./" ++ n+++getDistName :: FilePath -> [String] -> FilePath+getDistName _ (dn:_) = dn+getDistName currentDirectory _ = takeFileName currentDirectory++doFastZip :: [DarcsFlag]+ -> IO ()+doFastZip opts = withRepository (useCache opts) $ RepoJob $ \(Repo _ _ _ c) -> do+ when (SetScriptsExecutable `elem` opts) $+ putStrLn "WARNING: Zip archives cannot store executable flag."+ currentdir <- getCurrentDirectory+ let distname = getDistName currentdir [x | DistName x <- opts]+ i <- fetchFilePS (darcsdir </> "hashed_inventory") Uncachable+ pristine <- pathsAndContents (distname ++ "/") c (inv2pris i)+ epochtime <- toSeconds `fmap` getCurrentTime+ let entries = [ toEntry path epochtime (toLazy contents) | (path,contents) <- pristine ]+ let archive = foldr addEntryToArchive emptyArchive entries+ let resultfile = currentdir </> distname ++ ".zip"+ writeFile resultfile $ fromArchive archive+ when (Quiet `notElem` opts) $ putStrLn $ "Created " ++ resultfile++toLazy :: B.ByteString -> BL.ByteString+toLazy bs = BL.fromChunks [bs]
+ src/Darcs/UI/Commands/GZCRCs.hs view
@@ -0,0 +1,217 @@+-- Copyright (C) 2009 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.++{-# LANGUAGE CPP #-}++module Darcs.UI.Commands.GZCRCs+ ( gzcrcs+ , doCRCWarnings+ ) where++import Prelude hiding ( (^) )+import Control.Monad ( when, unless, forM_ )+import Control.Monad.Trans ( liftIO )+import Control.Monad.Writer ( runWriterT, tell )+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.IORef ( newIORef, readIORef, writeIORef )+import Data.Monoid ( Any(..), Sum(..) )+import System.Directory ( doesFileExist, doesDirectoryExist )+import System.Exit ( ExitCode(..), exitWith )+import System.IO ( hPutStr, hPutStrLn, stderr )+import Darcs.Util.File ( getRecursiveContentsFullPath )+import Darcs.Util.ByteString ( isGZFile, gzDecompress )+import Darcs.Util.Global ( getCRCWarnings, resetCRCWarnings )+import Darcs.Repository ( Repository, withRepository, RepoJob(..) )+-- This command needs access beyond the normal repository APIs (to+-- get at the caches and inspect them directly)+-- Could move the relevant code into Darcs.Repository modules+-- but it doesn't really seem worth it.+import Darcs.Repository.Cache ( Cache(..), writable, isThisRepo,+ hashedFilePath, allHashedDirs )+import Darcs.Repository.InternalTypes ( extractCache )+import Darcs.Repository.Lock ( gzWriteAtomicFilePSs )+import Darcs.Patch ( RepoPatch )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )+import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Path ( AbsolutePath )+import Darcs.UI.Flags+ ( DarcsFlag( Quiet, Verbose, Check, Repair, JustThisRepo )+ , useCache )+import Darcs.Util.Text ( formatText )+import Darcs.Util.Printer ( putDocLn, text )++gzcrcsHelp :: String+gzcrcsHelp = formatText 80+ [ "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed "+ ++ "files with bad CRCs (but valid data) to be written out. CRCs were "+ ++ "not checked on reading, so this bug wasn't noticed."+ , "This command inspects your repository for this corruption and "+ ++ "optionally repairs it."+ , "By default it also does this for any caches you have configured and "+ ++ "any other local repositories listed as sources of patches for this "+ ++ "one, perhaps because of a lazy get. You can limit the scope to just "+ ++ "the current repo with the --just-this-repo flag."+ , "Note that readonly caches, or other repositories listed as sources, "+ ++ "will be checked but not repaired. Also, this command will abort if "+ ++ "it encounters any non-CRC corruption in compressed files."+ , "You may wish to also run 'darcs check --complete' before repairing the "+ ++ "corruption. This is not done automatically because it might result "+ ++ "in needing to fetch extra patches if the repository is lazy."+ , "If there are any other problems with your repository, you can still "+ ++ "repair the CRCs, but you are advised to first make a backup copy in "+ ++ "case the CRC errors are actually caused by bad data and the old "+ ++ "CRCs might be useful in recovering that data."+ , "If you were warned about CRC errors during an operation involving "+ ++ "another repository, then it is possible that the other repository "+ ++ "contains the corrupt CRCs, so you should arrange for that "+ ++ "repository to also be checked/repaired."+ ]++-- |This is designed for use in an atexit handler, e.g. in Darcs.RunCommand+doCRCWarnings :: Bool -> IO ()+doCRCWarnings verbose = do+ files <- getCRCWarnings+ resetCRCWarnings+ unless (null files) $ do+ hPutStr stderr . formatText 80 $+ [""+ , "Warning: CRC errors found. These are probably harmless but "+ ++ "should be repaired. See 'darcs gzcrcs --help' for more "+ ++ "information."+ , ""+ ]+ when verbose $+ hPutStrLn stderr . unlines $+ "The following corrupt files were found:" : files++gzcrcsDescription :: String+gzcrcsDescription = "Check or repair the CRCs of compressed files in the "+ ++ "repository."++gzcrcsBasicOpts :: DarcsOption a (Maybe O.GzcrcsAction -> Bool -> Maybe String -> a)+gzcrcsBasicOpts = O.gzcrcsActions ^ O.justThisRepo ^ O.workingRepoDir++gzcrcsOpts :: DarcsOption a+ (Maybe O.GzcrcsAction+ -> Bool+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+gzcrcsOpts = gzcrcsBasicOpts `withStdOpts` oid++gzcrcs :: DarcsCommand [DarcsFlag]+gzcrcs = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "gzcrcs"+ , commandHelp = gzcrcsHelp+ , commandDescription = gzcrcsDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = gzcrcsCmd+ , commandPrereq = amInRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = odesc gzcrcsBasicOpts+ , commandDefaults = defaultFlags gzcrcsOpts+ , commandCheckOptions = ocheck gzcrcsOpts+ , commandParseOptions = onormalise gzcrcsOpts+ }++gzcrcsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+gzcrcsCmd _ opts _ | Check `elem` opts || Repair `elem` opts =+ withRepository (useCache opts) (RepoJob (gzcrcs' opts))+gzcrcsCmd _ _ _ = error "You must specify --check or --repair for gzcrcs"++gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p wR wU wT -> IO ()+gzcrcs' opts repo = do+ -- Somewhat ugly IORef use here because it's convenient, would be nicer to+ -- pre-filter the list of locs to check and then decide whether to print+ -- the message up front.+ warnRelatedRepos <- newIORef $ not isJustThisRepo+ let Ca locs = extractCache repo+ (_, Any checkFailed) <- runWriterT $ forM_ locs $ \loc ->+ unless (isJustThisRepo && not (isThisRepo loc)) $ do+ let isWritable = writable loc+ forM_ allHashedDirs $ \hdir -> do+ let dir = hashedFilePath loc hdir ""+ exists <- liftIO $ doesDirectoryExist dir+ when exists $ do+ liftIO $ do+ warn <- readIORef warnRelatedRepos+ when (warn && not (isThisRepo loc)) $ do+ writeIORef warnRelatedRepos False+ putInfo $+ "Also checking related repos and caches; use "+ ++ "--just-this-repo to disable.\n"+ ++ "Checking " ++ dir+ ++ (if isWritable then "" else " (readonly)")+ files <- liftIO $ getRecursiveContentsFullPath dir+ (_, Sum count) <- runWriterT $ forM_ files $ \file -> do+ isfile <- liftIO $ doesFileExist file+ when isfile $ do+ gz <- liftIO $ isGZFile file+ case gz of+ Nothing -> return ()+ Just len -> do+ contents <- liftIO $ B.readFile file+ let contentsbl = BL.fromChunks [contents]+ (uncompressed, isCorrupt) =+ gzDecompress (Just len) contentsbl+ when isCorrupt $ do+ -- Count of files in current directory+ tell (Sum 1)+ liftIO . putVerbose $+ "Corrupt: " ++ file+ when (isWritable && shouldRepair) $+ doRepair file uncompressed+ when (count > (0 :: Int)) $ do+ liftIO . putInfo $+ "Found " ++ show count ++ " corrupt file"+ ++ (if count > 1 then "s" else "")+ ++ (if shouldRepair+ then if isWritable+ then " (repaired)"+ else " (not repaired)"+ else "")+ -- Something corrupt somewhere+ tell (Any True)+ when (Check `elem` opts && checkFailed) $+ exitWith (ExitFailure 1)+ where+ [shouldRepair, isQuiet, isVerbose, isJustThisRepo] = zipWith ($)+ (elem `fmap` [Repair, Quiet, Verbose, JustThisRepo]) (repeat opts)+ putInfo = unless isQuiet . putDocLn . text+ putVerbose = when isVerbose . putDocLn . text+ doRepair name contents = liftIO $ gzWriteAtomicFilePSs name contents+
+ src/Darcs/UI/Commands/Help.hs view
@@ -0,0 +1,421 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Help (+ helpCmd,+ commandControlList, environmentHelp, -- these are for preproc.hs+ printVersion,+ listAvailableCommands ) where++import Darcs.UI.Flags+ ( DarcsFlag+ , environmentHelpEmail+ , environmentHelpSendmail+ )+import Darcs.UI.Options.Markdown ( optionsMarkdown )+import Darcs.UI.Commands+ ( CommandArgs(..)+ , CommandControl(..)+ , normalCommand+ , DarcsCommand(..), withStdOpts+ , WrappedCommand(..)+ , wrappedCommandName+ , disambiguateCommands+ , extractCommands+ , getCommandHelp+ , nodefaults+ , usage+ )+import Darcs.UI.External ( viewDoc )+import Darcs.Repository.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir+ , environmentHelpLocks )+import Darcs.Patch.Match ( helpOnMatchers )+import Darcs.Repository.Prefs ( boringFileHelp, binariesFileHelp, environmentHelpHome )+import Darcs.Repository.Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort )+import Darcs.Repository.External ( environmentHelpProtocols )+import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Path ( AbsolutePath )+import Control.Arrow ( (***) )+import Data.Char ( isAlphaNum, toLower, toUpper )+import Data.Either ( partitionEithers )+import Data.List ( groupBy, isPrefixOf, intercalate, nub )+import Darcs.Util.English ( andClauses )+import Darcs.Util.Printer (text, vcat, vsep, ($$), empty)+import Darcs.Util.Printer.Color ( environmentHelpColor, environmentHelpEscape, environmentHelpEscapeWhite )+import System.Exit ( exitSuccess )+import Version ( version )+import Darcs.Util.Download ( environmentHelpProxy, environmentHelpProxyPassword )+import Darcs.Util.Workaround ( getCurrentDirectory )+import Darcs.UI.Options ( DarcsOption, defaultFlags, ocheck, onormalise, oid )+import qualified Darcs.UI.Options.All as O ( StdCmdAction, Verbosity, UseCache )+import qualified Darcs.UI.TheCommands as TheCommands++helpDescription :: String+helpDescription = "Display help about darcs and darcs commands."++helpHelp :: String+helpHelp =+ "Without arguments, `darcs help` prints a categorized list of darcs\n" +++ "commands and a short description of each one. With an extra argument,\n" +++ "`darcs help foo` prints detailed help about the darcs command foo.\n"++argPossibilities :: [String]+argPossibilities = map wrappedCommandName $ extractCommands commandControlList++helpOpts :: DarcsOption a+ (Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+helpOpts = withStdOpts oid oid++help :: DarcsCommand [DarcsFlag]+help = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "help"+ , commandHelp = helpHelp+ , commandDescription = helpDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[<DARCS_COMMAND> [DARCS_SUBCOMMAND]] "]+ , commandCommand = \ x y z -> helpCmd x y z >> exitSuccess+ , commandPrereq = \_ -> return $ Right ()+ , commandGetArgPossibilities = return argPossibilities+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = []+ , commandDefaults = defaultFlags helpOpts+ , commandCheckOptions = ocheck helpOpts+ , commandParseOptions = onormalise helpOpts+ }++helpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+helpCmd _ _ ["manpage"] = putStr $ unlines manpageLines+helpCmd _ _ ["markdown"] = putStr $ unlines markdownLines+helpCmd _ _ ["patterns"] = viewDoc $ text $ unlines helpOnMatchers+helpCmd _ _ ("environment":vs_) =+ viewDoc $ header $$+ vsep (map render known) $$+ footer+ where+ header | null known = empty+ | otherwise = text "Environment Variables" $$+ text "====================="++ footer | null unknown = empty+ | otherwise = text "" $$+ text ("Unknown environment variables: "+ ++ intercalate ", " unknown)++ render (ks, ds) = text (andClauses ks ++ ":") $$+ vcat [ text (" " ++ d) | d <- ds ]++ (unknown, known) = case map (map toUpper) vs_ of+ [] -> ([], environmentHelp)+ vs -> (nub *** (nub . concat)) . partitionEithers $+ map doLookup vs++ -- v is not known if it doesn't appear in the list of aliases of any+ -- of the environment var help descriptions.+ doLookup v = case filter ((v `elem`) . fst) environmentHelp of+ [] -> Left v+ es -> Right es++helpCmd _ _ [] = viewDoc $ text $ usage commandControlList++helpCmd _ _ (cmd:args) =+ let disambiguated = disambiguateCommands commandControlList cmd args+ in case disambiguated of+ Left err -> fail err+ Right (cmds,_) ->+ let msg = case cmds of+ CommandOnly c -> getCommandHelp Nothing c+ SuperCommandOnly c -> getCommandHelp Nothing c+ SuperCommandSub c s -> getCommandHelp (Just c) s+ in viewDoc $ text msg++listAvailableCommands :: IO ()+listAvailableCommands =+ do here <- getCurrentDirectory+ is_valid <- mapM+ (\(WrappedCommand c)-> withCurrentDirectory here $ commandPrereq c [])+ (extractCommands commandControlList)+ putStr $ unlines $ map (wrappedCommandName . fst) $+ filter (isRight.snd) $+ zip (extractCommands commandControlList) is_valid+ putStrLn "--help"+ putStrLn "--version"+ putStrLn "--exact-version"+ putStrLn "--overview"+ where isRight (Right _) = True+ isRight _ = False++printVersion :: IO ()+printVersion = putStrLn $ "darcs version " ++ version++-- avoiding a module import cycle between Help and TheCommands+commandControlList :: [CommandControl]+commandControlList =+ normalCommand help : TheCommands.commandControlList++-- FIXME: the "grouping" comments below should made subsections in the+-- manpage, as we already do for DarcsCommand groups. --twb, 2009++-- | Help on each environment variable in which Darcs is interested.+environmentHelp :: [([String], [String])]+environmentHelp = [+ -- General-purpose+ environmentHelpHome,+ environmentHelpEditor,+ environmentHelpPager,+ environmentHelpColor,+ environmentHelpEscapeWhite,+ environmentHelpEscape,+ environmentHelpTmpdir,+ environmentHelpKeepTmpdir,+ environmentHelpEmail,+ environmentHelpSendmail,+ environmentHelpLocks,+ -- Remote Repositories+ environmentHelpSsh,+ environmentHelpScp,+ environmentHelpSshPort,+ environmentHelpProxy,+ environmentHelpProxyPassword,+ environmentHelpProtocols,+ environmentHelpTimeout]++-- | This module is responsible for emitting a darcs "man-page", a+-- reference document used widely on Unix-like systems. Manpages are+-- primarily used as a quick reference, or "memory jogger", so the+-- output should be terser than the user manual.+--+-- Before modifying the output, please be sure to read the man(7) and+-- man-pages(7) manpages, as these respectively describe the relevant+-- syntax and conventions.++-- | The lines of the manpage to be printed.+manpageLines :: [String]+manpageLines = [+ ".TH DARCS 1 \"" ++ version ++ "\"",+ ".SH NAME",+ "darcs \\- an advanced revision control system",+ ".SH SYNOPSIS",+ ".B darcs", ".I command", ".RI < arguments |[ options ]>...",+ "",+ "Where the", ".I commands", "and their respective", ".I arguments", "are",+ "",+ unlines synopsis,+ ".SH DESCRIPTION",+ -- FIXME: this is copy-and-pasted from darcs.cabal, so+ -- it'll get out of date as people forget to maintain+ -- both in sync.+ "Darcs is a free, open source revision control",+ "system. It is:",+ ".TP 3", "\\(bu",+ "Distributed: Every user has access to the full",+ "command set, removing boundaries between server and",+ "client or committer and non\\(hycommitters.",+ ".TP", "\\(bu",+ "Interactive: Darcs is easy to learn and efficient to",+ "use because it asks you questions in response to",+ "simple commands, giving you choices in your work",+ "flow. You can choose to record one change in a file,",+ "while ignoring another. As you update from upstream,",+ "you can review each patch name, even the full `diff'",+ "for interesting patches.",+ ".TP", "\\(bu",+ "Smart: Originally developed by physicist David",+ "Roundy, darcs is based on a unique algebra of",+ "patches.",+ "This smartness lets you respond to changing demands",+ "in ways that would otherwise not be possible. Learn",+ "more about spontaneous branches with darcs.",+ ".SH OPTIONS",+ "Different options are accepted by different Darcs commands.",+ "Each command's most important options are listed in the",+ ".B COMMANDS",+ "section. For a full list of all options accepted by",+ "a particular command, run `darcs", ".I command", "\\-\\-help'.",+ ".SS " ++ escape (unlines helpOnMatchers), -- FIXME: this is a kludge.+ ".SH COMMANDS",+ unlines commands,+ unlines environment,+ ".SH FILES",+ ".SS \"_darcs/prefs/binaries\"",+ escape $ unlines binariesFileHelp,+ ".SS \"_darcs/prefs/boring\"",+ escape $ unlines boringFileHelp,+ ".SH BUGS",+ "At http://bugs.darcs.net/ you can find a list of known",+ "bugs in Darcs. Unknown bugs can be reported at that",+ "site (after creating an account) or by emailing the",+ "report to bugs@darcs.net.",+ -- ".SH EXAMPLE",+ -- FIXME:+ -- new project: init, rec -la;+ -- track upstream project: get, pull -a;+ -- contribute to project: add, rec, push/send.+ ".SH SEE ALSO",+ "The Darcs website provides a lot of additional information.",+ "It can be found at http://darcs.net/",+ ".SH LICENSE",+ "Darcs is free software; you can redistribute it and/or modify",+ "it under the terms of the GNU General Public License as published by",+ "the Free Software Foundation; either version 2, or (at your option)",+ "any later version." ]+ where+ -- | A synopsis line for each command. Uses 'foldl' because it is+ -- necessary to avoid blank lines from Hidden_commands, as groff+ -- translates them into annoying vertical padding (unlike TeX).+ synopsis :: [String]+ synopsis = foldl iter [] commandControlList+ where iter :: [String] -> CommandControl -> [String]+ iter acc (GroupName _) = acc+ iter acc (HiddenCommand _) = acc+ iter acc (CommandData (WrappedCommand c@SuperCommand {})) =+ acc ++ concatMap+ (render (commandName c ++ " "))+ (extractCommands (commandSubCommands c))+ iter acc (CommandData c) = acc ++ render "" c+ render :: String -> WrappedCommand -> [String]+ render prefix (WrappedCommand c) =+ [".B darcs " ++ prefix ++ commandName c] +++ map mangle_args (commandExtraArgHelp c) +++ -- In the output, we want each command to be on its own+ -- line, but we don't want blank lines between them.+ -- AFAICT this can only be achieved with the .br+ -- directive, which is probably a GNUism.+ [".br"]++ -- | As 'synopsis', but make each group a subsection (.SS), and+ -- include the help text for each command.+ commands :: [String]+ commands = foldl iter [] commandControlList+ where iter :: [String] -> CommandControl -> [String]+ iter acc (GroupName x) = acc ++ [".SS \"" ++ x ++ "\""]+ iter acc (HiddenCommand _) = acc+ iter acc (CommandData (WrappedCommand c@SuperCommand {})) =+ acc ++ concatMap+ (render (commandName c ++ " "))+ (extractCommands (commandSubCommands c))+ iter acc (CommandData c) = acc ++ render "" c+ render :: String -> WrappedCommand -> [String]+ render prefix (WrappedCommand c) =+ [".B darcs " ++ prefix ++ commandName c] +++ map mangle_args (commandExtraArgHelp c) +++ [".RS 4", escape $ commandHelp c, ".RE"]++ -- | Now I'm showing off: mangle the extra arguments of Darcs commands+ -- so as to use the ideal format for manpages, italic words and roman+ -- punctuation.+ mangle_args :: String -> String+ mangle_args s =+ ".RI " ++ unwords (map show (groupBy cmp $ map toLower $ gank s))+ where cmp x y = not $ xor (isAlphaNum x) (isAlphaNum y)+ xor x y = (x && not y) || (y && not x)+ gank (' ':'o':'r':' ':xs) = '|' : gank xs+ gank (x:xs) = x : gank xs+ gank [] = []++ environment :: [String]+ environment = ".SH ENVIRONMENT" : concat+ [(".SS \"" ++ andClauses ks ++ "\"") : map escape ds+ | (ks, ds) <- environmentHelp]++ escape :: String -> String+ escape = minus . bs -- Order is important+ where+ minus = replace "-" "\\-"+ bs = replace "\\" "\\\\"++ replace :: Eq a => [a] -> [a] -> [a] -> [a]+ replace _ _ [] = []+ replace find repl s =+ if find `isPrefixOf` s+ then repl ++ replace find repl (drop (length find) s)+ else head s : replace find repl (tail s)++markdownLines :: [String]+markdownLines =+ [ "Darcs " ++ version, ""+ , "# Commands", ""+ , unlines commands+ , "# Environment variables"+ , "", unlines environment+ , "# Patterns"+ , "", unlines helpOnMatchers ]+ where+ environment :: [String]+ environment = intercalate [""]+ [ renderEnv ks ds | (ks, ds) <- environmentHelp ]+ where+ renderEnv k d = ("## " ++ (intercalate ", " k)) : "" : d+ commands :: [String]+ commands = foldl iter [] commandControlList+ iter :: [String] -> CommandControl -> [String]+ iter acc (GroupName x) = acc ++ ["## " ++ x, ""]+ iter acc (HiddenCommand _) = acc+ iter acc (CommandData (WrappedCommand c@SuperCommand {})) =+ acc ++ concatMap+ (render (commandName c ++ " "))+ (extractCommands (commandSubCommands c))+ iter acc (CommandData c) = acc ++ render "" c+ render :: String -> WrappedCommand -> [String]+ render prefix (WrappedCommand c) =+ [ "### " ++ prefix ++ commandName c+ , "", "darcs " ++ prefix ++ commandName c ++ " [OPTION]... " +++ unwords (commandExtraArgHelp c)+ , "", commandDescription c+ , "", commandHelp c+ , "Options:", optionsMarkdown $ commandBasicOptions c+ , if null opts2 then ""+ else unlines ["Advanced Options:", optionsMarkdown opts2]+ ]+ where opts2 = commandAdvancedOptions c++environmentHelpEditor :: ([String], [String])+environmentHelpEditor = (["DARCS_EDITOR", "DARCSEDITOR", "VISUAL", "EDITOR"],[+ "To edit a patch description of email comment, Darcs will invoke an",+ "external editor. Your preferred editor can be set as any of the",+ "environment variables $DARCS_EDITOR, $DARCSEDITOR, $VISUAL or $EDITOR.",+ "If none of these are set, vi(1) is used. If vi crashes or is not",+ "found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are",+ "each tried in turn."])++environmentHelpPager :: ([String], [String])+environmentHelpPager = (["DARCS_PAGER", "PAGER"],[+ "Darcs will sometimes invoke a pager if it deems output to be too long",+ "to fit onscreen. Darcs will use the pager specified by $DARCS_PAGER",+ "or $PAGER. If neither are set, `less` will be used."])++environmentHelpTimeout :: ([String], [String])+environmentHelpTimeout = (["DARCS_CONNECTION_TIMEOUT"],[+ "Set the maximum time in seconds that darcs allows and connection to",+ "take. If the variable is not specified the default are 30 seconds. This",+ "option only works with curl."])++-- | There are two environment variables that we do not document:+-- - DARCS_USE_ISPRINT: deprecated, use DARCS_DONT_ESCAPE_ISPRINT.+-- - DARCS_TESTING_PREFS_DIR: used by the test suite to tell darcs+-- where to find its configuration files.
+ src/Darcs/UI/Commands/Init.hs view
@@ -0,0 +1,110 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Init ( initialize, initializeCmd ) where++import Prelude hiding ( (^) )+import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts, nodefaults, amNotInRepository, putInfo, formatPath )+import Darcs.UI.Flags ( DarcsFlag( WorkRepoDir ), withWorkingDir, patchFormat, runPatchIndex )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+ ( patchFormat, useWorkingDir, workingRepoDir, patchIndex, hashed+ , PatchFormat, WithWorkingDir, WithPatchIndex+ , StdCmdAction, Verbosity, UseCache, PatchFormat(..)+ )+import Darcs.UI.Options.All ( )+import Darcs.Util.Printer ( text )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Repository ( createRepository )++initializeDescription :: String+initializeDescription = "Make the current directory or the specified directory a repository."++initializeHelp :: String+initializeHelp =+ "The `darcs initialize` command turns the current directory into a\n" +++ "Darcs repository. Any existing files and subdirectories become\n" +++ "UNSAVED changes: record them with `darcs record --look-for-adds`.\n" +++ "\n" +++ "This command creates the `_darcs` directory, which stores version\n" +++ "control metadata. It also contains per-repository settings in\n" +++ "`_darcs/prefs/`, which you can read about in the user manual.\n" +++ "\n" +++ "By default, patches of the new repository are in the darcs-2 semantics.\n" +++ "However it is possible to create a repository in darcs-1 semantics with\n" +++ "the flag `--darcs-1`, althought this is not recommended except for sharing\n" +++ "patches with a project that uses patches in the darcs-1 semantics.\n" +++ "\n" +++ "Initialize is commonly abbreviated to `init`.\n"++initBasicOpts :: DarcsOption a (O.PatchFormat -> O.WithWorkingDir -> Maybe String -> a)+initBasicOpts = O.patchFormat ^ O.useWorkingDir ^ O.workingRepoDir++initAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> () -> a)+initAdvancedOpts = O.patchIndex ^ O.hashed++initOpts :: DarcsOption a+ (O.PatchFormat+ -> O.WithWorkingDir+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.WithPatchIndex+ -> ()+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+initOpts = initBasicOpts `withStdOpts` initAdvancedOpts++initialize :: DarcsCommand [DarcsFlag]+initialize = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "initialize"+ , commandHelp = initializeHelp+ , commandDescription = initializeDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[<DIRECTORY>]"]+ , commandPrereq = \_ -> return $ Right ()+ , commandCommand = initializeCmd+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc initAdvancedOpts+ , commandBasicOptions = odesc initBasicOpts+ , commandDefaults = defaultFlags initOpts+ , commandCheckOptions = ocheck initOpts+ , commandParseOptions = onormalise initOpts+ }++initializeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+initializeCmd aps opts [outname] | null [ () | WorkRepoDir _ <- opts ] =+ initializeCmd aps (WorkRepoDir outname:opts) []+initializeCmd _ opts [] = do+ location <- amNotInRepository opts+ case location of+ Left msg -> fail $ "Unable to " ++ formatPath ("darcs " ++ commandName initialize)+ ++ " here.\n\n" ++ msg+ Right () -> do+ createRepository (patchFormat opts == O.PatchFormat1) (withWorkingDir opts) (runPatchIndex opts)+ putInfo opts $ text "Repository initialized."+initializeCmd _ _ _ = fail "You must provide 'initialize' with either zero or one argument."
+ src/Darcs/UI/Commands/Log.hs view
@@ -0,0 +1,469 @@+-- Copyright (C) 2003-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, PatternGuards #-}+++module Darcs.UI.Commands.Log+ ( changes, log+ , changelog, getLogInfo+ ) where++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 ((<$>))++import Darcs.UI.PrintPatch ( showFriendly )+import Darcs.Patch.PatchInfoAnd ( fmapFLPIAP, hopefullyM, info )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, findRepository )+import Darcs.UI.External ( viewDocWith )+import Darcs.UI.Flags+ ( DarcsFlag(GenContext, HumanReadable,+ MachineReadable, Count, Interactive,+ NumberPatches, XMLOutput, Summary,+ Verbose, Debug, NoPatchIndexFlag)+ , doReverse, showChangesOnlyToFiles+ , useCache, maxCount, umask+ , verbosity, isUnified, isInteractive, diffAlgorithm, hasSummary+ , fixSubPaths, getRepourl )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Path ( SubPath(), toFilePath,+ fp2fn, fn2fp, normPath, AbsolutePath )+import Darcs.Repository ( PatchSet, PatchInfoAnd,+ withRepositoryDirectory, RepoJob(..),+ readRepo, unrecordedChanges,+ withRepoLockCanFail )+import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(MyersDiff), UpdateWorking(..) )+import Darcs.Patch.Set ( PatchSet(..), newset2RL )+import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.FileHunk ( IsHunk )+import Darcs.Patch.Info ( toXml, showPatchInfo, escapeXML, PatchInfo )+import Darcs.Patch.Depends ( findCommonWithThem )+import Darcs.Patch.Bundle( contextPatches )+import Darcs.Patch.Prim ( PrimPatchBase )+import Darcs.Patch.Show ( ShowPatch )+import Darcs.Patch.TouchesFiles ( lookTouch )+import Darcs.Patch.Type ( PatchType(PatchType) )+import Darcs.Patch.Apply ( Apply, ApplyState )+import Darcs.Patch ( invert, xmlSummary, description,+ effectOnFilePaths, listTouchedFiles )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+ ( FL(NilFL), RL(..), filterOutFLFL, filterRL,+ reverseFL, (:>)(..), mapRL )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2, Sealed(..), seal2 )+import Darcs.Patch.Match+ ( MatchFlag+ , firstMatch+ , secondMatch+ , matchAPatchread+ , haveNonrangeMatch+ , matchFirstPatchset+ , matchSecondPatchset+ )+import Darcs.Patch.Matchable ( Matchable )+import Darcs.Util.Printer ( Doc, simplePrinters, (<+>), prefix, text, vcat,+ vsep, (<>), ($$), errorDoc, insertBeforeLastline, empty, RenderMode(..) )+import Darcs.Util.Printer.Color ( fancyPrinters )+import Darcs.Util.Progress ( setProgressMode, debugMessage )+import Darcs.UI.SelectChanges ( viewChanges )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.Repository.PatchIndex ( PatchFilter, maybeFilterPatches, attemptCreatePatchIndex )+import Storage.Hashed.Tree( Tree )++logHelp :: String+logHelp =+ "The `darcs log` command lists the patches that constitute the\n" +++ "current repository or, with `--repo`, a remote repository. Without\n" +++ "options or arguments, ALL patches will be listed.\n" +++ "\n" ++ logHelp' +++ "\n" ++ logHelp''++logBasicOpts :: DarcsOption a+ ([O.MatchFlag]+ -> Maybe Int+ -> Bool+ -> Maybe O.ChangesFormat+ -> Maybe O.Summary+ -> Bool+ -> Maybe String+ -> Maybe String+ -> Maybe Bool+ -> a)+logBasicOpts+ = O.matchSeveralOrRange+ ^ O.matchMaxcount+ ^ O.onlyToFiles+ ^ O.changesFormat+ ^ O.summary+ ^ O.changesReverse+ ^ O.possiblyRemoteRepo+ ^ O.workingRepoDir+ ^ O.interactive -- False++logAdvancedOpts :: DarcsOption a (O.NetworkOptions -> O.WithPatchIndex -> a)+logAdvancedOpts = O.network ^ O.patchIndexYes++logOpts :: DarcsOption a+ ([O.MatchFlag]+ -> Maybe Int+ -> Bool+ -> Maybe O.ChangesFormat+ -> Maybe O.Summary+ -> Bool+ -> Maybe String+ -> Maybe String+ -> Maybe Bool+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.NetworkOptions+ -> O.WithPatchIndex+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+logOpts = logBasicOpts `withStdOpts` logAdvancedOpts++log :: DarcsCommand [DarcsFlag]+log = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "log"+ , commandHelp = logHelp+ , commandDescription = "List patches in the repository."+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+ , commandGetArgPossibilities = return []+ , commandCommand = logCmd+ , commandPrereq = findRepository+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc logAdvancedOpts+ , commandBasicOptions = odesc logBasicOpts+ , commandDefaults = defaultFlags logOpts+ , commandCheckOptions = ocheck logOpts+ , commandParseOptions = onormalise logOpts+ }++logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+logCmd fps opts args+ | GenContext `elem` opts = if not . null $ args+ then fail "log --context cannot accept other arguments"+ else logContext opts+ | null args = showLog opts Nothing+ | otherwise = do+ fs <- fixSubPaths fps args+ case fs of+ [] -> putStrLn "No valid arguments were given, nothing to do."+ _ -> do unless (Interactive `elem` opts)+ $ unless (NoPatchIndexFlag `elem` opts)+ $ withRepoLockCanFail (useCache opts) YesUpdateWorking (umask opts)+ $ RepoJob attemptCreatePatchIndex+ showLog opts . Just . nub $ sort fs++showLog :: [DarcsFlag] -> Maybe [SubPath] -> IO ()+showLog opts files =+ let repodir = fromMaybe "." (getRepourl opts) in+ withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repository -> do+ unless (Debug `elem` opts) $ setProgressMode False+ Sealed unrec <- case files of+ Nothing -> return $ Sealed NilFL+ Just _ -> Sealed `fmap` unrecordedChanges (UseIndex, ScanKnown, MyersDiff) repository files+ `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+ filtered_changes p =+ maybe_reverse <$>+ getLogInfo+ (maxCount opts)+ (parseFlags O.matchSeveralOrRange opts)+ (showChangesOnlyToFiles opts)+ recFiles+ (maybeFilterPatches repository)+ p+ debugMessage "About to read the repository..."+ patches <- readRepo repository+ debugMessage "Done reading the repository."+ if Interactive `elem` opts+ then do (fp_and_fs, _, _) <- filtered_changes patches+ let fp = map fst fp_and_fs+ viewChanges (logPatchSelOpts opts) fp+ else do let header = if isJust files && XMLOutput `notElem` opts+ then text $ "Changes to "++unwords (fromJust recFiles)++":\n"+ else empty+ debugMessage "About to print the changes..."+ let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters+ ps <- readRepo repository -- read repo again to prevent holding onto+ -- values forced by filtered_changes+ logOutput <- changelog opts ps `fmap` filtered_changes patches+ viewDocWith printers Encode $ header $$ logOutput+ where maybe_reverse (xs,b,c) = if doReverse opts+ then (reverse xs, b, c)+ else (xs, b, c)+++-- FIXME: this prose is unreadable. --twb, 2009-08+logHelp' :: String+logHelp' =+ "When given one or more files or directories as arguments, only\n" +++ "patches which affect those files or directories are listed. This\n" +++ "includes changes that happened to files before they were moved or\n" +++ "renamed.\n" +++ "\n" +++ "When given a `--from-tag`, `--from-patch` or `--from-match`, only changes\n" +++ "since that tag or patch are listed. Similarly, the `--to-tag`,\n" +++ "`--to-patch` and `--to-match` options restrict the list to older patches.\n" +++ "\n" +++ "The `--last` and `--max-count` options both limit the number of patches\n" +++ "listed. The former applies BEFORE other filters, whereas the latter\n" +++ "applies AFTER other filters. For example `darcs log foo.c\n" +++ "--max-count 3` will print the last three patches that affect foo.c,\n" +++ "whereas `darcs log --last 3 foo.c` will, of the last three\n" +++ "patches, print only those that affect foo.c.\n"++getLogInfo :: forall p wX wY+ . (Matchable p, ApplyState p ~ Tree)+ => Maybe Int -> [MatchFlag] -> Bool+ -> Maybe [FilePath]+ -> PatchFilter p+ -> PatchSet p wX wY+ -> IO ( [(Sealed2 (PatchInfoAnd p), [FilePath])]+ , [(FilePath, FilePath)]+ , Maybe Doc )+getLogInfo maxCountFlag matchFlags onlyToFilesFlag plain_fs patchFilter ps =+ case (sp1s, sp2s) of+ (Sealed p1s, Sealed p2s) ->+ case findCommonWithThem p2s p1s of+ _ :> us ->+ let ps' = filterRL pf (reverseFL us) in+ case plain_fs of+ Nothing -> return $ foldr (\x xs -> (x, []) -:- xs) ([], [], Nothing) $+ maybe id take maxCountFlag ps'+ Just fs -> let fs' = map (\x -> "./" ++ x) fs in do+ filterOutUnrelatedChanges <$> do+ ps'' <- patchFilter fs' ps'+ return $ filterPatchesByNames maxCountFlag fs' ps''+ where+ sp1s = if firstMatch matchFlags+ then matchFirstPatchset matchFlags ps+ else Sealed $ PatchSet NilRL NilRL+ sp2s = if secondMatch matchFlags+ then matchSecondPatchset matchFlags ps+ else Sealed ps+ pf = if haveNonrangeMatch (PatchType :: PatchType p) matchFlags+ then matchAPatchread matchFlags+ else \_ -> True++ filterOutUnrelatedChanges (pfs, renames, doc)+ | onlyToFilesFlag = (map onlyRelated pfs, renames, doc)+ | otherwise = (pfs, renames, doc)++ onlyRelated (Sealed2 p, fs) =+ (Sealed2 $ fmapFLPIAP (filterOutFLFL (unrelated fs)) p, fs)++ unrelated fs p+ -- If the change does not affect the patches we are looking at,+ -- we ignore the difference between the two states.+ | null $ fs `intersect` listTouchedFiles p = unsafeCoerce IsEq+ | otherwise = NotEq++-- | Take a list of filenames and patches and produce a list of patches that+-- actually touch the given files with a list of touched file names, a list of+-- original-to-current filepath mappings, indicating the original names of the+-- affected files and possibly an error. Additionaly, the function takes a+-- "depth limit" -- maxcount, that could be Nothing (return everything) or+-- "Just n" -- returns at most n patches touching the file (starting from the+-- beginning of the patch list).+filterPatchesByNames+ :: forall p+ . (Matchable p, ApplyState p ~ Tree)+ => Maybe Int -- ^ maxcount+ -> [FilePath] -- ^ filenames+ -> [Sealed2 (PatchInfoAnd p)] -- ^ patchlist+ -> ([(Sealed2 (PatchInfoAnd p),[FilePath])], [(FilePath, FilePath)], Maybe Doc)+filterPatchesByNames maxcount fns patches = removeNonRenames $+ evalState (filterPatchesByNames' fns patches) (maxcount, initRenames) where+ removeNonRenames (ps, renames, doc) = (ps, removeIds renames, doc)+ removeIds = filter $ uncurry (/=)+ initRenames = map (\x -> (x, x)) fns+ returnFinal = (\renames -> ([], renames, Nothing)) <$> gets snd+ filterPatchesByNames' [] _ = returnFinal+ filterPatchesByNames' _ [] = returnFinal+ filterPatchesByNames' fs (s2hp@(Sealed2 hp) : ps) = do+ (count, renames) <- get+ let stopNow = case count of+ Nothing -> False+ Just c -> c <= 0+ if stopNow+ then returnFinal+ else case hopefullyM hp of+ Nothing -> do+ let err = text "Can't find changes prior to:"+ $$ showPatchInfo (info hp)+ return ([], renames, Just err)+ Just p ->+ case lookTouch (Just renames) fs (invert p) of+ (True, affected, [], renames') ->+ return ([(s2hp, affected)], renames', Nothing)+ (True, affected, fs', renames') -> do+ let sub1Mb c = subtract 1 <$> c+ modify $ \(c, _) -> (sub1Mb c, renames')+ rest <- filterPatchesByNames' fs' ps+ return $ (s2hp, affected) -:- rest+ (False, _, fs', renames') -> do+ modify $ second (const renames')+ filterPatchesByNames' fs' ps++-- | Note, lazy pattern matching is required to make functions like+-- filterPatchesByNames lazy in case you are only not interested in+-- the first element. E.g.:+--+-- let (fs, _, _) = filterPatchesByNames ...+(-:-) :: a -> ([a],b,c) -> ([a],b,c)+x -:- ~(xs,y,z) = (x:xs,y,z)++changelog :: forall p wStart wX+ . ( Apply p, ApplyState p ~ Tree, ShowPatch p, IsHunk p+ , PrimPatchBase p, PatchListFormat p+ , Conflict p, CommuteNoConflicts p+ )+ => [DarcsFlag] -> PatchSet p wStart wX+ -> ([(Sealed2 (PatchInfoAnd p), [FilePath])], [(FilePath, FilePath)], Maybe Doc)+ -> Doc+changelog opts patchset (pis_and_fs, createdAsFs, mbErr)+ | Count `elem` opts = text $ show $ length pis_and_fs+ | MachineReadable `elem` opts =+ maybe (vsep $ map (unseal2 (showPatchInfo.info)) pis) errorDoc mbErr+ | XMLOutput `elem` opts =+ text "<changelog>"+ $$ vcat created_as_xml+ $$ vcat actual_xml_changes+ $$ text "</changelog>"+ | Summary `elem` opts || Verbose `elem` opts =+ mbAppendErr $ vsep (map (number_patch change_with_summary) pis)+ | otherwise = mbAppendErr $ vsep (map (number_patch description') pis)+ where mbAppendErr = maybe id (\err -> ($$ err)) mbErr+ change_with_summary :: Sealed2 (PatchInfoAnd p) -> Doc+ change_with_summary (Sealed2 hp)+ | Just p <- hopefullyM hp = showFriendly (verbosity opts) (hasSummary O.NoSummary opts) p+ | otherwise = description hp+ $$ indent (text "[this patch is unavailable]")++ xml_with_summary (Sealed2 hp)+ | Just p <- hopefullyM hp = insertBeforeLastline+ (toXml $ info hp) (indent $ xmlSummary p)+ xml_with_summary (Sealed2 hp) = toXml (info hp)+ indent = prefix " "+ actual_xml_changes = if Summary `elem` opts+ then map xml_with_summary pis+ else map (toXml . unseal2 info) pis++ created_as_xml = map create createdAsFs where+ create rename@(_, as) = createdAsXml (first_change_of as) rename+ -- We need to reorder the patches when they haven't been reversed+ -- already, so that we find the *first* patch that modifies a given+ -- file, not the last (by default, the list is oldest->newest).+ reorderer = if not (doReverse opts) then reverse else id+ oldest_first_pis_and_fs = reorderer pis_and_fs+ couldnt_find fn = error $ "Couldn't find first patch affecting " +++ fn ++ " in pis_and_fs"+ mb_first_change_of fn = find ((fn `elem`) . snd) oldest_first_pis_and_fs+ find_first_change_of fn = fromMaybe (couldnt_find fn)+ (mb_first_change_of fn)+ first_change_of = unseal2 info . fst . find_first_change_of+ number_patch f x = if NumberPatches `elem` opts+ then case get_number x of+ Just n -> text (show n++":") <+> f x+ Nothing -> f x+ else f x+ get_number :: Sealed2 (PatchInfoAnd p) -> Maybe Int+ get_number (Sealed2 y) = gn 1 (newset2RL patchset)+ where iy = info y+ gn :: Int -> RL (PatchInfoAnd p) wStart wY -> Maybe Int+ gn n (b:<:bs) | seq n (info b) == iy = Just n+ | otherwise = gn (n+1) bs+ gn _ NilRL = Nothing+ pis = map fst pis_and_fs+ description' = unseal2 description++-- FIXME: this prose is unreadable. --twb, 2009-08+logHelp'' :: String+logHelp'' =+ "Three output formats exist. The default is `--human-readable`. You can\n" +++ "also select `--context`, which is the internal format (as seen in patch\n" +++ "bundles) that can be re-read by Darcs (e.g. `darcs get --context`).\n" +++ "\n" +++ "Finally, there is `--xml-output`, which emits valid XML... unless a the\n" +++ "patch metadata (author, name or description) contains a non-ASCII\n" +++ "character and was recorded in a non-UTF8 locale.\n" +++ "\n" +++ -- FIXME: can't we just disallow the following usage?+ "Note that while the `--context` flag may be used in conjunction with\n" +++ "`--xml-output` or `--human-readable`, in neither case will darcs get be\n" +++ "able to read the output. On the other hand, sufficient information\n" +++ "WILL be output for a knowledgeable human to recreate the current state\n" +++ "of the repository.\n"++logContext :: [DarcsFlag] -> IO ()+logContext opts = do+ let repodir = fromMaybe "." $ getRepourl opts+ withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repository -> do+ (_ :> ps') <- contextPatches `fmap` readRepo repository+ let ps = mapRL (\p -> (seal2 p, [])) ps'+ let header = if fancy then empty else text "\nContext:\n"+ let logOutput = changelog opts' emptyset (ps, [], Nothing)+ viewDocWith simplePrinters Encode $ header $$ logOutput+ where opts' = if fancy then opts else MachineReadable : opts+ fancy = HumanReadable `elem` opts || XMLOutput `elem` opts+ emptyset = PatchSet NilRL NilRL++-- | changes is an alias for log+changes :: DarcsCommand [DarcsFlag]+changes = commandAlias "changes" Nothing log++createdAsXml :: PatchInfo -> (String, String) -> Doc+createdAsXml pinfo (current, createdAs) =+ text "<created_as current_name='"+ <> escapeXML current+ <> text "' original_name='"+ <> escapeXML createdAs+ <> text "'>"+ $$ toXml pinfo+ $$ text "</created_as>"++logPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+logPatchSelOpts flags = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = parseFlags O.matchSeveralOrRange flags+ , S.diffAlgorithm = diffAlgorithm flags+ , S.interactive = isInteractive flags+ , S.selectDeps = O.PromptDeps -- option not supported, use default+ , S.summary = hasSummary O.NoSummary flags+ , S.withContext = isUnified flags+ }
+ src/Darcs/UI/Commands/MarkConflicts.hs view
@@ -0,0 +1,163 @@+-- Copyright (C) 2002-2003,2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.UI.Commands.MarkConflicts ( markconflicts ) where++import Prelude hiding ( (^), catch )++import System.Exit ( exitSuccess )+import Data.List.Ordered ( nubSort )+import Control.Monad ( when, unless )+import Control.Exception ( catch, IOException )++import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Util.Printer( putDocLn, putDocLnWith, text, redText, ($$) )+import Darcs.Util.Printer.Color (fancyPrinters)++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Flags ( DarcsFlag, diffingOpts, verbosity, dryRun, umask, useCache )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( UpdateWorking (..) )+import Darcs.Repository ( withRepoLock, RepoJob(..), addToPending,+ applyToWorking,+ readRepo, unrecordedChanges, Repository+ )+import Darcs.Patch ( invert, PrimOf, listTouchedFiles )+import Darcs.Patch.Witnesses.Ordered ( FL(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Repository.Resolution ( patchsetConflictResolutions )+#include "impossible.h"++markconflictsDescription :: String+markconflictsDescription =+ "Mark unresolved conflicts in working tree, for manual resolution."++markconflictsHelp :: String+markconflictsHelp = unlines+ ["Darcs requires human guidance to unify changes to the same part of a"+ ,"source file. When a conflict first occurs, darcs will add the"+ ,"initial state and both choices to the working tree, delimited by the"+ ,"markers `v v v`, `=====`, `* * *` and `^ ^ ^`, as follows:"+ ,""+ ," v v v v v v v"+ ," Initial state."+ ," ============="+ ," First choice."+ ," *************"+ ," Second choice."+ ," ^ ^ ^ ^ ^ ^ ^"+ ,""+ ,"However, you might revert or manually delete these markers without"+ ,"actually resolving the conflict. In this case, `darcs mark-conflicts`"+ ,"is useful to show where are the unresolved conflicts. It is also"+ ,"useful if `darcs apply` is called with `--apply-conflicts`,"+ ,"where conflicts aren't marked initially."+ ,""+ ,"Unless you use the `--dry-run` flag, any unrecorded changes to the"+ ,"working tree WILL be lost forever when you run this command!"+ ,"You will be prompted for confirmation before this takes place."+ ]++markconflictsBasicOpts :: DarcsOption a+ (O.UseIndex+ -> Maybe String+ -> O.DiffAlgorithm+ -> O.DryRun+ -> O.XmlOutput+ -> a)+markconflictsBasicOpts+ = O.useIndex+ ^ O.workingRepoDir+ ^ O.diffAlgorithm+ ^ O.dryRunXml++markconflictsAdvancedOpts :: DarcsOption a (O.UMask -> a)+markconflictsAdvancedOpts = O.umask++markconflictsOpts :: DarcsOption a+ (O.UseIndex+ -> Maybe String+ -> O.DiffAlgorithm+ -> O.DryRun+ -> O.XmlOutput+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UMask+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+markconflictsOpts = markconflictsBasicOpts `withStdOpts` markconflictsAdvancedOpts++markconflicts :: DarcsCommand [DarcsFlag]+markconflicts = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "mark-conflicts"+ , commandHelp = markconflictsHelp+ , commandDescription = markconflictsDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = markconflictsCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc markconflictsAdvancedOpts+ , commandBasicOptions = odesc markconflictsBasicOpts+ , commandDefaults = defaultFlags markconflictsOpts+ , commandCheckOptions = ocheck markconflictsOpts+ , commandParseOptions = onormalise markconflictsOpts+ }++markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+markconflictsCmd _ opts [] = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(repository :: Repository p wR wU wR) -> do+ pend <- unrecordedChanges (diffingOpts opts) repository Nothing+ r <- readRepo repository+ Sealed res <- return $ patchsetConflictResolutions r+ case nubSort $ listTouchedFiles res of+ [] -> putStrLn "No conflicts to mark." >> exitSuccess+ cfs -> putDocLnWith fancyPrinters $+ redText "Conflicts found in the following files:" $$ text (unlines cfs)+ when (dryRun opts == O.YesDryRun) $ do+ putDocLn $ text "Conflicts will not be marked: this is a dry run."+ exitSuccess+ let undoUnrec :: FL (PrimOf p) wR wU -> IO (Repository p wR wR wR)+ undoUnrec NilFL = return repository+ undoUnrec pend' =+ do putStrLn ("This will trash any unrecorded changes"+++ " in the working directory.")+ confirmed <- promptYorn "Are you sure? "+ unless confirmed exitSuccess+ applyToWorking repository (verbosity opts) (invert pend') `catch` \(e :: IOException) ->+ bug ("Can't undo pending changes!" ++ show e)+ repository' <- undoUnrec pend+ withSignalsBlocked $+ do addToPending repository' YesUpdateWorking res+ _ <- applyToWorking repository' (verbosity opts) res `catch` \(e :: IOException) ->+ bug ("Problem marking conflicts in mark-conflicts!" ++ show e)+ return ()+ putStrLn "Finished marking conflicts."+markconflictsCmd _ _ _ = impossible
+ src/Darcs/UI/Commands/Move.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE RankNTypes #-}+-- Copyright (C) 2002-2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.UI.Commands.Move ( move, mv ) where++import Prelude hiding ( (^) )++import Control.Applicative ( (<$>) )+import Control.Monad ( when, unless, forM_, forM )+import Data.Maybe ( fromMaybe )+import Darcs.Util.SignalHandler ( withSignalsBlocked )++import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, amInHashedRepository )+import Darcs.UI.Flags ( DarcsFlag(Quiet)+ , doAllowCaseOnly, doAllowWindowsReserved, useCache, dryRun, umask+ , maybeFixSubPaths, fixSubPaths )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Diff ( treeDiff )+import Darcs.Repository.Flags ( UpdateWorking (..), DiffAlgorithm(..) )+import Darcs.Repository.Prefs ( filetypeFunction )+import System.FilePath.Posix ( (</>), takeFileName )+import System.Directory ( renameDirectory )+import Darcs.Repository.State ( readRecordedAndPending, readRecorded, updateIndex )+import Darcs.Repository+ ( Repository+ , withRepoLock+ , RepoJob(..)+ , addPendingDiffToPending+ , listFiles+ )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) )+import Darcs.Patch.Witnesses.Sealed ( emptyGap, freeGap, joinGap, FreeLeft )+import Darcs.Util.Global ( debugMessage )+import qualified Darcs.Patch+import Darcs.Patch ( RepoPatch, PrimPatch )+import Darcs.Patch.Apply( ApplyState )+import Data.List ( nub, sort )+import qualified System.FilePath.Windows as WindowsFilePath++import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase, treeHasFile )+import Storage.Hashed.Tree( Tree, modifyTree )+import Storage.Hashed.Plain( readPlainTree )+import Darcs.Util.Path+ ( floatPath+ , fp2fn+ , fn2fp+ , superName+ , SubPath()+ , toFilePath+ , AbsolutePath+ )+import Darcs.Util.Workaround ( renameFile )++moveDescription :: String+moveDescription = "Move or rename files."++moveHelp :: String+moveHelp =+ "Darcs cannot reliably distinguish between a file being deleted and a\n" +++ "new one added, and a file being moved. Therefore Darcs always assumes\n" +++ "the former, and provides the `darcs mv` command to let Darcs know when\n" +++ "you want the latter. This command will also move the file in the\n" +++ "working tree (unlike `darcs remove`), unless it has already been moved.\n" +++ "\n" +++ -- Note that this paragraph is very similar to one in ./Add.lhs.+ "Darcs will not rename a file if another file in the same folder has\n" +++ "the same name, except for case. The `--case-ok` option overrides this\n" +++ "behaviour. Windows and OS X usually use filesystems that do not allow\n" +++ "files a folder to have the same name except for case (for example,\n" +++ "`ReadMe` and `README`). If `--case-ok` is used, the repository might be\n" +++ "unusable on those systems!\n"++moveBasicOpts :: DarcsOption a (Bool -> Bool -> Maybe String -> a)+moveBasicOpts = O.allowProblematicFilenames ^ O.workingRepoDir++moveAdvancedOpts :: DarcsOption a (O.UMask -> a)+moveAdvancedOpts = O.umask++moveOpts :: DarcsOption a+ (Bool+ -> Bool+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UMask+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+moveOpts = moveBasicOpts `withStdOpts` moveAdvancedOpts++move :: DarcsCommand [DarcsFlag]+move = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "move"+ , commandHelp = moveHelp+ , commandDescription = moveDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["<SOURCE> ... <DESTINATION>"]+ , commandCommand = moveCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = listFiles False+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc moveAdvancedOpts+ , commandBasicOptions = odesc moveBasicOpts+ , commandDefaults = defaultFlags moveOpts+ , commandCheckOptions = ocheck moveOpts+ , commandParseOptions = onormalise moveOpts+ }++moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+moveCmd fps opts args+ | length args < 2 =+ fail "The `darcs move' command requires at least two arguments."+ | length args == 2 = do+ xs <- maybeFixSubPaths fps args+ case xs of+ [Just from, Just to]+ | from == to -> fail "Cannot rename a file or directory onto itself!"+ | toFilePath from == "" -> fail "Cannot move the root of the repository"+ | otherwise -> moveFile opts from to+ _ -> fail "Both source and destination must be valid."+ | otherwise = let (froms, to) = (init args, last args) in do+ x <- head <$> maybeFixSubPaths fps [to]+ case x of+ Nothing -> fail "Invalid destination directory."+ Just to' -> do+ xs <- nub . sort <$> fixSubPaths fps froms+ if to' `elem` xs+ then fail "Cannot rename a file or directory onto itself!"+ else case xs of+ [] -> fail "Nothing to move."+ froms' -> moveFilesToDir opts froms' to'++data FileKind = Dir | File+ deriving (Show, Eq)++data FileStatus =+ Nonexistant+ | Unadded FileKind+ | Shadow FileKind -- ^ known to darcs, but absent in working copy+ | Known FileKind+ deriving Show++fileStatus :: Tree IO -- ^ tree of the working directory+ -> Tree IO -- ^ tree of recorded and pending changes+ -> Tree IO -- ^ tree of recorded changes+ -> FilePath+ -> IO FileStatus+fileStatus work cur recorded fp = do+ existsInCur <- treeHas cur fp+ existsInRec <- treeHas recorded fp+ existsInWork <- treeHas work fp+ case (existsInRec, existsInCur, existsInWork) of+ (_, True, True) -> do+ isDirCur <- treeHasDir cur fp+ isDirWork <- treeHasDir work fp+ unless (isDirCur == isDirWork) . fail $ "don't know what to do with " ++ fp+ return . Known $ if isDirCur then Dir else File++ (_, False, True) -> do+ isDir <- treeHasDir work fp+ if isDir+ then return $ Unadded Dir+ else return $ Unadded File+ (False, False, False) -> return Nonexistant+ (_, _, False) -> do+ isDir <- treeHasDir cur fp+ if isDir+ then return $ Shadow Dir+ else return $ Shadow File++-- | Takes two filenames (as 'Subpath'), and tries to move the first+-- into/onto the second. Needs to guess what that means: renaming or moving+-- into a directory, and whether it is a post-hoc move.+moveFile :: [DarcsFlag] -> SubPath -> SubPath -> IO ()+moveFile opts old new = withRepoAndState opts $ \(repo, work, cur, recorded) -> do+ let old_fp = toFilePath old+ new_fp = toFilePath new+ new_fs <- fileStatus work cur recorded new_fp+ old_fs <- fileStatus work cur recorded old_fp+ let doSimpleMove = simpleMove repo opts cur work old_fp new_fp+ case (old_fs, new_fs) of+ (Nonexistant, _) -> fail $ old_fp ++ " does not exist."+ (Unadded k, _) -> fail $ show k ++ " " ++ old_fp ++ " is unadded."+ (Known _, Nonexistant) -> doSimpleMove+ (Known _, Shadow _) -> doSimpleMove+ (_, Nonexistant) -> fail $ old_fp ++ " is not in the repository."+ (Known _, Known Dir) -> moveToDir repo opts cur work [old_fp] new_fp+ (Known _, Unadded Dir) -> fail $+ new_fp ++ " is not known to darcs; please add it to the repository."+ (Known _, _) -> fail $ new_fp ++ " already exists."+ (Shadow k, Unadded k') | k == k' -> doSimpleMove+ (Shadow File, Known Dir) -> moveToDir repo opts cur work [old_fp] new_fp+ (Shadow Dir, Known Dir) -> doSimpleMove+ (Shadow File, Known File) -> doSimpleMove+ (Shadow k, _) -> fail $+ "cannot move " ++ show k ++ " " ++ old_fp ++ " into " ++ new_fp+ ++ " : " ++ "did you already move it elsewhere?"++moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO ()+moveFilesToDir opts froms to = withRepoAndState opts $ \(repo, work, cur, _) ->+ moveToDir repo opts cur work (map toFilePath froms) $ toFilePath to++withRepoAndState :: [DarcsFlag]+ -> (forall p wR wU .+ (ApplyState p ~ Tree, RepoPatch p) =>+ (Repository p wR wU wR, Tree IO, Tree IO, Tree IO)+ -> IO ())+ -> IO ()+withRepoAndState opts f =+ withRepoLock dr uc YesUpdateWorking um $ RepoJob $ \repo -> do+ work <- readPlainTree "."+ cur <- readRecordedAndPending repo+ recorded <- readRecorded repo+ f (repo, work, cur, recorded)+ where+ dr = dryRun opts+ uc = useCache opts+ um = umask opts++simpleMove :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT+ -> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath+ -> IO ()+simpleMove repository opts cur work old_fp new_fp = do+ doMoves repository opts cur work [(old_fp, new_fp)]+ unless (Quiet `elem` opts) $+ putStrLn $ unwords ["Moved:", old_fp, "to:", new_fp]++moveToDir :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT+ -> [DarcsFlag] -> Tree IO -> Tree IO -> [FilePath] -> FilePath+ -> IO ()+moveToDir repository opts cur work moved finaldir = do+ let movetargets = map ((finaldir </>) . takeFileName) moved+ moves = zip moved movetargets+ doMoves repository opts cur work moves+ unless (Quiet `elem` opts) $+ putStrLn $ unwords $ ["Moved:"] ++ moved ++ ["to:", finaldir]++doMoves :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT+ -> [DarcsFlag] -> Tree IO -> Tree IO+ -> [(FilePath, FilePath)] -> IO ()+doMoves repository opts cur work moves = do+ patches <- forM moves $ \(old, new) -> do+ prePatch <- generatePreMovePatches opts cur work (old,new)+ return (prePatch, old, new)+ withSignalsBlocked $ do+ forM_ patches $ \(prePatch, old, new) -> do+ let -- Add any pre patches before the move patch+ pendingDiff = joinGap (+>+)+ (fromMaybe (emptyGap NilFL) prePatch)+ (freeGap $ Darcs.Patch.move old new :>: NilFL)+ addPendingDiffToPending repository YesUpdateWorking pendingDiff+ moveFileOrDir work old new+ updateIndex repository++-- Take the recorded/ working trees and the old and intended new filenames;+-- check if the new path is safe on windows. We potentially need to create+-- extra patches that are required to keep the repository consistent, in order+-- to allow the move patch to be applied.+generatePreMovePatches :: PrimPatch prim => [DarcsFlag] -> Tree IO -> Tree IO+ -> (FilePath, FilePath)+ -> IO (Maybe (FreeLeft (FL prim)))+generatePreMovePatches opts cur work (old,new) = do+ -- Only allow Windows-invalid paths if we've been told to do so+ unless newIsOkWindowsPath $ fail newNotOkWindowsPathMsg+ -- Check if the first directory above the new path is in the repo (this+ -- is the new path if itself is a directory), handling the case where+ -- a user moves a file into a directory not known by darcs.+ let dirPath = fn2fp $ superName $ fp2fn new+ haveNewParent <- treeHasDir cur dirPath+ unless haveNewParent $+ fail $ "The target directory " ++ dirPath+ ++ " isn't known in the repository, did you forget to add it?"+ newInRecorded <- hasNew cur+ newInWorking <- hasNew work+ oldInWorking <- treeHas work old+ if oldInWorking -- We need to move the object+ then do+ -- We can't move if the target already exists in working+ when newInWorking $ fail $ alreadyExists "working directory"+ if newInRecorded+ then Just <$> deleteNewFromRepoPatches+ else return Nothing+ else do+ unless (Quiet `elem` opts) $+ putStrLn "Detected post-hoc move."+ -- Post-hoc move - user has moved/deleted the file in working, so+ -- we can hopefully make a move patch to make the repository+ -- consistent.+ -- If we don't have the old or new in working, we're stuck+ unless newInWorking $+ fail $ "Cannot determine post-hoc move target, "+ ++ "no file/dir named:\n" ++ new+ Just <$> if newInRecorded+ then deleteNewFromRepoPatches+ else return $ emptyGap NilFL+ where+ newIsOkWindowsPath =+ doAllowWindowsReserved opts || WindowsFilePath.isValid new++ newNotOkWindowsPathMsg =+ "The filename " ++ new ++ " is not valid under Windows.\n"+ ++ "Use --reserved-ok to allow such filenames."++ -- If we're moving to a file/dir that was recorded, but has been deleted,+ -- we need to add patches to pending that remove the original.+ deleteNewFromRepoPatches = do+ unless (Quiet `elem` opts) $+ putStrLn $ "Existing recorded contents of " ++ new+ ++ " will be overwritten."+ ftf <- filetypeFunction+ let curNoNew = modifyTree cur (floatPath new) Nothing+ -- Return patches to remove new, so that the move patch+ -- can move onto new+ treeDiff MyersDiff ftf cur curNoNew++ -- Check if the passed tree has the new filepath. The old path is removed+ -- from the tree before checking if the new path is present.+ hasNew s = treeHas_case (modifyTree s (floatPath old) Nothing) new+ treeHas_case = if doAllowCaseOnly opts then treeHas else treeHasAnycase++ alreadyExists inWhat =+ if doAllowCaseOnly opts+ then "A file or dir named "++new++" already exists in "+ ++ inWhat ++ "."+ else "A file or dir named "++new++" (or perhaps differing "+ ++ "only in case)\nalready exists in "++ inWhat ++ ".\n"+ ++ "Use --case-ok to allow files differing only in case."++moveFileOrDir :: Tree IO -> FilePath -> FilePath -> IO ()+moveFileOrDir work old new = do+ has_file <- treeHasFile work old+ has_dir <- treeHasDir work old+ when has_file $ do debugMessage $ unwords ["renameFile",old,new]+ renameFile old new+ when has_dir $ do debugMessage $ unwords ["renameDirectory",old,new]+ renameDirectory old new++mv :: DarcsCommand [DarcsFlag]+mv = commandAlias "mv" Nothing move+
+ src/Darcs/UI/Commands/Optimize.hs view
@@ -0,0 +1,695 @@+-- Copyright (C) 2003-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, OverloadedStrings #-}++module Darcs.UI.Commands.Optimize ( optimize, doOptimizeHTTP ) where++import Prelude hiding ( (^) )+import Control.Applicative ( (<$>) )+import Control.Exception ( finally )+import Control.Monad ( when, unless, forM_ )+import Data.Maybe ( isJust, fromJust )+import Data.List ( sort )+import Data.Set ( difference )+import System.Directory+ ( getDirectoryContents+ , doesDirectoryExist+ , doesFileExist+ , renameFile+ , getModificationTime+ , createDirectoryIfMissing+ , removeFile+ , getHomeDirectory+ )+import System.IO.Unsafe ( unsafeInterleaveIO )+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BL+++import Darcs.Patch.PatchInfoAnd ( extractHash )+import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, amInRepository, putInfo+ , normalCommand, withStdOpts )+import Darcs.Repository.Prefs ( getPreflist, getCaches, globalCacheDir, oldGlobalCacheDir )+import Darcs.Repository+ ( Repository+ , withRepoLock+ , RepoJob(..)+ , readRepo+ , reorderInventory+ , cleanRepository+ , replacePristine+ )+import Darcs.Repository.HashedRepo ( inventoriesDir, patchesDir, pristineDir,+ hashedInventory, filterDirContents,+ readHashedPristineRoot, listInventoriesRepoDir,+ listPatchesLocalBucketed, set, unset, inv2pris )+import Darcs.Repository.HashedIO ( getHashedFiles )+import Darcs.Repository.Old ( oldRepoFailMsg )+import Darcs.Repository.InternalTypes ( Repository(..) )+import Darcs.Repository.Util ( getRecursiveDarcsRepos )+import Darcs.Patch.Witnesses.Ordered+ ( mapRL+ , mapFL+ , bunchFL+ , lengthRL+ )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Set+ ( newset2RL+ , newset2FL+ , progressPatchSet+ )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Printer ( text )+import Darcs.Repository.Lock+ ( maybeRelink+ , gzWriteAtomicFilePS+ , writeAtomicFilePS+ , rmRecursive+ , removeFileMayNotExist+ )+import Darcs.Util.File ( withCurrentDirectory, getRecursiveContents )+import Darcs.UI.External ( catchall )+import Darcs.Util.Progress+ ( beginTedious+ , endTedious+ , tediousSize+ , debugMessage+ )+import Darcs.Util.Global ( darcsdir )++import System.FilePath.Posix+ ( takeExtension+ , (</>)+ , (<.>)+ , takeFileName+ , joinPath+ )+import Text.Printf ( printf )+import System.Posix.Files ( getFileStatus, isDirectory )+import Darcs.UI.Flags+ ( DarcsFlag(Compress)+ , compression, verbosity, useCache, umask )+import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise+ , defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags+ ( UpdateWorking (..), DryRun ( NoDryRun ), UseCache (..), UMask (..)+ , WithWorkingDir(WithWorkingDir) )+import Darcs.Patch.Progress ( progressFL )+import Darcs.Repository.Cache ( hashedDir, bucketFolder,+ HashedDir(HashedPristineDir) )+import Darcs.Repository.Format+ ( identifyRepoFormat+ , createRepoFormat+ , writeRepoFormat+ , formatHas+ , RepoProperty ( HashedInventory )+ )+import Darcs.Repository.PatchIndex+import qualified Darcs.Repository.HashedRepo as HashedRepo+import Darcs.Repository.State ( readRecorded )++import Storage.Hashed.Tree+ ( Tree+ , TreeItem(..)+ , list+ , expand+ , emptyTree+ )+import Darcs.Util.Path( anchorPath, toFilePath, AbsolutePath )+import Storage.Hashed.Plain( readPlainTree )+import Storage.Hashed.Darcs+ ( writeDarcsHashed+ , decodeDarcsSize+ )+import Codec.Archive.Tar ( write )+import Codec.Archive.Tar.Entry ( fileEntry, toTarPath )+import Codec.Compression.GZip ( compress )+++optimizeDescription :: String+optimizeDescription = "Optimize the repository."++optimizeHelp :: String+optimizeHelp =+ "The `darcs optimize` command modifies the current repository in an\n" +++ "attempt to reduce its resource requirements."++optimize :: DarcsCommand [DarcsFlag]+optimize = SuperCommand {+ commandProgramName = "darcs"+ , commandName = "optimize"+ , commandHelp = optimizeHelp+ , commandDescription = optimizeDescription+ , commandPrereq = amInRepository+ , commandSubCommands = [ normalCommand optimizeClean,+ normalCommand optimizeHttp,+ normalCommand optimizeReorder,+ normalCommand optimizeEnablePatchIndex,+ normalCommand optimizeDisablePatchIndex,+ normalCommand optimizeCompress,+ normalCommand optimizeUncompress,+ normalCommand optimizeRelink,+ normalCommand optimizePristine,+ normalCommand optimizeUpgrade,+ normalCommand optimizeGlobalCache+ ]+ }++commonBasicOpts :: DarcsOption a (Maybe String -> UMask -> a)+commonBasicOpts = O.workingRepoDir ^ O.umask+commonAdvancedOpts :: DarcsOption a a+commonAdvancedOpts = oid+commonOpts :: DarcsOption a+ (Maybe String+ -> UMask+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+commonOpts = commonBasicOpts `withStdOpts` commonAdvancedOpts++common :: DarcsCommand [DarcsFlag]+common = DarcsCommand+ { commandProgramName = "darcs"+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandPrereq = amInRepository+ , commandArgdefaults = nodefaults+ , commandName = undefined+ , commandHelp = undefined+ , commandDescription = undefined+ , commandCommand = undefined+ , commandGetArgPossibilities = undefined+ , commandAdvancedOptions = odesc commonAdvancedOpts+ , commandBasicOptions = odesc commonBasicOpts+ , commandDefaults = defaultFlags commonOpts+ , commandCheckOptions = ocheck commonOpts+ , commandParseOptions = onormalise commonOpts+ }+++optimizeClean :: DarcsCommand [DarcsFlag]+optimizeClean = common+ { commandName = "clean"+ , commandHelp = "This command deletes obsolete files within the repository."+ , commandDescription = "garbage collect pristine, inventories and patches"+ , commandCommand = optimizeCleanCmd+ }++optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeCleanCmd _ opts _ = do+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories+ putInfo opts "Done cleaning repository!"++optimizeUpgrade :: DarcsCommand [DarcsFlag]+optimizeUpgrade = common+ { commandName = "upgrade"+ , commandHelp = "Convert old-fashioned repositories to the current default hashed format."+ , commandDescription = "upgrade repository to latest compatible format"+ , commandCommand = optimizeUpgradeCmd+ }++optimizeHttp :: DarcsCommand [DarcsFlag]+optimizeHttp = common+ { commandName = "http"+ , commandHelp = optimizeHelpHttp+ , commandDescription = "optimize repository for getting over network"+ , commandCommand = optimizeHttpCmd+ }++optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeHttpCmd _ opts _ = do+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories+ doOptimizeHTTP repository+ putInfo opts "Done creating packs!"++optimizePristine :: DarcsCommand [DarcsFlag]+optimizePristine = common+ { commandName = "pristine"+ , commandHelp = "This command updates the format of `_darcs/pristine.hashed/`, which was different\n"+ ++ "before darcs 2.3.1."+ , commandDescription = "optimize hashed pristine layout"+ , commandCommand = optimizePristineCmd+ }++optimizePristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizePristineCmd _ opts _ = do+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories+ doOptimizePristine opts repository+ putInfo opts "Done optimizing pristine!"++optimizeCompress :: DarcsCommand [DarcsFlag]+optimizeCompress = common+ { commandName = "compress"+ , commandHelp = optimizeHelpCompression+ , commandDescription = "compress patches and inventories"+ , commandCommand = optimizeCompressCmd+ }++optimizeUncompress :: DarcsCommand [DarcsFlag]+optimizeUncompress = common+ { commandName = "uncompress"+ , commandHelp = optimizeHelpCompression+ , commandDescription = "uncompress patches and inventories"+ , commandCommand = optimizeUncompressCmd+ }++optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeCompressCmd _ opts _ = do+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories+ optimizeCompression [Compress]+ putInfo opts "Done optimizing by compression!"++optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeUncompressCmd _ opts _ = do+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories+ optimizeCompression []+ putInfo opts "Done optimizing by uncompression!"++optimizeCompression :: [DarcsFlag] -> IO ()+optimizeCompression opts = do+ putInfo opts "Optimizing (un)compression of patches..."+ do_compress (darcsdir++"/patches")+ putInfo opts "Optimizing (un)compression of inventories..."+ do_compress (darcsdir++"/inventories")+ where do_compress f =+ do isd <- doesDirectoryExist f+ if isd then withCurrentDirectory f $+ do fs <- filter notdot `fmap` getDirectoryContents "."+ mapM_ do_compress fs+ else if Compress `elem` opts+ then gzReadFilePS f >>= gzWriteAtomicFilePS f+ else gzReadFilePS f >>= writeAtomicFilePS f+ notdot ('.':_) = False+ notdot _ = True++optimizeEnablePatchIndex :: DarcsCommand [DarcsFlag]+optimizeEnablePatchIndex = common+ { commandName = "enable-patch-index"+ , commandHelp = "Build the patch index, an internal data structure that accelerates\n"+ ++ "commands that need to know what patches touch a given file. Such as\n"+ ++ "annotate and log."+ , commandDescription = "Enable patch index"+ , commandCommand = optimizeEnablePatchIndexCmd+ }++optimizeDisablePatchIndex :: DarcsCommand [DarcsFlag]+optimizeDisablePatchIndex = common+ { commandName = "disable-patch-index"+ , commandHelp = "Delete and stop maintaining the patch index from the repository."+ , commandDescription = "Disable patch index"+ , commandCommand = optimizeDisablePatchIndexCmd+ }++optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeEnablePatchIndexCmd _ opts _ = do+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ createOrUpdatePatchIndexDisk repository+ putInfo opts "Done enabling patch index!"++optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeDisablePatchIndexCmd _ opts _ = do+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(Repo repodir _ _ _) -> do+ deletePatchIndex repodir+ putInfo opts "Done disabling patch index!"++optimizeReorder :: DarcsCommand [DarcsFlag]+optimizeReorder = common+ { commandName = "reorder"+ , commandHelp = "This command moves recent patches (those not included in\n" +++ "the latest tag) to the \"front\", reducing the amount that a typical\n" +++ "remote command needs to download. It should also reduce the CPU time\n" +++ "needed for some operations."+ , commandDescription = "reorder the patches in the repository"+ , commandCommand = optimizeReorderCmd+ }++optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeReorderCmd _ opts _ = do+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ reorderInventory repository (compression opts) YesUpdateWorking (verbosity opts)+ putInfo opts "Done reordering!"++optimizeRelinkBasicOpts :: DarcsOption a+ (Maybe String -> UMask -> [AbsolutePath] -> a)+optimizeRelinkBasicOpts = commonBasicOpts ^ O.siblings+optimizeRelinkOpts :: DarcsOption a+ (Maybe String+ -> UMask+ -> [AbsolutePath]+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+optimizeRelinkOpts = optimizeRelinkBasicOpts `withStdOpts` commonAdvancedOpts++optimizeRelink :: DarcsCommand [DarcsFlag]+optimizeRelink = common+ { commandName = "relink"+ , commandHelp = optimizeHelpRelink + , commandDescription = "relink random internal data to a sibling"+ , commandCommand = optimizeRelinkCmd+ , commandAdvancedOptions = odesc commonAdvancedOpts+ , commandBasicOptions = odesc optimizeRelinkBasicOpts+ , commandDefaults = defaultFlags optimizeRelinkOpts+ , commandCheckOptions = ocheck optimizeRelinkOpts+ , commandParseOptions = onormalise optimizeRelinkOpts+ }++optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeRelinkCmd _ opts _ = do+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ cleanRepository repository -- garbage collect pristine.hashed, inventories and patches directories+ doRelink opts+ putInfo opts "Done relinking!"++optimizeHelpHttp :: String+optimizeHelpHttp = unlines+ [ "Using this option creates 'repository packs' that could dramatically"+ , "speed up performance when a user does a `darcs clone` of the repository"+ , "over HTTP. To make use of packs, the clients must have a darcs of at"+ , "least version 2.10."+ ]++optimizeHelpCompression :: String+optimizeHelpCompression =+ "By default patches are compressed with zlib (RFC 1951) to reduce\n" +++ "storage (and download) size. In exceptional circumstances, it may be\n" +++ "preferable to avoid compression. In this case the `--dont-compress`\n" +++ "option can be used (e.g. with `darcs record`) to avoid compression.\n" +++ "\n" +++ "The `darcs optimize uncompress` and `darcs optimize compress`\n" +++ "commands can be used to ensure existing patches in the current\n" +++ "repository are respectively uncompressed or compressed."++optimizeHelpRelink :: String+optimizeHelpRelink =+ "The `darcs optimize relink` command hard-links patches that the\n" +++ "current repository has in common with its peers. Peers are those\n" +++ "repositories listed in `_darcs/prefs/sources`, or defined with the\n" +++ "`--sibling` option (which can be used multiple times).\n" +++ "\n" +++ "Darcs uses hard-links automatically, so this command is rarely needed.\n" +++ "It is most useful if you used `cp -r` instead of `darcs get` to copy a\n" +++ "repository, or if you pulled the same patch from a remote repository\n" +++ "into multiple local repositories."++doOptimizePristine :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository p wR wU wT -> IO ()+doOptimizePristine opts repo = do+ hashed <- doesFileExist $ darcsdir </> "hashed_inventory"+ when hashed $ do+ inv <- BS.readFile (darcsdir </> "hashed_inventory")+ let linesInv = BS.split '\n' inv+ case linesInv of+ [] -> return ()+ (pris_line:_) ->+ let size = decodeDarcsSize $ BS.drop 9 pris_line+ in when (isJust size) $ do putInfo opts "Optimizing hashed pristine..."+ readRecorded repo >>= replacePristine repo+ cleanRepository repo++doRelink :: [DarcsFlag] -> IO ()+doRelink opts =+ do let some_siblings = parseFlags O.siblings opts+ defrepolist <- getPreflist "defaultrepo"+ let siblings = map toFilePath some_siblings ++ defrepolist+ if null siblings+ then putInfo opts "No siblings -- no relinking done."+ else do debugMessage "Relinking patches..."+ patch_tree <- expand =<< readPlainTree (darcsdir </> "patches")+ let patches = [ anchorPath "" p | (p, File _) <- list patch_tree ]+ maybeRelinkFiles siblings patches $ darcsdir </> "patches"+ debugMessage "Done relinking."++maybeRelinkFiles :: [String] -> [String] -> String -> IO ()+maybeRelinkFiles src dst dir =+ mapM_ (maybeRelinkFile src . ((dir ++ "/") ++)) dst++maybeRelinkFile :: [String] -> String -> IO ()+maybeRelinkFile [] _ = return ()+maybeRelinkFile (h:t) f =+ do done <- maybeRelink (h ++ "/" ++ f) f+ unless done $+ maybeRelinkFile t f++optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeUpgradeCmd _ opts _ = do+ debugMessage "Upgrading to hashed..."+ rf <- identifyRepoFormat "."+ debugMessage "Found our format"+ if formatHas HashedInventory rf+ then putInfo opts "No action taken because this repository already is hashed."+ else do putInfo opts "Checking repository in case of corruption..."+ withRepoLock NoDryRun YesUseCache YesUpdateWorking NoUMask $ RepoJob $ \repository ->+ actuallyUpgradeFormat repository++actuallyUpgradeFormat :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()+actuallyUpgradeFormat repository = do+ -- convert patches/inventory+ patches <- readRepo repository+ let k = "Hashing patch"+ beginTedious k+ tediousSize k (lengthRL $ newset2RL patches)+ let patches' = progressPatchSet k patches+ cache <- getCaches YesUseCache "."+ let compr = compression [] -- default compression+ HashedRepo.writeTentativeInventory cache compr patches'+ endTedious k+ -- convert pristine by applying patches+ -- the faster alternative would be to copy pristine, but the apply method is more reliable+ let patchesToApply = progressFL "Applying patch" $ newset2FL patches'+ createDirectoryIfMissing False $ darcsdir </> hashedDir HashedPristineDir+ -- We ignore the returned root hash, we don't use it.+ _ <- writeDarcsHashed emptyTree $ darcsdir </> "pristine.hashed"+ sequence_ $ mapFL HashedRepo.applyToTentativePristine $ bunchFL 100 patchesToApply+ -- now make it official+ HashedRepo.finalizeTentativeChanges repository compr+ writeRepoFormat (createRepoFormat True WithWorkingDir) (darcsdir </> "format")+ -- clean out old-fashioned junk+ debugMessage "Cleaning out old-fashioned repository files..."+ removeFile $ darcsdir </> "inventory"+ removeFile $ darcsdir </> "tentative_inventory"+ rmRecursive (darcsdir </> "pristine") `catchall` rmRecursive (darcsdir </> "current")+ rmGzsIn (darcsdir </> "patches")+ rmGzsIn (darcsdir </> "inventories")+ let checkpointDir = darcsdir </> "checkpoints"+ hasCheckPoints <- doesDirectoryExist checkpointDir+ when hasCheckPoints $ rmRecursive checkpointDir+ where+ rmGzsIn dir =+ withCurrentDirectory dir $ do+ gzs <- filter ((== ".gz") . takeExtension) `fmap` getDirectoryContents "."+ mapM_ removeFile gzs++doOptimizeHTTP :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wT -> IO ()+doOptimizeHTTP repo = flip finally (mapM_ removeFileIfExists+ [ darcsdir </> "meta-filelist-inventories"+ , darcsdir </> "meta-filelist-pristine"+ , basicTar <.> "part"+ , patchesTar <.> "part"+ ]) $ do+ rf <- identifyRepoFormat "."+ unless (formatHas HashedInventory rf) $ fail oldRepoFailMsg+ createDirectoryIfMissing False packsDir+ -- pristine hash+ Just hash <- readHashedPristineRoot repo+ writeFile ( packsDir </> "pristine" ) hash+ -- pack patchesTar+ ps <- mapRL hashedPatchFileName . newset2RL <$> readRepo repo+ is <- map ((darcsdir </> "inventories") </>) <$> HashedRepo.listInventories+ writeFile (darcsdir </> "meta-filelist-inventories") . unlines $+ map takeFileName is+ BL.writeFile (patchesTar <.> "part") . compress . write =<<+ mapM fileEntry' ((darcsdir </> "meta-filelist-inventories") : ps +++ reverse is)+ renameFile (patchesTar <.> "part") patchesTar+ -- pack basicTar+ pr <- sortByMTime =<< dirContents "pristine.hashed"+ writeFile (darcsdir </> "meta-filelist-pristine") . unlines $+ map takeFileName pr+ BL.writeFile (basicTar <.> "part") . compress . write =<< mapM fileEntry' (+ [ darcsdir </> "meta-filelist-pristine"+ , darcsdir </> "hashed_inventory"+ ] ++ reverse pr)+ renameFile (basicTar <.> "part") basicTar+ where+ packsDir = darcsdir </> "packs"+ basicTar = packsDir </> "basic.tar.gz"+ patchesTar = packsDir </> "patches.tar.gz"+ fileEntry' x = unsafeInterleaveIO $ do+ content <- BL.fromChunks . return <$> gzReadFilePS x+ tp <- either fail return $ toTarPath False x+ return $ fileEntry tp content+ dirContents d = map ((darcsdir </> d) </>) <$>+ (filterDirContents d $ const True)+ hashedPatchFileName x = case extractHash x of+ Left _ -> fail "unexpected unhashed patch"+ Right h -> darcsdir </> "patches" </> h+ sortByMTime xs = map snd . sort <$> mapM (\x -> (\t -> (t, x)) <$>+ getModificationTime x) xs+ removeFileIfExists x = do+ ex <- doesFileExist x+ when ex $ removeFile x++optimizeBucketed :: [DarcsFlag] -> IO ()+optimizeBucketed opts = do+ putInfo opts "Migrating global cache to bucketed format."+ gOldCacheDir <- oldGlobalCacheDir+ gCacheDir <- globalCacheDir++ case gCacheDir of+ Nothing -> fail "New global cache doesn't exist."+ Just gCacheDir' -> do+ let gCachePristineDir = joinPath [gCacheDir', pristineDir]+ gCacheInventoriesDir = joinPath [gCacheDir', inventoriesDir]+ gCachePatchesDir = joinPath [gCacheDir', patchesDir]+ debugMessage "Making bucketed cache from new cache."+ toBucketed gCachePristineDir gCachePristineDir+ toBucketed gCacheInventoriesDir gCacheInventoriesDir+ toBucketed gCachePatchesDir gCachePatchesDir+ case gOldCacheDir of+ Nothing -> debugMessage "Old global cache doesn't exist."+ Just gOldCacheDir' -> do+ debugMessage "Making bucketed cache from old cache."+ toBucketed (joinPath [gOldCacheDir', pristineDir]) gCachePristineDir+ toBucketed (joinPath [gOldCacheDir', inventoriesDir]) gCacheInventoriesDir+ toBucketed (joinPath [gOldCacheDir', patchesDir]) gCachePatchesDir+ putInfo opts "Done making bucketed cache!"+ where+ toBucketed :: FilePath -> FilePath -> IO ()+ toBucketed src dest = do+ srcExist <- doesDirectoryExist src+ if srcExist+ then do+ debugMessage $ "Making " ++ src ++ " bucketed in " ++ dest+ forM_ subDirSet $ \subDir ->+ createDirectoryIfMissing True (dest </> subDir)+ fileNames <- getDirectoryContents src+ forM_ fileNames $ \file -> do+ fileStatus <- getFileStatus (src </> file)+ if not $ isDirectory fileStatus+ then renameFile' src dest file+ else return ()+ else do+ debugMessage $ show src ++ " didn't exist, doing nothing."+ return ()++ renameFile' :: FilePath -> FilePath -> FilePath -> IO ()+ renameFile' s d f = renameFile (s </> f) (joinPath [d, bucketFolder f, f])++ subDirSet :: [String]+ subDirSet = map toStrHex [0..255]++ toStrHex :: Int -> String+ toStrHex = printf "%02x"+++optimizeGlobalCache :: DarcsCommand [DarcsFlag]+optimizeGlobalCache = common+ { commandName = "cache"+ , commandExtraArgs = -1+ , commandExtraArgHelp = [ "<DIRECTORY> ..." ]+ , commandHelp = optimizeHelpGlobalCache+ , commandDescription = "garbage collect global cache"+ , commandCommand = optimizeGlobalCacheCmd+ , commandPrereq = \_ -> return $ Right ()+ }++optimizeHelpGlobalCache :: String+optimizeHelpGlobalCache = unlines+ [ "This command deletes obsolete files within the global cache."+ , "It takes one or more directories as arguments, and recursively"+ , "searches all repositories within these directories. Then it deletes"+ , "all files in the global cache not belonging to these repositories."+ , "When no directory is given, it searches repositories in the user's"+ , "home directory."+ , ""+ , "It also automatically migrates the global cache to the (default)"+ , "bucketed format."+ ]++optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeGlobalCacheCmd _ opts args = do+ optimizeBucketed opts+ home <- getHomeDirectory+ let args' = if null args then [home] else args+ cleanGlobalCache args' opts+ putInfo opts "Done cleaning global cache!"++cleanGlobalCache :: [String] -> [DarcsFlag] -> IO ()+cleanGlobalCache dirs opts = do+ putInfo opts "\nLooking for repositories in the following directories:"+ putInfo opts $ text $ unlines dirs+ gCacheDir' <- globalCacheDir+ repoPaths' <- mapM getRecursiveDarcsRepos dirs++ putInfo opts "Finished listing repositories."++ let repoPaths = unset . set $ concat repoPaths'+ gCache = fromJust gCacheDir'+ gCacheInvDir = gCache </> inventoriesDir+ gCachePatchesDir = gCache </> patchesDir+ gCachePristineDir = gCache </> pristineDir++ createDirectoryIfMissing True gCacheInvDir+ createDirectoryIfMissing True gCachePatchesDir+ createDirectoryIfMissing True gCachePristineDir++ remove listInventoriesRepoDir gCacheInvDir repoPaths+ remove ((listPatchesLocalBucketed gCache) . (</> darcsdir)) gCachePatchesDir repoPaths+ remove getPristine gCachePristineDir repoPaths++ where+ remove fGetFiles cacheSubDir repoPaths = do+ s1 <- mapM fGetFiles repoPaths+ s2 <- getRecursiveContents cacheSubDir+ remove' cacheSubDir s2 (concat s1)++ remove' :: String -> [String] -> [String] -> IO ()+ remove' dir s1 s2 = do+ mapM_ (removeFileMayNotExist . (\hashedFile ->+ dir </> bucketFolder hashedFile </> hashedFile))+ (unset $ (set s1) `difference` (set s2))++ getPristine :: String -> IO [String]+ getPristine darcsDir = do+ i <- gzReadFilePS (darcsDir </> darcsdir </> hashedInventory)+ priss <- getHashedFiles (darcsDir </> darcsdir </> pristineDir) [inv2pris i]+ return priss
+ src/Darcs/UI/Commands/Pull.hs view
@@ -0,0 +1,489 @@+-- Copyright (C) 2002-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.UI.Commands.Pull ( -- * Commands.+ pull, fetch,+ pullCmd, StandardPatchApplier,+ -- * Utility functions.+ fetchPatches, revertable+ ) where++import Prelude hiding ( (^) )++import System.Exit ( exitSuccess )+import Control.Monad ( when, unless, (>=>) )+import Data.List ( nub )+import Data.Maybe ( fromMaybe )++import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts+ , putInfo+ , setEnvDarcsPatches+ , formatPath+ , defaultRepo+ , amInHashedRepository+ )+import Darcs.UI.Flags+ ( DarcsFlag+ ( AllowConflicts+ , Complement+ , DryRun+ , Intersection+ , MarkConflicts+ , NoAllowConflicts+ , SkipConflicts+ , Verbose+ , XMLOutput+ , Quiet+ , AllowUnrelatedRepos+ )+ , fixUrl, getOutput+ , doReverse, verbosity, dryRun, umask, useCache, selectDeps+ , remoteRepos, reorder, setDefault+ , isUnified, hasSummary+ , diffAlgorithm, isInteractive )+import Darcs.UI.Options+ ( DarcsOption, (^), odesc, ocheck, onormalise+ , defaultFlags, parseFlags+ )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( UpdateWorking (..) )+import Darcs.Repository+ ( Repository+ , identifyRepositoryFor+ , withRepoLock+ , RepoJob(..)+ , readRepo+ , checkUnrelatedRepos+ , modifyCache+ , modifyCache+ , Cache(..)+ , CacheLoc(..)+ , WritableOrNot(..)+ , filterOutConflicts+ )++import qualified Darcs.Repository.Cache as DarcsCache+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefully, patchDesc )+import Darcs.Patch ( RepoPatch, description )+import Darcs.Patch.Bundle( makeBundleN, patchFilename )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Set ( Origin, PatchSet(..), SealedPatchSet )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd )+import Darcs.Patch.Witnesses.Ordered+ ( (:>)(..), (:\/:)(..), FL(..), RL(..)+ , mapFL, nullFL, reverseFL, mapFL_FL )+import Darcs.Patch.Permutations ( partitionFL )+import Darcs.Repository.Prefs ( addToPreflist, addRepoSource, getPreflist )+import Darcs.Repository.Motd (showMotd )+import Darcs.Patch.Depends ( findUncommon, findCommonWithThem,+ newsetIntersection, newsetUnion )+import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..) )+import Darcs.UI.SelectChanges+ ( selectChanges+ , WhichChanges(..)+ , runSelection+ , selectionContext+ )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.Util.Exception ( clarifyErrors )+import Darcs.Util.Printer ( putDocLn, vcat, ($$), text, putDoc )+import Darcs.Repository.Lock ( writeDocBinFile )+import Darcs.Util.Path ( useAbsoluteOrStd, stdOut, AbsolutePath )+import Darcs.Util.Workaround ( getCurrentDirectory )+import Storage.Hashed.Tree( Tree )+#include "impossible.h"+++pullDescription :: String+pullDescription =+ "Copy and apply patches from another repository to this one."++fetchDescription :: String+fetchDescription =+ "Fetch patches from another repository, but don't apply them."++pullHelp :: String+pullHelp = unlines+ [ "Pull is used to bring changes made in another repository into the current"+ , "repository (that is, either the one in the current directory, or the one"+ , "specified with the `--repodir` option). Pull allows you to bring over all or"+ , "some of the patches that are in that repository but not in this one. Pull"+ , "accepts arguments, which are URLs from which to pull, and when called"+ , "without an argument, pull will use the repository from which you have most"+ , "recently either pushed or pulled."+ , ""+ , "The default (`--union`) behavior is to pull any patches that are in any of"+ , "the specified repositories. If you specify the `--intersection` flag, darcs"+ , "will only pull those patches which are present in all source repositories."+ , "If you specify the `--complement` flag, darcs will only pull elements in the"+ , "first repository that do not exist in any of the remaining repositories."+ , ""+ , "If `--reorder` is supplied, the set of patches that exist only in the current"+ , "repository is brought at the top of the current history. This will work even"+ , "if there are no new patches to pull."+ , ""+ , "See `darcs help apply` for detailed description of many options."+ ]++fetchHelp :: String+fetchHelp = unlines+ [ "Fetch is similar to `pull` except that it does not apply any changes"+ , "to the current repository. Instead, it generates a patch bundle that"+ , "you can apply later with `apply`."+ , ""+ , "Fetch's behaviour is essentially similar to pull's, so please consult"+ , "the help of `pull` to know more."+ ]++pullBasicOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.Reorder+ -> Maybe Bool+ -> Maybe O.AllowConflicts+ -> O.ExternalMerge+ -> O.RunTest+ -> O.DryRun+ -> O.XmlOutput+ -> Maybe O.Summary+ -> O.SelectDeps+ -> Maybe Bool+ -> Maybe String+ -> Bool+ -> O.DiffAlgorithm+ -> a)+pullBasicOpts+ = O.matchSeveral+ ^ O.reorder+ ^ O.interactive -- True+ ^ O.conflicts O.YesAllowConflictsAndMark+ ^ O.useExternalMerge+ ^ O.test+ ^ O.dryRunXml+ ^ O.summary+ ^ O.selectDeps+ ^ O.setDefault+ ^ O.workingRepoDir+ ^ O.allowUnrelatedRepos+ ^ O.diffAlgorithm++pullAdvancedOpts :: DarcsOption a+ (O.RepoCombinator+ -> O.Compression+ -> O.UseIndex+ -> O.RemoteRepos+ -> O.SetScriptsExecutable+ -> O.UMask+ -> Bool+ -> Bool+ -> O.WantGuiPause+ -> O.NetworkOptions+ -> a)+pullAdvancedOpts+ = O.repoCombinator+ ^ O.compress+ ^ O.useIndex+ ^ O.remoteRepos+ ^ O.setScriptsExecutable+ ^ O.umask+ ^ O.restrictPaths+ ^ O.changesReverse+ ^ O.pauseForGui+ ^ O.network++pullOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.Reorder+ -> Maybe Bool+ -> Maybe O.AllowConflicts+ -> O.ExternalMerge+ -> O.RunTest+ -> O.DryRun+ -> O.XmlOutput+ -> Maybe O.Summary+ -> O.SelectDeps+ -> Maybe Bool+ -> Maybe String+ -> Bool+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.RepoCombinator+ -> O.Compression+ -> O.UseIndex+ -> O.RemoteRepos+ -> O.SetScriptsExecutable+ -> O.UMask+ -> Bool+ -> Bool+ -> O.WantGuiPause+ -> O.NetworkOptions+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts++fetchBasicOpts :: DarcsOption a+ ([O.MatchFlag]+ -> Maybe Bool+ -> O.DryRun+ -> Maybe O.Summary+ -> O.SelectDeps+ -> Maybe Bool+ -> Maybe String+ -> Maybe O.Output+ -> Bool+ -> O.DiffAlgorithm+ -> a)+fetchBasicOpts+ = O.matchSeveral+ ^ O.interactive -- True+ ^ O.dryRun+ ^ O.summary+ ^ O.selectDeps+ ^ O.setDefault+ ^ O.workingRepoDir+ ^ O.output+ ^ O.allowUnrelatedRepos+ ^ O.diffAlgorithm++fetchAdvancedOpts :: DarcsOption a+ (O.RepoCombinator -> O.RemoteRepos -> O.NetworkOptions -> a)+fetchAdvancedOpts+ = O.repoCombinator+ ^ O.remoteRepos+ ^ O.network++fetchOpts :: DarcsOption a+ ([O.MatchFlag]+ -> Maybe Bool+ -> O.DryRun+ -> Maybe O.Summary+ -> O.SelectDeps+ -> Maybe Bool+ -> Maybe String+ -> Maybe O.Output+ -> Bool+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.RepoCombinator+ -> O.RemoteRepos+ -> O.NetworkOptions+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+fetchOpts = fetchBasicOpts `withStdOpts` fetchAdvancedOpts++fetch :: DarcsCommand [DarcsFlag]+fetch = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "fetch"+ , commandHelp = fetchHelp+ , commandDescription = fetchDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[REPOSITORY]..."]+ , commandCommand = fetchCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = getPreflist "repos"+ , commandArgdefaults = defaultRepo+ , commandAdvancedOptions = odesc fetchAdvancedOpts+ , commandBasicOptions = odesc fetchBasicOpts+ , commandDefaults = defaultFlags fetchOpts+ , commandCheckOptions = ocheck fetchOpts+ , commandParseOptions = onormalise fetchOpts+ }++pull :: DarcsCommand [DarcsFlag]+pull = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "pull"+ , commandHelp = pullHelp+ , commandDescription = pullDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[REPOSITORY]..."]+ , commandCommand = pullCmd StandardPatchApplier+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = getPreflist "repos"+ , commandArgdefaults = defaultRepo+ , commandAdvancedOptions = odesc pullAdvancedOpts+ , commandBasicOptions = odesc pullBasicOpts+ , commandDefaults = defaultFlags pullOpts+ , commandCheckOptions = ocheck pullOpts+ , commandParseOptions = onormalise pullOpts+ }++mergeOpts :: [DarcsFlag] -> [DarcsFlag]+mergeOpts opts | NoAllowConflicts `elem` opts = opts+ | AllowConflicts `elem` opts = opts+ | otherwise = MarkConflicts : opts++pullCmd :: PatchApplier pa => pa -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+pullCmd patchApplier (_,o) opts repos =+ do+ pullingFrom <- mapM (fixUrl o) repos+ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $+ repoJob patchApplier opts $ \patchProxy initRepo -> do++ let repository = modifyCache initRepo $ addReposToCache pullingFrom+ (_, Sealed (us' :\/: to_be_pulled))+ <- fetchPatches o opts' repos "pull" repository+ let from_whom = error "Internal error: pull shouldn't need a 'from' address"+ applyPatches patchApplier patchProxy "pull" opts' from_whom repository us' to_be_pulled+ where+ opts' = mergeOpts opts+ addReposToCache repos' (Ca cache) = Ca $ [ toReadOnlyCache r | r <- repos' ] ++ cache+ toReadOnlyCache = Cache DarcsCache.Repo NotWritable+++fetchCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+fetchCmd (_,o) opts repos =+ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $+ fetchPatches o opts repos "fetch" >=> makeBundle opts++fetchPatches :: forall p wR wU . (RepoPatch p, ApplyState p ~ Tree)+ => AbsolutePath -> [DarcsFlag] -> [String] -> String+ -> Repository p wR wU wR+ -> IO (SealedPatchSet p Origin,+ Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wR))+fetchPatches o opts unfixedrepodirs@(_:_) jobname repository = do+ here <- getCurrentDirectory+ repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl o) unfixedrepodirs+ -- Test to make sure we aren't trying to pull from the current repo+ when (null repodirs) $+ fail "Can't pull from current repository!"+ old_default <- getPreflist "defaultrepo"+ when (old_default == repodirs && XMLOutput `notElem` opts) $+ let pulling = if DryRun `elem` opts then "Would pull" else "Pulling"+ in putInfo opts $ text $ pulling++" from "++concatMap formatPath repodirs++"..."+ (Sealed them, Sealed compl) <- readRepos repository opts repodirs+ addRepoSource (head repodirs) (dryRun opts) (remoteRepos opts) (setDefault False opts)+ mapM_ (addToPreflist "repos") repodirs+ unless (Quiet `elem` opts || XMLOutput `elem` opts) $ mapM_ showMotd repodirs+ us <- readRepo repository+ checkUnrelatedRepos (AllowUnrelatedRepos `elem` opts) us them++ common :> _ <- return $ findCommonWithThem us them+ us' :\/: them' <- return $ findUncommon us them+ _ :\/: compl' <- return $ findUncommon us compl++ let avoided = mapFL info compl'+ ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) them'+ when (Verbose `elem` opts) $+ do case us' of+ (x@(_:>:_)) -> putDocLn $ text "We have the following new (to them) patches:"+ $$ vcat (mapFL description x)+ _ -> return ()+ unless (nullFL ps) $ putDocLn $ text "They have the following patches to pull:"+ $$ vcat (mapFL description ps)+ (hadConflicts, Sealed psFiltered)+ <- if SkipConflicts `elem` opts+ then filterOutConflicts (reverseFL us') repository ps+ else return (False, Sealed ps)+ when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."+ when (nullFL psFiltered) $ do putInfo opts $ text "No remote changes to pull in!"+ setEnvDarcsPatches psFiltered+ when (reorder opts /= O.Reorder) exitSuccess+ let direction = if doReverse opts then FirstReversed else First+ context = selectionContext direction jobname (pullPatchSelOpts opts) Nothing Nothing+ (to_be_pulled :> _) <- runSelection (selectChanges psFiltered) context+ return (seal common, seal $ us' :\/: to_be_pulled)++fetchPatches _ _ [] jobname _ = fail $+ "No default repository to " ++ jobname ++ " from, please specify one"++makeBundle :: forall p wR . (RepoPatch p, ApplyState p ~ Tree)+ => [DarcsFlag]+ -> (SealedPatchSet p Origin,+ Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wR))+ -> IO ()+makeBundle opts (Sealed common, Sealed (_ :\/: to_be_fetched)) =+ do+ bundle <- makeBundleN Nothing (unsafeCoercePEnd common) $+ mapFL_FL hopefully to_be_fetched+ let fname = case to_be_fetched of+ (x:>:_)-> patchFilename $ patchDesc x+ _ -> impossible+ o = fromMaybe stdOut (getOutput opts fname)+ useAbsoluteOrStd writeDocBinFile putDoc o bundle++revertable :: IO a -> IO a+revertable x =+ x `clarifyErrors` unlines+ ["Error applying patch to the working directory.","",+ "This may have left your working directory an inconsistent",+ "but recoverable state. If you had no un-recorded changes",+ "by using 'darcs revert' you should be able to make your",+ "working directory consistent again."]++{- Read in the specified pull-from repositories. Perform+Intersection, Union, or Complement read. In patch-theory terms+(stated in set algebra, where + is union and & is intersection+and \ is complement):++ Union = ((R1 + R2 + ... + Rn) \ Rc)+ Intersection = ((R1 & R2 & ... & Rn) \ Rc)+ Complement = (R1 \ Rc) \ ((R2 + R3 + ... + Rn) \ Rc)++ where Rc = local repo+ R1 = 1st specified pull repo+ R2, R3, Rn = other specified pull repo++Since Rc is not provided here yet, the result of readRepos is a+tuple: the first patchset(s) to be complemented against Rc and then+the second patchset(s) to be complemented against Rc.+-}++readRepos :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> [DarcsFlag] -> [String]+ -> IO (SealedPatchSet p Origin,SealedPatchSet p Origin)+readRepos _ _ [] = impossible+readRepos to_repo opts us =+ do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo (useCache opts) u+ ps <- readRepo r+ return $ seal ps) us+ return $ if Intersection `elem` opts+ then (newsetIntersection rs, seal (PatchSet NilRL NilRL))+ else if Complement `elem` opts+ then (head rs, newsetUnion $ tail rs)+ else (newsetUnion rs, seal (PatchSet NilRL NilRL))++pullPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+pullPatchSelOpts flags = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = parseFlags O.matchSeveral flags+ , S.diffAlgorithm = diffAlgorithm flags+ , S.interactive = isInteractive flags+ , S.selectDeps = selectDeps flags+ , S.summary = hasSummary O.NoSummary flags+ , S.withContext = isUnified flags+ }
+ src/Darcs/UI/Commands/Push.hs view
@@ -0,0 +1,286 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, TypeOperators #-}++module Darcs.UI.Commands.Push ( push ) where++import Prelude hiding ( (^) )++import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ), exitSuccess )+import Control.Monad ( when, unless )+import Data.Char ( toUpper )+import Data.Maybe ( isJust, isNothing )+import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts+ , putVerbose+ , putInfo+ , abortRun+ , printDryRunMessageAndExit+ , setEnvDarcsPatches+ , formatPath+ , defaultRepo+ , amInHashedRepository+ )+import Darcs.UI.Flags+ ( DarcsFlag+ , isInteractive, verbosity, isUnified, hasSummary, diffAlgorithm+ , hasXmlOutput, selectDeps, applyAs+ , doReverse, dryRun, useCache, remoteRepos, setDefault, fixUrl )+import Darcs.UI.Options+ ( DarcsOption, (^), odesc, ocheck, onormalise+ , defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( DryRun (..) )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )+import Darcs.Repository ( Repository, withRepository, RepoJob(..), identifyRepositoryFor,+ readRepo, checkUnrelatedRepos )+import Darcs.Patch ( RepoPatch, description )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Witnesses.Ordered+ ( (:>)(..), RL, FL, nullRL,+ nullFL, reverseFL, mapFL_FL, mapRL )+import Darcs.Repository.Prefs ( addRepoSource, getPreflist )+import Darcs.UI.External ( maybeURLCmd, signString )+import Darcs.Util.URL ( isHttpUrl, isValidLocalPath )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.UI.SelectChanges+ ( selectChanges+ , WhichChanges(..)+ , selectionContext+ , runSelection+ )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )+import Darcs.Patch.Bundle ( makeBundleN )+import Darcs.Patch.Patchy( ShowPatch )+import Darcs.Patch.Set ( PatchSet, Origin )+import Darcs.Util.Printer ( Doc, vcat, empty, text, ($$) )+import Darcs.UI.RemoteApply ( remoteApply )+import Darcs.UI.Email ( makeEmail )+import Darcs.Util.English (englishNum, Noun(..))+import Darcs.Util.Workaround ( getCurrentDirectory )+import Storage.Hashed.Tree( Tree )+#include "impossible.h"+++pushDescription :: String+pushDescription =+ "Copy and apply patches from this repository to another one."++pushHelp :: String+pushHelp = unlines+ [ "Push is the opposite of pull. Push allows you to copy changes from the"+ , "current repository into another repository."+ , ""+ , "If you give the `--apply-as` flag, darcs will use sudo to apply the"+ , "changes as a different user. This can be useful if you want to set up a"+ , "system where several users can modify the same repository, but you don't"+ , "want to allow them full write access. This isn't secure against skilled"+ , "malicious attackers, but at least can protect your repository from clumsy,"+ , "inept or lazy users."+ , ""+ , "Darcs push will by default compress the patch data before sending it to a"+ , "remote location via ssh. This works as long as the remote darcs is not"+ , "older than version 2.5. If you get errors that indicate a corrupt patch"+ , "bundle, you should try again with the `--no-compress` option to send the"+ , "data in un-compressed form (which is a lot slower for large patches, but"+ , "should always work)."+ ]++pushBasicOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.SelectDeps+ -> Maybe Bool+ -> O.Sign+ -> O.DryRun+ -> O.XmlOutput+ -> Maybe O.Summary+ -> Maybe String+ -> Maybe Bool+ -> Bool+ -> a)+pushBasicOpts+ = O.matchSeveral+ ^ O.selectDeps+ ^ O.interactive+ ^ O.sign+ ^ O.dryRunXml+ ^ O.summary+ ^ O.workingRepoDir+ ^ O.setDefault+ ^ O.allowUnrelatedRepos++pushAdvancedOpts :: DarcsOption a+ (Maybe String -> O.RemoteRepos -> Bool -> O.Compression -> O.NetworkOptions -> a)+pushAdvancedOpts+ = O.applyAs+ ^ O.remoteRepos+ ^ O.changesReverse+ ^ O.compress+ ^ O.network++pushOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.SelectDeps+ -> Maybe Bool+ -> O.Sign+ -> DryRun+ -> O.XmlOutput+ -> Maybe O.Summary+ -> Maybe String+ -> Maybe Bool+ -> Bool+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> Maybe String+ -> O.RemoteRepos+ -> Bool+ -> O.Compression+ -> O.NetworkOptions+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+pushOpts = pushBasicOpts `withStdOpts` pushAdvancedOpts++push :: DarcsCommand [DarcsFlag]+push = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "push"+ , commandHelp = pushHelp+ , commandDescription = pushDescription+ , commandExtraArgs = 1+ , commandExtraArgHelp = ["[REPOSITORY]"]+ , commandCommand = pushCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = getPreflist "repos"+ , commandArgdefaults = defaultRepo+ , commandAdvancedOptions = odesc pushAdvancedOpts+ , commandBasicOptions = odesc pushBasicOpts+ , commandDefaults = defaultFlags pushOpts+ , commandCheckOptions = ocheck pushOpts+ , commandParseOptions = onormalise pushOpts+ }++pushCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+pushCmd _ _ [""] = impossible+pushCmd (_,o) opts [unfixedrepodir] =+ do+ repodir <- fixUrl o unfixedrepodir+ -- Test to make sure we aren't trying to push to the current repo+ here <- getCurrentDirectory+ checkOptionsSanity opts repodir+ when (repodir == here) $+ fail "Cannot push from repository to itself."+ -- absolute '.' also taken into account by fix_filepath+ bundle <- withRepository (useCache opts) $ RepoJob $+ prepareBundle opts repodir+ sbundle <- signString (parseFlags O.sign opts) bundle+ let body = if isValidLocalPath repodir+ then sbundle+ else makeEmail repodir [] Nothing Nothing sbundle Nothing+ rval <- remoteApply opts repodir body+ case rval of ExitFailure ec -> do putStrLn "Apply failed!"+ exitWith (ExitFailure ec)+ ExitSuccess -> putInfo opts $ text "Push successful."+pushCmd _ _ _ = impossible++prepareBundle :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)+ => [DarcsFlag] -> String -> Repository p wR wU wT -> IO Doc+prepareBundle opts repodir repository = do+ old_default <- getPreflist "defaultrepo"+ when (old_default == [repodir]) $+ let pushing = if dryRun opts == YesDryRun then "Would push" else "Pushing"+ in putInfo opts $ text $ pushing++" to "++formatPath repodir++"..."+ them <- identifyRepositoryFor repository (useCache opts) repodir >>= readRepo+ addRepoSource repodir (dryRun opts) (remoteRepos opts) (setDefault False opts)+ us <- readRepo repository+ common :> us' <- return $ findCommonWithThem us them+ prePushChatter opts us (reverseFL us') them+ let direction = if doReverse opts then FirstReversed else First+ context = selectionContext direction "push" (pushPatchSelOpts opts) Nothing Nothing+ runSelection (selectChanges us') context+ >>= bundlePatches opts common++prePushChatter :: forall p a wX wY wT . (RepoPatch p, ShowPatch a) =>+ [DarcsFlag] -> PatchSet p Origin wX ->+ RL a wT wX -> PatchSet p Origin wY -> IO ()+prePushChatter opts us us' them = do+ checkUnrelatedRepos (parseFlags O.allowUnrelatedRepos opts) us them+ let num_to_pull = snd $ countUsThem us them+ pull_reminder = if num_to_pull > 0+ then text $ "The remote repository has " ++ show num_to_pull+ ++ " " ++ englishNum num_to_pull (Noun "patch") " to pull."+ else empty+ putVerbose opts $ text "We have the following patches to push:" $$ vcat (mapRL description us')+ unless (nullRL us') $ putInfo opts pull_reminder+ when (nullRL us') $ do putInfo opts $ text "No recorded local changes to push!"+ exitSuccess++bundlePatches :: forall t p wZ wW wA. (RepoPatch p, ApplyState p ~ Tree)+ => [DarcsFlag] -> PatchSet p wA wZ+ -> (FL (PatchInfoAnd p) :> t) wZ wW+ -> IO Doc+bundlePatches opts common (to_be_pushed :> _) =+ do+ setEnvDarcsPatches to_be_pushed+ printDryRunMessageAndExit "push"+ (verbosity opts)+ (hasSummary O.NoSummary opts)+ (dryRun opts)+ (hasXmlOutput opts)+ (isInteractive opts)+ to_be_pushed+ when (nullFL to_be_pushed) $ do+ putInfo opts $+ text "You don't want to push any patches, and that's fine with me!"+ exitSuccess+ makeBundleN Nothing common (mapFL_FL hopefully to_be_pushed)++checkOptionsSanity :: [DarcsFlag] -> String -> IO ()+checkOptionsSanity opts repodir =+ if isHttpUrl repodir then do+ when (isJust $ applyAs opts) $+ abortRun opts $ text "Cannot --apply-as when pushing to URLs"+ maybeapply <- maybeURLCmd "APPLY" repodir+ when (isNothing maybeapply) $+ let lprot = takeWhile (/= ':') repodir+ prot = map toUpper lprot+ msg = text ("Pushing to "++lprot++" URLs is not supported.\n"+++ "You may be able to hack this to work"+++ " using DARCS_APPLY_"++prot) in+ abortRun opts msg+ else when (parseFlags O.sign opts /= O.NoSign) $+ abortRun opts $ text "Signing doesn't make sense for local repositories or when pushing over ssh."+++pushPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+pushPatchSelOpts flags = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = parseFlags O.matchSeveral flags+ , S.diffAlgorithm = diffAlgorithm flags+ , S.interactive = isInteractive flags+ , S.selectDeps = selectDeps flags+ , S.summary = hasSummary O.NoSummary flags+ , S.withContext = isUnified flags+ }
+ src/Darcs/UI/Commands/Rebase.hs view
@@ -0,0 +1,1118 @@+-- Copyright (C) 2009 Ganesh Sittampalam+--+-- BSD3++{-# LANGUAGE CPP, TypeOperators #-}++module Darcs.UI.Commands.Rebase ( rebase ) where++import Prelude hiding ( (^), catch, log )++import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts+ , normalCommand, hiddenCommand+ , commandAlias+ , defaultRepo, nodefaults+ , putInfo, putVerbose+ , setEnvDarcsPatches+ , printDryRunMessageAndExit+ , amInHashedRepository+ )+import Darcs.UI.Commands.Amend ( updatePatchHeader )+import Darcs.UI.Commands.Apply ( applyCmd )+import Darcs.UI.Commands.Log ( changelog, getLogInfo )+import Darcs.UI.Commands.Pull ( pullCmd, revertable )+import Darcs.UI.Commands.Unrecord ( getLastPatches, matchingHead )+import Darcs.UI.CommandsAux ( checkPaths )+import Darcs.UI.Flags+ ( DarcsFlag+ ( AllowConflicts+ , NoAllowConflicts+ , MarkConflicts+ , SkipConflicts+ , SetScriptsExecutable)+ , externalMerge, allowConflicts+ , compression, diffingOpts+ , dryRun, reorder, verbosity+ , useCache, wantGuiPause+ , umask, toMatchFlags, doReverse+ , DarcsFlag(XMLOutput)+ , showChangesOnlyToFiles+ , diffAlgorithm, maxCount, hasSummary, isInteractive+ , selectDeps, hasXmlOutput+ )+import Darcs.UI.Options+ ( DarcsOption, (^), oid, odesc, ocheck, onormalise+ , defaultFlags, parseFlags+ )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository+ ( Repository, RepoJob(..), withRepoLock, withRepository+ , tentativelyAddPatch, finalizeRepositoryChanges+ , invalidateIndex+ , tentativelyRemovePatches, readRepo+ , tentativelyAddToPending, unrecordedChanges, applyToWorking+ , revertRepositoryChanges+ , setScriptsExecutablePatches+ , listFiles+ )+import Darcs.Repository.Flags ( UpdateWorking(..), ExternalMerge(..) )+import Darcs.Repository.Internal ( announceMergeConflicts )+import Darcs.Repository.Merge ( tentativelyMergePatches )+import Darcs.Repository.Prefs ( getPreflist )+import Darcs.Repository.Resolution ( standardResolution )+import Darcs.Patch ( invert, effect, commute, RepoPatch, description )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Commute ( selfCommuter )+import Darcs.Patch.CommuteFn ( commuterIdFL )+import Darcs.Patch.Info ( showPatchInfo )+import Darcs.Patch.Match ( firstMatch, secondMatch, splitSecondFL )+import Darcs.Patch.Named+ ( patchcontents+ , Named, fmapNamed, fmapFL_Named+ , patch2patchinfo+ )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia, hopefully )+import Darcs.Patch.Prim ( PrimOf, canonizeFL, fromPrim )+import Darcs.Patch.Rebase+ ( Rebasing(..), RebaseItem(..)+ , mkSuspended+ , simplifyPush, simplifyPushes+ , takeHeadRebase, takeHeadRebaseFL+ )+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims )+import Darcs.Patch.Rebase.Name ( RebaseName(..), commuteNameNamed )+import Darcs.Patch.Rebase.Viewing+ ( RebaseSelect(RSFwd), rsToNamed+ , toRebaseSelect, fromRebaseSelect, extractRebaseSelect, reifyRebaseSelect+ , partitionUnconflicted+ , WithDroppedDeps(..), WDDNamed, commuterIdWDD+ , toRebaseChanges+ )+import Darcs.Patch.Permutations ( partitionConflictingFL )+import Darcs.Patch.Progress ( progressFL )+import Darcs.Patch.Set ( PatchSet(..), appendPSFL )+import Darcs.Patch.Show ( showNicely )+import Darcs.Patch.Split ( primSplitter )+import Darcs.UI.ApplyPatches ( PatchApplier(..), PatchProxy(..) )+import Darcs.UI.SelectChanges+ ( selectChanges, runSelection+ , selectionContext, selectionContextGeneric, selectionContextPrim+ , WhichChanges(First, Last, LastReversed)+ , viewChanges+ )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), (+>+), mapFL_FL+ , concatFL, mapFL, nullFL, lengthFL+ , (:>)(..)+ , RL(..), reverseRL+ )+import Darcs.Patch.Witnesses.Sealed+ ( Sealed(..), seal, unseal+ , FlippedSeal(..)+ , Sealed2(..)+ )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Util.English ( englishNum, Noun(Noun) )+import Darcs.Util.Printer+ ( vcat, text, ($$)+ , putDocLnWith, simplePrinters+ , renderString, RenderMode(..)+ )+import Darcs.Util.Printer.Color ( fancyPrinters )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Path ( AbsolutePath )++import Storage.Hashed.Tree ( Tree )++import Control.Applicative ( (<$>) )+import Control.Exception ( catch, IOException )+import Control.Monad ( when )+import System.Exit ( exitSuccess )++#include "impossible.h"++rebaseDescription :: String+rebaseDescription = "Edit several patches at once."++rebaseHelp :: String+rebaseHelp =+ "The `darcs rebase' command is used to edit a collection of darcs patches.\n"++rebase :: DarcsCommand [DarcsFlag]+rebase = SuperCommand+ { commandProgramName = "darcs"+ , commandName = "rebase"+ , commandHelp = rebaseHelp+ , commandDescription = rebaseDescription+ , commandPrereq = amInHashedRepository+ , commandSubCommands =+ [ normalCommand pull+ , normalCommand apply+ , normalCommand suspend+ , normalCommand unsuspend+ , hiddenCommand reify+ , hiddenCommand inject+ , normalCommand obliterate+ , normalCommand log+ , hiddenCommand changes+ ]+ }++suspendBasicOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.SelectDeps+ -> Maybe Bool+ -> Maybe O.Summary+ -> O.DiffAlgorithm+ -> a)+suspendBasicOpts+ = O.matchSeveralOrLast+ ^ O.selectDeps+ ^ O.interactive+ ^ O.summary+ ^ O.diffAlgorithm++suspendAdvancedOpts :: DarcsOption a (Bool -> O.UseIndex -> a)+suspendAdvancedOpts+ = O.changesReverse+ ^ O.useIndex++suspendOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.SelectDeps+ -> Maybe Bool+ -> Maybe O.Summary+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> Bool+ -> O.UseIndex+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+suspendOpts = suspendBasicOpts `withStdOpts` suspendAdvancedOpts++suspend :: DarcsCommand [DarcsFlag]+suspend = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "suspend"+ , commandHelp = "Select patches to move into a suspended state at the end of the repo.\n"+ , commandDescription = "Select patches to move into a suspended state at the end of the repo."+ , commandPrereq = amInHashedRepository+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = suspendCmd+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc suspendAdvancedOpts+ , commandBasicOptions = odesc suspendBasicOpts+ , commandDefaults = defaultFlags suspendOpts+ , commandCheckOptions = ocheck suspendOpts+ , commandParseOptions = onormalise suspendOpts+ }++suspendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+suspendCmd _ opts _args =+ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $+ StartRebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ \repository -> do+ allpatches <- readRepo repository+ (rOld, Sealed qs, allpatches_tail) <- return $ takeHeadRebase allpatches+ (_ :> patches) <-+ return $ if firstMatch (parseFlags O.matchSeveralOrLast opts)+ then getLastPatches (parseFlags O.matchSeveralOrLast opts) allpatches_tail+ else matchingHead (parseFlags O.matchSeveralOrLast opts) allpatches_tail+ let direction = if doReverse opts then Last else LastReversed+ patches_context = selectionContext direction "suspend" (patchSelOpts opts) Nothing Nothing+ (_ :> psToSuspend) <-+ runSelection+ (selectChanges patches)+ patches_context+ when (nullFL psToSuspend) $ do+ putStrLn "No patches selected!"+ exitSuccess+ repository' <- doSuspend opts repository qs rOld psToSuspend+ finalizeRepositoryChanges repository' YesUpdateWorking (compression opts)+ return ()++doSuspend+ :: forall p wR wU wT wX wY+ . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)+ => [DarcsFlag]+ -> Repository (Rebasing p) wR wU wT+ -> FL (RebaseItem p) wT wY+ -> PatchInfoAnd (Rebasing p) wT wT+ -> FL (PatchInfoAnd (Rebasing p)) wX wT+ -> IO (Repository (Rebasing p) wR wU wX)+doSuspend opts repository qs rOld psToSuspend = do+ pend <- unrecordedChanges (diffingOpts opts) repository Nothing+ FlippedSeal psAfterPending <-+ let effectPsToSuspend = effect psToSuspend in+ case commute (effectPsToSuspend :> pend) of+ Just (_ :> res) -> return (FlippedSeal res)+ Nothing -> do+ putVerbose opts $+ let invPsEffect = invert effectPsToSuspend+ doPartition = partitionConflictingFL (commuterIdFL selfCommuter)+ in+ case (doPartition invPsEffect pend, doPartition pend invPsEffect) of+ (_ :> invSuspendedConflicts, _ :> pendConflicts) ->+ let suspendedConflicts = invert invSuspendedConflicts in+ text "these changes in the suspended patches:" $$+ showNicely suspendedConflicts $$+ text "conflict with these local changes:" $$+ showNicely pendConflicts+ fail $ "Can't suspend selected patches without reverting some unrecorded change. Use --verbose to see the details."+++ rNew <- mkSuspended (mapFL_FL (ToEdit . fmapNamed unNormal . hopefully) psToSuspend +>+ qs)+ invalidateIndex repository+ repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (psToSuspend +>+ (rOld :>: NilFL))+ tentativelyAddToPending repository' YesUpdateWorking $ invert $ effect psToSuspend+ repository'' <- tentativelyAddPatch repository' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew)+ _ <- applyToWorking repository'' (verbosity opts) (invert psAfterPending)+ `catch` \(e :: IOException) -> fail ("Couldn't undo patch in working dir.\n" ++ show e)+ return repository''+ where unNormal :: Rebasing p wA wB -> p wA wB+ unNormal (Normal q) = q+ unNormal (Suspended _) = error "Can't suspend a rebase patch"++unsuspendBasicOpts :: DarcsOption a+ (Maybe O.AllowConflicts+ -> [O.MatchFlag]+ -> Maybe Bool+ -> Maybe O.Summary+ -> ExternalMerge+ -> Bool+ -> Maybe String+ -> O.DiffAlgorithm+ -> a)+unsuspendBasicOpts+ = O.conflicts O.YesAllowConflictsAndMark+ ^ O.matchSeveralOrFirst+ ^ O.interactive+ ^ O.summary+ ^ O.useExternalMerge+ ^ O.keepDate+ ^ O.author+ ^ O.diffAlgorithm++unsuspendAdvancedOpts :: DarcsOption a (O.UseIndex -> a)+unsuspendAdvancedOpts = O.useIndex++unsuspendOpts :: DarcsOption a+ (Maybe O.AllowConflicts+ -> [O.MatchFlag]+ -> Maybe Bool+ -> Maybe O.Summary+ -> ExternalMerge+ -> Bool+ -> Maybe String+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseIndex+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+unsuspendOpts = unsuspendBasicOpts `withStdOpts` unsuspendAdvancedOpts++unsuspend :: DarcsCommand [DarcsFlag]+unsuspend = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "unsuspend"+ , commandHelp = "Selected patches to restore from a suspended state to the end of the repo.\n"+ , commandDescription = "Select suspended patches to restore to the end of the repo."+ , commandPrereq = amInHashedRepository+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = unsuspendCmd False+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc unsuspendAdvancedOpts+ , commandBasicOptions = odesc unsuspendBasicOpts+ , commandDefaults = defaultFlags unsuspendOpts+ , commandCheckOptions = ocheck unsuspendOpts+ , commandParseOptions = onormalise unsuspendOpts+ }++reifyBasicOpts :: DarcsOption a+ ([O.MatchFlag] -> Maybe Bool -> Bool -> Maybe String -> O.DiffAlgorithm -> a)+reifyBasicOpts+ = O.matchSeveralOrFirst+ ^ O.interactive+ ^ O.keepDate+ ^ O.author+ ^ O.diffAlgorithm++reifyOpts :: DarcsOption a+ ([O.MatchFlag]+ -> Maybe Bool+ -> Bool+ -> Maybe String+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+reifyOpts = reifyBasicOpts `withStdOpts` oid++reify :: DarcsCommand [DarcsFlag]+reify = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "reify"+ , commandHelp = "Select suspended patches to restore to the end of the repo, reifying any fixup patches.\n"+ , commandDescription = "Select suspended patches to restore to the end of the repo, reifying any fixup patches."+ , commandPrereq = amInHashedRepository+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = unsuspendCmd True+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = odesc reifyBasicOpts+ , commandDefaults = defaultFlags reifyOpts+ , commandCheckOptions = ocheck reifyOpts+ , commandParseOptions = onormalise reifyOpts+ }++unsuspendCmd :: Bool -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+unsuspendCmd reifyFixups _ opts _args =+ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $+ RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $+ \(repository :: Repository (Rebasing p) wR wU wR) -> (do+ patches <- readRepo repository+ pend <- unrecordedChanges (diffingOpts opts) repository Nothing+ let checkChanges :: FL (PrimOf p) wA wB -> IO (EqCheck wA wB)+ checkChanges NilFL = return IsEq+ checkChanges _ = error "can't unsuspend when there are unrecorded changes"+ IsEq <- checkChanges pend :: IO (EqCheck wR wU)+ (rOld, Sealed ps, _) <- return $ takeHeadRebase patches++ let selects = toRebaseSelect ps++ let matchFlags = toMatchFlags opts+ inRange :> outOfRange <-+ return $+ if secondMatch matchFlags then+ splitSecondFL rsToNamed matchFlags selects+ else selects :> NilFL++ offer :> dontoffer <-+ return $+ if SkipConflicts `elem` opts+ then partitionUnconflicted inRange+ else inRange :> NilRL++ let warnSkip :: RL q wX wY -> IO ()+ warnSkip NilRL = return ()+ warnSkip _ = putStrLn "Skipping some patches which would cause conflicts."++ warnSkip dontoffer++ let patches_context = selectionContextGeneric rsToNamed First "unsuspend" (patchSelOpts opts) Nothing+ (chosen :> keep) <- runSelection (selectChanges offer) patches_context+ when (nullFL chosen) $ do putStrLn "No patches selected!"+ exitSuccess++ (ps_to_unsuspend :: FL (WDDNamed p) wR wZ) :> chosen_fixups+ <- (if reifyFixups then reifyRebaseSelect else return . extractRebaseSelect) chosen++ let da = diffAlgorithm opts+ ps_to_keep = simplifyPushes da chosen_fixups .+ fromRebaseSelect $+ keep +>+ reverseRL dontoffer +>+ outOfRange++ Sealed standard_resolved_p <- return $ standardResolution $ concatFL+ $ progressFL "Examining patches for conflicts"+ $ mapFL_FL (patchcontents . wddPatch) ps_to_unsuspend+ :: IO (Sealed (FL (PrimOf p) wZ))++ let merge_opts | NoAllowConflicts `elem` opts = opts+ | AllowConflicts `elem` opts = opts+ | otherwise = MarkConflicts : opts++ have_conflicts <- announceMergeConflicts "unsuspend" (allowConflicts merge_opts) (externalMerge merge_opts) standard_resolved_p+ Sealed (resolved_p :: FL (PrimOf p) wA wB) <-+ case (externalMerge opts, have_conflicts) of+ (NoExternalMerge,_) -> return $ if AllowConflicts `elem` opts -- i.e. don't mark them+ then seal NilFL+ else seal standard_resolved_p+ (_,False) -> return $ seal standard_resolved_p+ (YesExternalMerge _, True) -> error "external resolution for unsuspend not implemented yet"++ let effect_to_apply = concatFL (mapFL_FL effect ps_to_unsuspend) +>+ resolved_p+ invalidateIndex repository+ repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (rOld :>: NilFL)+ -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord+ tentativelyAddToPending repository' YesUpdateWorking effect_to_apply+ (repository'', renames) <- doAdd repository' ps_to_unsuspend+ rNew <- unseal mkSuspended . unseal (simplifyPushes da (mapFL_FL NameFixup renames)) $ ps_to_keep+ repository''' <- tentativelyAddPatch repository'' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew)+ finalizeRepositoryChanges repository''' YesUpdateWorking (compression opts)+ _ <- applyToWorking repository''' (verbosity opts) effect_to_apply `catch` \(e :: IOException) ->+ fail ("couldn't apply patch in working dir.\n" ++ show e)+ return ()+ ) :: IO ()+ where doAdd :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository (Rebasing p) wR wU wT+ -> FL (WDDNamed p) wT wT2+ -> IO (Repository (Rebasing p) wR wU wT2, FL (RebaseName p) wT2 wT2)+ doAdd repo NilFL = return (repo, NilFL)+ doAdd repo ((p :: WDDNamed p wT wU) :>:ps) = do+ case wddDependedOn p of+ [] -> return ()+ deps -> do+ -- It might make sense to only print out this message once, but we might find+ -- that the dropped dependencies are interspersed with other output,+ -- e.g. if running with --ask-deps+ putStr $ "Warning: dropping the following explicit "+ ++ englishNum (length deps) (Noun "dependency") ":\n\n"+ let printIndented n =+ mapM_ (putStrLn . (replicate n ' '++)) . lines .+ renderString Encode . showPatchInfo+ putStrLn . renderString Encode . showPatchInfo .+ patch2patchinfo $ wddPatch p+ putStr " depended on:\n"+ mapM_ (printIndented 2) deps+ putStr "\n"++ -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord+ p' <- snd <$> updatePatchHeader+ False -- askDeps+ (patchSelOpts opts)+ (parseFlags O.keepDate opts)+ (parseFlags O.selectAuthor opts)+ (parseFlags O.author opts)+ (parseFlags O.patchname opts)+ (parseFlags O.askLongComment opts)+ repo (n2pia (fmapNamed Normal (wddPatch p))) NilFL+ repo' <- tentativelyAddPatch repo (compression opts) (verbosity opts) YesUpdateWorking p'+ -- create a rename that undoes the change we just made, so the contexts match up+ let rename :: RebaseName p wU wU+ rename = Rename (info p') (patch2patchinfo (wddPatch p))+ -- push it through the remaining patches to fix them up+ Just (ps2 :> (rename2 :: RebaseName p wV wT2)) <- return (commuterIdFL (commuterIdWDD commuteNameNamed) (rename :> ps))+ -- assert that the rename still has a null effect on the context after commuting+ IsEq <- return (unsafeCoerceP IsEq :: EqCheck wV wT2)+ (repo'', renames) <- doAdd repo' ps2+ -- return the renames so that the suspended patch can be fixed up+ return (repo'', rename2 :>: renames)+++injectBasicOpts :: DarcsOption a (Bool -> Maybe String -> O.DiffAlgorithm -> a)+injectBasicOpts = O.keepDate ^ O.author ^ O.diffAlgorithm++injectOpts :: DarcsOption a + (Bool+ -> Maybe String+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+injectOpts = injectBasicOpts `withStdOpts` oid++inject :: DarcsCommand [DarcsFlag]+inject = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "inject"+ , commandHelp = "Merge a change from the fixups of a patch into the patch itself.\n"+ , commandDescription = "Merge a change from the fixups of a patch into the patch itself."+ , commandPrereq = amInHashedRepository+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = injectCmd+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = odesc injectBasicOpts+ , commandDefaults = defaultFlags injectOpts+ , commandCheckOptions = ocheck injectOpts+ , commandParseOptions = onormalise injectOpts+ }++injectCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+injectCmd _ opts _args =+ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $+ RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $+ \(repository :: Repository (Rebasing p) wR wU wR) -> do+ patches <- readRepo repository++ (rOld, Sealed ps, _) <- return $ takeHeadRebase patches++ let selects = toRebaseSelect ps++ -- TODO this selection doesn't need to respect dependencies+ -- TODO we only want to select one patch: generalise withSelectedPatchFromRepo+ let patches_context = selectionContextGeneric rsToNamed First "inject into" (patchSelOpts opts) Nothing+ (chosens :> rest_selects) <- runSelection (selectChanges selects) patches_context++ let extractSingle :: FL (RebaseSelect p) wX wY -> (FL (RebaseFixup p) :> Named p) wX wY+ extractSingle (RSFwd fixups toedit :>: NilFL) = fixups :> toedit+ extractSingle (_ :>: NilFL) = impossible+ extractSingle _ = error "You must select precisely one patch!"++ fixups :> toedit <- return $ extractSingle chosens++ name_fixups :> prim_fixups <- return $ flToNamesPrims fixups++ let changes_context = selectionContextPrim Last "inject" (patchSelOpts opts) (Just primSplitter) Nothing Nothing+ (rest_fixups :> injects) <- runSelection (selectChanges prim_fixups) changes_context++ when (nullFL injects) $ do+ putStrLn "No changes selected!"+ exitSuccess++ -- Don't bother to update patch header since unsuspend will do that later+ let da = diffAlgorithm opts+ toeditNew = fmapFL_Named (mapFL_FL fromPrim . canonizeFL da . (injects +>+) . effect) toedit+ rNew <- unseal mkSuspended $ unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups))+ $ simplifyPushes da (mapFL_FL PrimFixup rest_fixups)+ $ ToEdit toeditNew :>: fromRebaseSelect rest_selects++ repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (rOld :>: NilFL)+ repository'' <- tentativelyAddPatch repository' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew)+ finalizeRepositoryChanges repository'' YesUpdateWorking (compression opts)+ return ()++obliterateBasicOpts :: DarcsOption a (O.DiffAlgorithm -> a)+obliterateBasicOpts = O.diffAlgorithm++obliterateOpts :: DarcsOption a+ (O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+obliterateOpts = obliterateBasicOpts `withStdOpts` oid++obliterate :: DarcsCommand [DarcsFlag]+obliterate = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "obliterate"+ , commandHelp = "Obliterate a patch that is currently suspended.\n"+ , commandDescription = "Obliterate a patch that is currently suspended.\n"+ , commandPrereq = amInHashedRepository+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = obliterateCmd+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = odesc obliterateBasicOpts+ , commandDefaults = defaultFlags obliterateOpts+ , commandCheckOptions = ocheck obliterateOpts+ , commandParseOptions = onormalise obliterateOpts+ }++obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+obliterateCmd _ opts _args =+ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $+ RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $+ \(repository :: Repository (Rebasing p) wR wU wR) -> (do+ patches <- readRepo repository++ (rOld, Sealed ps, _) <- return $ takeHeadRebase patches++ let selects = toRebaseSelect ps++ -- TODO this selection doesn't need to respect dependencies+ let patches_context = selectionContextGeneric rsToNamed First "obliterate" (obliteratePatchSelOpts opts) Nothing+ (chosen :> keep) <- runSelection (selectChanges selects) patches_context+ when (nullFL chosen) $ do putStrLn "No patches selected!"+ exitSuccess++ let da = diffAlgorithm opts+ do_obliterate :: FL (RebaseItem p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)+ do_obliterate NilFL = Sealed+ do_obliterate (Fixup f :>: qs) = unseal (simplifyPush da f) . do_obliterate qs+ do_obliterate (ToEdit e :>: qs) = -- since Named doesn't have any witness context for the+ -- patch names, the AddName here will be inferred to be wX wX+ unseal (simplifyPush da (NameFixup (AddName (patch2patchinfo e)))) .+ unseal (simplifyPushes da (mapFL_FL PrimFixup (effect (patchcontents e)))) .+ do_obliterate qs++ let ps_to_keep = do_obliterate (fromRebaseSelect chosen) (fromRebaseSelect keep)+ rNew <- unseal mkSuspended ps_to_keep++ repository' <- tentativelyRemovePatches repository (compression opts) YesUpdateWorking (rOld :>: NilFL)+ repository'' <- tentativelyAddPatch repository' (compression opts) (verbosity opts) YesUpdateWorking (n2pia rNew)+ finalizeRepositoryChanges repository'' YesUpdateWorking (compression opts)+ return ()+ ) :: IO ()+++pullDescription :: String+pullDescription =+ "Copy and apply patches from another repository, suspending any local patches that conflict."++pullHelp :: String+pullHelp =+ "Copy and apply patches from another repository, suspending any local patches that conflict."++pullBasicOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.Reorder+ -> Maybe Bool+ -> Maybe O.AllowConflicts+ -> ExternalMerge+ -> O.RunTest+ -> O.DryRun+ -> O.XmlOutput+ -> Maybe O.Summary+ -> O.SelectDeps+ -> Maybe Bool+ -> Maybe String+ -> Bool+ -> O.DiffAlgorithm+ -> a)+pullBasicOpts+ = O.matchSeveral+ ^ O.reorder+ ^ O.interactive+ ^ O.conflicts O.YesAllowConflictsAndMark+ ^ O.useExternalMerge+ ^ O.test+ ^ O.dryRunXml+ ^ O.summary+ ^ O.selectDeps+ ^ O.setDefault+ ^ O.workingRepoDir+ ^ O.allowUnrelatedRepos+ ^ O.diffAlgorithm++pullAdvancedOpts :: DarcsOption a+ (O.RepoCombinator+ -> O.Compression+ -> O.UseIndex+ -> O.RemoteRepos+ -> O.SetScriptsExecutable+ -> O.UMask+ -> Bool+ -> Bool+ -> O.NetworkOptions+ -> a)+pullAdvancedOpts+ = O.repoCombinator+ ^ O.compress+ ^ O.useIndex+ ^ O.remoteRepos+ ^ O.setScriptsExecutable+ ^ O.umask+ ^ O.restrictPaths+ ^ O.changesReverse+ ^ O.network++pullOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.Reorder+ -> Maybe Bool+ -> Maybe O.AllowConflicts+ -> ExternalMerge+ -> O.RunTest+ -> O.DryRun+ -> O.XmlOutput+ -> Maybe O.Summary+ -> O.SelectDeps+ -> Maybe Bool+ -> Maybe String+ -> Bool+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.RepoCombinator+ -> O.Compression+ -> O.UseIndex+ -> O.RemoteRepos+ -> O.SetScriptsExecutable+ -> O.UMask+ -> Bool+ -> Bool+ -> O.NetworkOptions+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts++pull :: DarcsCommand [DarcsFlag]+pull = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "pull"+ , commandHelp = pullHelp+ , commandDescription = pullDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[REPOSITORY]..."]+ , commandCommand = pullCmd RebasePatchApplier+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = getPreflist "repos"+ , commandArgdefaults = defaultRepo+ , commandAdvancedOptions = odesc pullAdvancedOpts+ , commandBasicOptions = odesc pullBasicOpts+ , commandDefaults = defaultFlags pullOpts+ , commandCheckOptions = ocheck pullOpts+ , commandParseOptions = onormalise pullOpts+ }++applyDescription :: String+applyDescription = "Apply a patch bundle, suspending any local patches that conflict."++applyHelp :: String+applyHelp = "Apply a patch bundle, suspending any local patches that conflict."++stdindefault :: a -> [String] -> IO [String]+stdindefault _ [] = return ["-"]+stdindefault _ x = return x++apply :: DarcsCommand [DarcsFlag]+apply = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "apply"+ , commandHelp = applyHelp+ , commandDescription = applyDescription+ , commandExtraArgs = 1+ , commandExtraArgHelp = ["<PATCHFILE>"]+ , commandCommand = applyCmd RebasePatchApplier+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = listFiles False+ , commandArgdefaults = const stdindefault+ , commandAdvancedOptions = odesc applyAdvancedOpts+ , commandBasicOptions = odesc applyBasicOpts+ , commandDefaults = defaultFlags applyOpts+ , commandCheckOptions = ocheck applyOpts+ , commandParseOptions = onormalise applyOpts+ }++applyBasicOpts :: DarcsOption a+ (O.Verify+ -> O.Reorder+ -> Maybe Bool+ -> O.DryRun+ -> O.XmlOutput+ -> [O.MatchFlag]+ -> Maybe String+ -> O.DiffAlgorithm+ -> a)+applyBasicOpts+ = O.verify+ ^ O.reorder+ ^ O.interactive+ ^ O.dryRunXml+ ^ O.matchSeveral+ ^ O.workingRepoDir+ ^ O.diffAlgorithm++applyAdvancedOpts :: DarcsOption a+ (Maybe String+ -> Maybe String+ -> Bool+ -> (Bool, Maybe String)+ -> O.UseIndex+ -> O.Compression+ -> O.SetScriptsExecutable+ -> O.UMask+ -> Bool+ -> Bool+ -> O.WantGuiPause+ -> a)+applyAdvancedOpts+ = O.reply+ ^ O.ccApply+ ^ O.happyForwarding+ ^ O.sendmail+ ^ O.useIndex+ ^ O.compress+ ^ O.setScriptsExecutable+ ^ O.umask+ ^ O.restrictPaths+ ^ O.changesReverse+ ^ O.pauseForGui++applyOpts :: DarcsOption a+ (O.Verify+ -> O.Reorder+ -> Maybe Bool+ -> O.DryRun+ -> O.XmlOutput+ -> [O.MatchFlag]+ -> Maybe String+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> Maybe String+ -> Maybe String+ -> Bool+ -> (Bool, Maybe String)+ -> O.UseIndex+ -> O.Compression+ -> O.SetScriptsExecutable+ -> O.UMask+ -> Bool+ -> Bool+ -> O.WantGuiPause+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)++applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts++data RebasePatchApplier = RebasePatchApplier++instance PatchApplier RebasePatchApplier where+ type CarrierType RebasePatchApplier p = Rebasing p++ repoJob RebasePatchApplier opts f =+ StartRebaseJob (compression opts) (verbosity opts) YesUpdateWorking (f PatchProxy)+ applyPatches RebasePatchApplier PatchProxy = applyPatchesForRebaseCmd++applyPatchesForRebaseCmd+ :: forall p wR wU wX wT wZ+ . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)+ => String+ -> [DarcsFlag]+ -> String+ -> Repository (Rebasing p) wR wU wT+ -> FL (PatchInfoAnd (Rebasing p)) wX wT+ -> FL (PatchInfoAnd (Rebasing p)) wX wZ+ -> IO ()+applyPatchesForRebaseCmd cmdName opts _from_whom repository us' to_be_applied = do+ printDryRunMessageAndExit cmdName+ (verbosity opts)+ (hasSummary O.NoSummary opts)+ (dryRun opts)+ (hasXmlOutput opts)+ (isInteractive opts)+ to_be_applied+ setEnvDarcsPatches to_be_applied+ when (nullFL to_be_applied) $ do+ putStrLn $ "You don't want to " ++ cmdName ++ " any patches, and that's fine with me!"+ exitSuccess+ checkPaths opts to_be_applied+ putVerbose opts $ text $ "Will " ++ cmdName ++ " the following patches:"+ putVerbose opts $ vcat $ mapFL description to_be_applied+ usOk :> usConflicted <- return $ partitionConflictingFL (commuterIdFL selfCommuter) us' to_be_applied++ when (lengthFL usConflicted > 0) $+ putInfo opts $ text "The following local patches are in conflict:"++ -- TODO: we assume the options apply only to the main+ -- command, review if there are any we should keep+ let patches_context = selectionContext LastReversed "suspend" applyPatchSelOpts Nothing Nothing++ (usKeep :> usToSuspend) <- runSelection (selectChanges usConflicted) patches_context++ (rOld, Sealed qs, _) <- return $ takeHeadRebaseFL us'+ repository' <- doSuspend opts repository qs rOld usToSuspend++ -- TODO This is a nasty hack, caused by the fact that readUnrecorded+ -- claims to read the tentative state but actual reads the committed state+ -- as a result we have to commit here so that tentativelyMergePatches does+ -- the right thing.+ finalizeRepositoryChanges repository' YesUpdateWorking (compression opts)+ >> revertRepositoryChanges repository' YesUpdateWorking++ Sealed pw <-+ tentativelyMergePatches+ repository' cmdName+ (allowConflicts opts) YesUpdateWorking+ (externalMerge opts)+ (wantGuiPause opts) (compression opts) (verbosity opts)+ (reorder opts) (diffingOpts opts)+ (usOk +>+ usKeep) to_be_applied++ invalidateIndex repository+ finalizeRepositoryChanges repository' YesUpdateWorking (compression opts)+ _ <- revertable $ applyToWorking repository' (verbosity opts) pw+ when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches pw+ putInfo opts $ text $ "Finished " ++ cmdName ++ "ing."++-- TODO I doubt this is right, e.g. withContext should be inherited+applyPatchSelOpts :: S.PatchSelectionOptions+applyPatchSelOpts = S.PatchSelectionOptions+ { S.verbosity = O.NormalVerbosity+ , S.matchFlags = []+ , S.diffAlgorithm = O.PatienceDiff+ , S.interactive = True+ , S.selectDeps = O.PromptDeps -- option not supported, use default+ , S.summary = O.NoSummary+ , S.withContext = O.NoContext+ }++obliteratePatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+obliteratePatchSelOpts opts = (patchSelOpts opts)+ { S.selectDeps = O.NoDeps+ }++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = parseFlags O.matchSeveralOrLast flags+ , S.diffAlgorithm = diffAlgorithm flags+ , S.interactive = isInteractive flags+ , S.selectDeps = selectDeps flags+ , S.summary = hasSummary O.NoSummary flags+ , S.withContext = O.NoContext+ }++log :: DarcsCommand [DarcsFlag]+log = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "log"+ , commandHelp = "List the currently suspended changes.\n"+ , commandDescription = "List the currently suspended changes"+ , commandPrereq = amInHashedRepository+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = logCmd+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc logAdvancedOpts+ , commandBasicOptions = odesc logBasicOpts+ , commandDefaults = defaultFlags logOpts+ , commandCheckOptions = ocheck logOpts+ , commandParseOptions = onormalise logOpts+ }++logBasicOpts :: DarcsOption a+ (Maybe O.Summary+ -> Maybe Bool+ -> a)+logBasicOpts+ = O.summary+ ^ O.interactive -- False++logAdvancedOpts :: DarcsOption a a+logAdvancedOpts = oid++logOpts :: DarcsOption a+ (Maybe O.Summary+ -> Maybe Bool+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)++logOpts = logBasicOpts `withStdOpts` logAdvancedOpts++logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+logCmd _ opts _files =+ withRepository (useCache opts) $+ RebaseJob (compression opts) (verbosity opts) YesUpdateWorking $ \repository -> do+ patches <- readRepo repository+ (_, Sealed ps, _) <- return $ takeHeadRebase patches+ let psToShow = toRebaseChanges ps+ if isInteractive opts+ then viewChanges (patchSelOpts opts) (mapFL Sealed2 psToShow)+ else do+ debugMessage "About to print the changes..."+ let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters+ emptyPatchSet = PatchSet NilRL NilRL+ patchSet = appendPSFL emptyPatchSet psToShow+ logInfo <-+ getLogInfo+ (maxCount opts)+ (toMatchFlags opts)+ (showChangesOnlyToFiles opts)+ Nothing+ (\_ qs -> return qs)+ patchSet+ let logDoc = changelog opts patchSet logInfo+ putDocLnWith printers logDoc++-- | changes is an alias for log+changes :: DarcsCommand [DarcsFlag]+changes = commandAlias "changes" Nothing log++{-+TODO:++ - amend-record shows the diff between the conflicted state and the resolution, which is unhelpful+ - testing+ - make aggregate commands+ - argument handling+ - what should happen to patch comment on unsuspend?+ - don't just drop explicit dependencies:+ - turn patchnames/explicit deps into patch type and use commutation+ - repo representation+ - seem to be able to get a messed up unrevert context+ - darcs pull/get can setup a rebase patch in a remote repo without the right format+ - rebase patches seem to parse as empty rather than failing??+ - warn about suspending conflicts+ - indication of expected conflicts on unsuspend+ - why isn't ! when you do x accurate?+ - rebase obliterate for more efficient removing of suspended patches+ - rebase pull needs more UI work+ - automatically answer yes re suspension+ - offer all patches (so they can be kept in order)+ - or perhaps rebase suspend --complement?+ - rebase changes for viewing suspended patch+ - matching options for rebase unsuspend (etc)+ - make unsuspend actually display the patch helpfully like normal selection+ - amended patches will often be in both the target repo and in the rebase context, detect?+ - can we be more intelligent about conflict resolutions?+ - --all option to unsuspend+ - review other conflict options for unsuspend+ - warning message on suspend about not being able to unsuspend with unrecorded changes+ - aborting during a rebase pull or rebase suspend causes it to leave the repo marked for rebase+ - rebase suspend needs --match+ - patch count: get English right in <n> suspended patch(es)+ - darcs check should check integrity of rebase patch+ - review existence of reify and inject commands - bit of an internals hack+ - need to move rebase to front before adding amend-record hint (and test this)+ - print something while moving rebase to front+-}+
+ src/Darcs/UI/Commands/Record.hs view
@@ -0,0 +1,567 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, PatternGuards #-}++module Darcs.UI.Commands.Record+ ( record+ , commit+ , getLog -- used by amend and tag, too+ , recordConfig, RecordConfig(..) -- needed for darcsden+ ) where++import Prelude hiding ( (^), catch )++import Control.Applicative ( (<$>) )+import Control.Exception ( handleJust, catch, IOException )+import Control.Monad ( when, unless, void )+import System.IO ( stdin )+import Data.List ( sort, isPrefixOf )+import Data.Char ( ord )+import System.Exit ( exitFailure, exitSuccess, ExitCode(..) )+import System.Directory ( removeFile )+import qualified Data.ByteString as B ( hPut )++import Darcs.Repository.Lock+ ( readLocaleFile+ , writeLocaleFile+ , appendToFile+ )+import Darcs.Patch.PatchInfoAnd ( n2pia )+import Darcs.Repository+ ( Repository+ , withRepoLock+ , RepoJob(..)+ , tentativelyAddPatch+ , finalizeRepositoryChanges+ , invalidateIndex+ , unrecordedChangesWithPatches+ , readRecorded+ , listRegisteredFiles+ )+import Darcs.Patch+ ( RepoPatch, Patchy, PrimOf, PrimPatch+ , namepatch, summaryFL, adddeps, fromPrims )+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), (:>)(..), nullFL )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Split ( primSplitter )+import Darcs.UI.External ( editFile )+import Darcs.UI.SelectChanges+ ( selectChanges+ , WhichChanges(..)+ , selectionContextPrim+ , runSelection+ , askAboutDepends+ )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+import Darcs.Util.Path ( FilePathLike, SubPath, toFilePath, AbsolutePath )+import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts+ , nodefaults+ , commandStub+ , setEnvDarcsFiles+ , setEnvDarcsPatches+ , amInHashedRepository+ )+import Darcs.UI.Commands.Util ( announceFiles, filterExistingFiles,+ testTentativeAndMaybeExit )+import Darcs.UI.Flags+ ( DarcsFlag+ , fileHelpAuthor+ , getAuthor+ , getDate+ , diffOpts+ , fixSubPaths+ )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, oparse, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( UpdateWorking (..), DryRun(NoDryRun) )+import Darcs.Repository.Util ( getMovesPs, getReplaces )+import Darcs.Util.Exception ( clarifyErrors )+import Darcs.Util.Prompt ( askUser, promptYorn )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Global ( darcsLastMessage )+import Darcs.Patch.Progress ( progressFL )+import Darcs.Util.Printer ( putDocLn, hPutDocLn, text, ($$), prefixLines, RenderMode(..) )+import Darcs.Util.ByteString ( encodeLocale )+import qualified Darcs.Util.Ratified as Ratified ( hGetContents )+import Storage.Hashed.Tree( Tree )++recordDescription :: String+recordDescription = "Create a patch from unrecorded changes."++recordHelp :: String+recordHelp =+ "The `darcs record` command is used to create a patch from changes in\n" +++ "the working tree. If you specify a set of files and directories,\n" +++ "changes to other files will be skipped.\n" +++ "\n" ++ recordHelp' +++ "\n" ++ recordHelp''++recordBasicOpts :: DarcsOption a+ (Maybe String+ -> Maybe String+ -> O.TestChanges+ -> Maybe Bool+ -> Bool+ -> Bool+ -> Maybe O.AskLongComment+ -> O.LookFor+ -> Maybe String+ -> O.WithContext+ -> O.DiffAlgorithm+ -> a)+recordBasicOpts+ = O.patchname+ ^ O.author+ ^ O.testChanges+ ^ O.interactive+ ^ O.pipe+ ^ O.askdeps+ ^ O.askLongComment+ ^ O.lookfor+ ^ O.workingRepoDir+ ^ O.withContext+ ^ O.diffAlgorithm++recordAdvancedOpts :: DarcsOption a+ (O.Logfile -> O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> a)+recordAdvancedOpts = O.logfile ^ O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable++recordOpts :: DarcsOption a+ (Maybe String+ -> Maybe String+ -> O.TestChanges+ -> Maybe Bool+ -> Bool+ -> Bool+ -> Maybe O.AskLongComment+ -> O.LookFor+ -> Maybe String+ -> O.WithContext+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.Logfile+ -> O.Compression+ -> O.UseIndex+ -> O.UMask+ -> O.SetScriptsExecutable+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+recordOpts = recordBasicOpts `withStdOpts` recordAdvancedOpts++data RecordConfig = RecordConfig+ { patchname :: Maybe String+ , author :: Maybe String+ , testChanges :: O.TestChanges+ , interactive :: Maybe Bool+ , pipe :: Bool+ , askDeps :: Bool+ , askLongComment :: Maybe O.AskLongComment+ , lookfor :: O.LookFor+ , _workingRepoDir :: Maybe String+ , withContext :: O.WithContext+ , diffAlgorithm :: O.DiffAlgorithm+ , verbosity :: O.Verbosity+ , logfile :: O.Logfile+ , compress :: O.Compression+ , useIndex :: O.UseIndex+ , umask :: O.UMask+ , sse :: O.SetScriptsExecutable+ , useCache :: O.UseCache+ }++recordConfig :: [DarcsFlag] -> RecordConfig+recordConfig = oparse (recordBasicOpts ^ O.verbosity ^ recordAdvancedOpts ^ O.useCache) RecordConfig++record :: DarcsCommand RecordConfig+record = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "record"+ , commandHelp = recordHelp+ , commandDescription = recordDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+ , commandCommand = recordCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = listRegisteredFiles+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc recordAdvancedOpts+ , commandBasicOptions = odesc recordBasicOpts+ , commandDefaults = defaultFlags recordOpts+ , commandCheckOptions = ocheck recordOpts+ , commandParseOptions = recordConfig+}++commitDescription :: String+commitDescription = "Redirect the user to record, push or send."++commitHelp :: String+commitHelp =+ "This command does not do anything.\n"+++ "If you want to save changes locally, use the `darcs record` command.\n"+++ "If you want to save a recorded patch to another repository, use the\n"+++ "`darcs push` or `darcs send` commands instead.\n"++commit :: DarcsCommand RecordConfig+commit = commandStub "commit" commitHelp commitDescription record++recordCmd :: (AbsolutePath, AbsolutePath) -> RecordConfig -> [String] -> IO ()+recordCmd fps cfg args = do+ checkNameIsNotOption (patchname cfg) (isInteractive True cfg)+ withRepoLock NoDryRun (useCache cfg) YesUpdateWorking (umask cfg) $ RepoJob $ \(repository :: Repository p wR wU wR) -> do+ files <- if null args then return Nothing+ else Just . sort <$> fixSubPaths fps args+ when (files == Just []) $ fail "No valid arguments were given."+ announceFiles files "Recording changes in"+ existing_files <- maybe (return Nothing)+ (fmap Just . filterExistingFiles repository (O.adds (lookfor cfg))) files+ when (existing_files == Just []) $+ fail "None of the files you specified exist!"+ debugMessage "About to get the unrecorded changes."+ Sealed replacePs <- if O.replaces (lookfor cfg) == O.YesLookForReplaces+ then getReplaces (diffingOpts cfg) repository files+ else return (Sealed NilFL)+ movesPs <- if O.moves (lookfor cfg) == O.YesLookForMoves+ then getMovesPs repository files+ else return NilFL+ changes <- unrecordedChangesWithPatches (diffingOpts cfg) repository files+ movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR)+ debugMessage "I've got unrecorded changes."+ case changes of+ NilFL | not (askDeps cfg) -> do+ -- We need to grab any input waiting for us, since we+ -- might break scripts expecting to send it to us; we+ -- don't care what that input is, though.+ void (getDate (pipe cfg))+ putStrLn "No changes!"+ exitFailure+ _ -> doRecord repository cfg existing_files changes++-- | Check user specified patch name is not accidentally a command line flag+checkNameIsNotOption :: Maybe String -> Bool -> IO ()+checkNameIsNotOption Nothing _ = return ()+checkNameIsNotOption _ False = return ()+checkNameIsNotOption (Just name) True =+ when (length name == 1 || (length name == 2 && head name == '-')) $ do+ confirmed <- promptYorn $ "You specified " ++ show name ++ " as the patch name. Is that really what you want?"+ unless confirmed $ putStrLn "Okay, aborting the record." >> exitFailure++doRecord :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)+ => Repository p wR wU wR -> RecordConfig -> Maybe [SubPath] -> FL (PrimOf p) wR wX -> IO ()+doRecord repository cfg files ps = do+ date <- getDate (pipe cfg)+ my_author <- getAuthor (author cfg) (pipe cfg)+ debugMessage "I'm slurping the repository."+ debugMessage "About to select changes..."+ pristine <- readRecorded repository+ (chs :> _ ) <- runSelection (selectChanges ps) $+ selectionContextPrim First "record" (patchSelOpts cfg) (Just primSplitter)+ (map toFilePath <$> files)+ (Just pristine)+ when (is_empty_but_not_askdeps chs) $+ do putStrLn "Ok, if you don't want to record anything, that's fine!"+ exitSuccess+ handleJust onlySuccessfulExits (\_ -> return ()) $+ do deps <- if askDeps cfg+ then askAboutDepends repository chs (patchSelOpts cfg) []+ else return []+ when (askDeps cfg) $ debugMessage "I've asked about dependencies."+ if nullFL chs && null deps+ then putStrLn "Ok, if you don't want to record anything, that's fine!"+ else do setEnvDarcsFiles chs+ (name, my_log, logf) <- getLog (patchname cfg) (pipe cfg) (logfile cfg) (askLongComment cfg) Nothing chs+ debugMessage ("Patch name as received from getLog: " ++ show (map ord name))+ doActualRecord repository cfg name date my_author my_log logf deps chs+ where is_empty_but_not_askdeps l+ | askDeps cfg = False+ -- a "partial tag" patch; see below.+ | otherwise = nullFL l++doActualRecord :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wR+ -> RecordConfig+ -> String -> String -> String+ -> [String] -> Maybe String+ -> [PatchInfo] -> FL (PrimOf p) wR wX -> IO ()+doActualRecord repository cfg name date my_author my_log logf deps chs =+ do debugMessage "Writing the patch file..."+ mypatch <- namepatch date name my_author my_log $+ fromPrims $ progressFL "Writing changes:" chs+ let pia = n2pia $ adddeps mypatch deps+ -- We don't care about the returned updated repository+ _ <- tentativelyAddPatch repository (compress cfg) (verbosity cfg) YesUpdateWorking+ $ pia+ invalidateIndex repository+ debugMessage "Applying to pristine..."+ testTentativeAndMaybeExit repository+ (verbosity cfg)+ (testChanges cfg)+ (sse cfg)+ (isInteractive True cfg)+ ("you have a bad patch: '" ++ name ++ "'")+ "record it" (Just failuremessage)+ finalizeRepositoryChanges repository YesUpdateWorking (compress cfg)+ `clarifyErrors` failuremessage+ debugMessage "Syncing timestamps..."+ removeLogFile logf+ unless (verbosity cfg == O.Quiet) $+ putDocLn $ text $ "Finished recording patch '" ++ name ++ "'"+ setEnvDarcsPatches (pia :>: NilFL)+ where+ removeLogFile :: Maybe String -> IO ()+ removeLogFile Nothing = return ()+ removeLogFile (Just lf) | lf == darcsLastMessage = return ()+ | otherwise = removeFile lf+ failuremessage = "Failed to record patch '"++name++"'" +++ case logf of Just lf -> "\nLogfile left in "++lf++"."+ Nothing -> ""++recordHelp' :: String+recordHelp' = unlines+ [ "Every patch has a name, an optional description, an author and a date."+ , ""+ , "Darcs will launch a text editor (see `darcs help environment`) after the"+ , "interactive selection, to let you enter the patch name (first line) and"+ , "the patch description (subsequent lines)."+ , ""+ , "The patch name should be a short sentence that concisely describes the"+ , "patch, such as \"Add error handling to main event loop.\" You can"+ , "supply it in advance with the `-m` option, in which case no text editor"+ , "is launched, unless you use the `--edit-long-comment` option."+ , ""+ , "The patch description is an optional block of free-form text. It is"+ , "used to supply additional information that doesn't fit in the patch"+ , "name. For example, it might include a rationale of WHY the change was"+ , "necessary."+ , ""+ , "A technical difference between patch name and patch description, is"+ , "that matching with the flag `-p` is only done on patch names."+ , ""+ , "Finally, the `--logfile` option allows you to supply a file that"+ , "already contains the patch name and patch description. This is"+ , "useful if a previous record failed and left a `darcs-record-0` file."+ , ""+ , unlines fileHelpAuthor+ , ""+ , "If you want to manually define any extra dependencies for your patch,"+ , "you can use the `--ask-deps` flag, and darcs will ask you for the patch's"+ , "dependencies. Some dependencies may be automatically inferred from the"+ , "patch's content and cannot be removed. "+ , "A patch with specific dependencies can be empty."+ , ""+ , "The patch date is generated automatically. It can only be spoofed by"+ , "using the `--pipe` option."+ , ""+ , "If you run record with the `--pipe` option, you will be prompted for"+ , "the patch date, author, and the long comment. The long comment will extend"+ , "until the end of file or stdin is reached (ctrl-D on Unixy systems, ctrl-Z"+ , "on systems running a Microsoft OS)."+ , ""+ , "This interface is intended for scripting darcs, in particular for writing"+ , "repository conversion scripts. The prompts are intended mostly as a useful"+ , "guide (since scripts won't need them), to help you understand the format in"+ , "which to provide the input. Here's an example of what the `--pipe`"+ , "prompts look like:"+ , ""+ , " What is the date? Mon Nov 15 13:38:01 EST 2004"+ , " Who is the author? David Roundy"+ , " What is the log? One or more comment lines"+ ]++data PName = FlagPatchName String | PriorPatchName String | NoPatchName++-- | Get the patch name and long description from one of+--+-- * the configuration (flags, defaults, hard-coded)+--+-- * an existing log file+--+-- * stdin (e.g. a pipe)+--+-- * a text editor+--+-- It ensures the patch name is not empty nor starts with the prefix TAG.+--+-- The last result component is a possible path to a temporary file that should be removed later.+getLog :: forall prim wX wY . (Patchy prim, PrimPatch prim)+ => Maybe String -- ^ patchname option+ -> Bool -- ^ pipe option+ -> O.Logfile -- ^ logfile option+ -> Maybe O.AskLongComment -- ^ askLongComment option+ -> Maybe (String, [String]) -- ^ possibly an existing patch name and long description+ -> FL prim wX wY -- ^ changes to record+ -> IO (String, [String], Maybe String) -- ^ patch name, long description and possibly the path+ -- to the temporary file that should be removed later+getLog m_name has_pipe log_file ask_long m_old chs = go has_pipe log_file ask_long where+ go True _ _ = do+ p <- case patchname_specified of+ FlagPatchName p -> return p+ PriorPatchName p -> return p+ NoPatchName -> prompt_patchname False+ putStrLn "What is the log?"+ thelog <- lines `fmap` Ratified.hGetContents stdin+ return (p, thelog, Nothing)+ go _ (O.Logfile { O._logfile = Just f }) _ = do+ mlp <- lines `fmap` readLocaleFile f `catch` (\(_ :: IOException) -> return [])+ firstname <- case (patchname_specified, mlp) of+ (FlagPatchName p, []) -> return p+ (_, p:_) -> if badName p+ then prompt_patchname True+ else return p -- logfile trumps prior!+ (PriorPatchName p, []) -> return p+ (NoPatchName, []) -> prompt_patchname True+ append_info f firstname+ when (ask_long == Just O.YesEditLongComment) (void $ editFile f)+ (name, thelog) <- read_long_comment f firstname+ return (name, thelog, if O._rmlogfile log_file then Just $ toFilePath f else Nothing)+ go _ _ (Just O.YesEditLongComment) =+ case patchname_specified of+ FlagPatchName p -> actually_get_log p+ PriorPatchName p -> actually_get_log p+ NoPatchName -> actually_get_log ""+ go _ _ (Just O.NoEditLongComment) =+ case patchname_specified of+ FlagPatchName p -> return (p, default_log, Nothing) -- record (or amend) -m+ PriorPatchName p -> return (p, default_log, Nothing) -- amend+ NoPatchName -> do p <- prompt_patchname True -- record+ return (p, [], Nothing)+ go _ _ (Just O.PromptLongComment) =+ case patchname_specified of+ FlagPatchName p -> prompt_long_comment p -- record (or amend) -m+ PriorPatchName p -> prompt_long_comment p+ NoPatchName -> prompt_patchname True >>= prompt_long_comment+ go _ _ Nothing =+ case patchname_specified of+ FlagPatchName p -> return (p, default_log, Nothing) -- record (or amend) -m+ PriorPatchName "" -> actually_get_log ""+ PriorPatchName p -> return (p, default_log, Nothing)+ NoPatchName -> actually_get_log ""++ patchname_specified = case (m_name, m_old) of+ (Just name, _) | badName name -> NoPatchName+ | otherwise -> FlagPatchName name+ (Nothing, Just (name,_)) -> PriorPatchName name+ (Nothing, Nothing) -> NoPatchName++ badName "" = True+ badName n = "TAG" `isPrefixOf` n++ default_log = case m_old of+ Nothing -> []+ Just (_,l) -> l++ prompt_patchname retry =+ do n <- askUser "What is the patch name? "+ if badName n+ then if retry then prompt_patchname retry+ else fail "Bad patch name!"+ else return n++ prompt_long_comment oldname =+ do y <- promptYorn "Do you want to add a long comment?"+ if y then actually_get_log oldname+ else return (oldname, [], Nothing)++ actually_get_log p = do let logf = darcsLastMessage+ -- TODO: make sure encoding used for logf is the same everywhere+ -- probably should be locale because the editor will assume it+ writeLocaleFile logf $ unlines $ p : default_log+ append_info logf p+ _ <- editFile logf+ (name,long) <- read_long_comment logf p+ if badName name+ then do putStrLn "WARNING: empty or incorrect patch name!"+ pn <- prompt_patchname True+ return (pn, long, Nothing)+ else return (name,long,Just logf)++ read_long_comment :: FilePathLike p => p -> String -> IO (String, [String])+ read_long_comment f oldname =+ do f' <- readLocaleFile f+ let t = filter (not.("#" `isPrefixOf`)) $ (lines.filter (/='\r')) f'+ case t of [] -> return (oldname, [])+ (n:ls) -> return (n, ls)++ append_info f oldname =+ do fc <- readLocaleFile f+ appendToFile f $ \h ->+ do case fc of+ _ | null (lines fc) -> B.hPut h (encodeLocale (oldname ++ "\n"))+ | last fc /= '\n' -> B.hPut h (encodeLocale "\n")+ | otherwise -> return ()+ hPutDocLn Encode h+ $ text "# Please enter the patch name in the first line, and"+ $$ text "# optionally, a long description in the following lines."+ $$ text "#"+ $$ text "# Lines starting with '#' will be ignored."+ $$ text "#"+ $$ text "#"+ $$ text "# This patch contains the following changes:"+ $$ text "#"+ $$ prefixLines (text "#") (summaryFL chs)++onlySuccessfulExits :: ExitCode -> Maybe ()+onlySuccessfulExits ExitSuccess = Just ()+onlySuccessfulExits _ = Nothing++recordHelp'' :: String+recordHelp'' =+ "If a test command has been defined with `darcs setpref`, attempting to\n" +++ "record a patch will cause the test command to be run in a clean copy\n" +++ "of the working tree (that is, including only recorded changes). If\n" +++ "the test fails, you will be offered to abort the record operation.\n" +++ "\n" +++ "The `--set-scripts-executable` option causes scripts to be made\n" +++ "executable in the clean copy of the working tree, prior to running the\n" +++ "test. See `darcs get` for an explanation of the script heuristic.\n" +++ "\n" +++ "If your test command is tediously slow (e.g. `make all`) and you are\n" +++ "recording several patches in a row, you may wish to use `--no-test` to\n" +++ "skip all but the final test.\n" +++ "\n" +++ "To see some context (unchanged lines) around each change, use the\n" +++ "`--unified` option.\n"++patchSelOpts :: RecordConfig -> S.PatchSelectionOptions+patchSelOpts cfg = S.PatchSelectionOptions+ { S.verbosity = verbosity cfg+ , S.matchFlags = []+ , S.diffAlgorithm = diffAlgorithm cfg+ , S.interactive = isInteractive True cfg+ , S.selectDeps = O.PromptDeps -- option not supported, use default+ , S.summary = O.NoSummary -- option not supported, use default+ , S.withContext = withContext cfg+ }++diffingOpts :: RecordConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)+diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) False (diffAlgorithm cfg)++isInteractive :: Bool -> RecordConfig -> Bool+isInteractive def = maybe def id . interactive
+ src/Darcs/UI/Commands/Remove.hs view
@@ -0,0 +1,207 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.UI.Commands.Remove ( remove, rm, unadd ) where++import Prelude hiding ( (^) )++import Control.Monad ( when, foldM )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults,+ commandAlias, commandStub,+ putWarning+ , amInHashedRepository+ )+import Darcs.UI.Commands.Add( expandDirs )+import Darcs.UI.Flags+ ( DarcsFlag, useCache, dryRun, umask, diffAlgorithm, fixSubPaths, verbosity )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( UpdateWorking (..) )+import Darcs.Repository+ ( Repository+ , withRepoLock+ , RepoJob(..)+ , addToPending+ , readRecordedAndPending+ , readUnrecorded+ , listRegisteredFiles+ )+import Darcs.Repository.Diff( treeDiff )+import Darcs.Patch ( RepoPatch, PrimOf, PrimPatch, adddir, rmdir, addfile, rmfile,+ listTouchedFiles )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )+import Darcs.Repository.Prefs ( filetypeFunction, FileType )+import Storage.Hashed.Tree( Tree, TreeItem(..), find, modifyTree, expand, list )+import Darcs.Util.Path( anchorPath, AnchoredPath, fn2fp, SubPath, sp2fn+ , AbsolutePath )+import Storage.Hashed( floatPath )++import Darcs.Util.Printer ( text )+++removeDescription :: String+removeDescription = "Remove files from version control."++removeHelp :: String+removeHelp =+ "The `darcs remove` command exists primarily for symmetry with `darcs\n" +++ "add`, as the normal way to remove a file from version control is\n" +++ "simply to delete it from the working tree. This command is only\n" +++ "useful in the unusual case where one wants to record a removal patch\n" +++ "WITHOUT deleting the copy in the working tree (which can be re-added).\n" +++ "\n" +++ "Note that applying a removal patch to a repository (e.g. by pulling\n" +++ "the patch) will ALWAYS affect the working tree of that repository.\n"++removeBasicOpts :: DarcsOption a (Maybe String -> Bool -> a)+removeBasicOpts = O.workingRepoDir ^ O.recursive++removeAdvancedOpts :: DarcsOption a (O.UMask -> a)+removeAdvancedOpts = O.umask++removeOpts :: DarcsOption a+ (Maybe String+ -> Bool+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UMask+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+removeOpts = removeBasicOpts `withStdOpts` removeAdvancedOpts++remove :: DarcsCommand [DarcsFlag]+remove = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "remove"+ , commandHelp = removeHelp+ , commandDescription = removeDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["<FILE or DIRECTORY> ..."]+ , commandCommand = removeCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = listRegisteredFiles+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc removeAdvancedOpts+ , commandBasicOptions = odesc removeBasicOpts+ , commandDefaults = defaultFlags removeOpts+ , commandCheckOptions = ocheck removeOpts+ , commandParseOptions = onormalise removeOpts+ }++removeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+removeCmd fps opts relargs = do+ when (null relargs) $+ fail "Nothing specified, nothing removed."+ origfiles <- fixSubPaths fps relargs+ when (null origfiles) $+ fail "No valid arguments were given."+ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ args <- if parseFlags O.recursive opts+ then reverse `fmap` expandDirs False origfiles+ else return origfiles+ Sealed p <- makeRemovePatch opts repository args+ let notQuiet = verbosity opts /= O.Quiet+ when (nullFL p && not (null origfiles) && notQuiet) $+ fail "No files were removed."+ addToPending repository YesUpdateWorking p+ when notQuiet $+ putStr $ unlines $ ["Will stop tracking:"] ++ listTouchedFiles p++-- | makeRemovePatch builds a list of patches to remove the given filepaths.+-- This function does not recursively process directories. The 'Recursive'+-- flag should be handled by the caller by adding all offspring of a directory+-- to the files list.+makeRemovePatch :: (RepoPatch p, ApplyState p ~ Tree)+ => [DarcsFlag] -> Repository p wR wU wT+ -> [SubPath] -> IO (Sealed (FL (PrimOf p) wU))+makeRemovePatch opts repository files =+ do recorded <- expand =<< readRecordedAndPending repository+ unrecorded <- readUnrecorded repository $ Just files+ ftf <- filetypeFunction+ result <- foldM removeOnePath (ftf,recorded,unrecorded, []) $ map (floatPath . fn2fp . sp2fn) files+ case result of+ (_, _, _, patches) -> return $+ unFreeLeft $ foldr (joinGap (+>+)) (emptyGap NilFL) $ reverse patches+ where removeOnePath (ftf, recorded, unrecorded, patches) f = do+ let recorded' = modifyTree recorded f Nothing+ unrecorded' = modifyTree unrecorded f Nothing+ local <- makeRemoveGap opts ftf recorded unrecorded unrecorded' f+ -- we can tell if the remove succeeded by looking if local is+ -- empty. If the remove succeeded, we should pass on updated+ -- recorded and unrecorded that reflect the removal+ return $ case local of+ Just gap -> (ftf, recorded', unrecorded', gap : patches)+ _ -> (ftf, recorded, unrecorded, patches)++-- | Takes a file path and returns the FL of patches to remove that, wrapped in+-- a 'Gap'.+-- Returns 'Nothing' in case the path cannot be removed (if it is not tracked,+-- or if it's a directory and it's not tracked).+-- The three 'Tree' arguments are the recorded state, the unrecorded state+-- excluding the removal of this file, and the unrecorded state including the+-- removal of this file.+makeRemoveGap :: PrimPatch prim => [DarcsFlag] -> (FilePath -> FileType)+ -> Tree IO -> Tree IO -> Tree IO -> AnchoredPath+ -> IO (Maybe (FreeLeft (FL prim)))+makeRemoveGap opts ftf recorded unrecorded unrecorded' f =+ case (find recorded f, find unrecorded f) of+ (Just (SubTree _), Just (SubTree unrecordedChildren)) ->+ if not $ null (list unrecordedChildren)+ then skipAndWarn "it is not empty"+ else return $ Just $ freeGap (rmdir f_fp :>: NilFL)+ (Just (File _), Just (File _)) -> do+ Just `fmap` treeDiff (diffAlgorithm opts) ftf unrecorded unrecorded'+ (Just (File _), _) ->+ return $ Just $ freeGap (addfile f_fp :>: rmfile f_fp :>: NilFL)+ (Just (SubTree _), _) ->+ return $ Just $ freeGap (adddir f_fp :>: rmdir f_fp :>: NilFL)+ (_, _) -> skipAndWarn "it is not tracked by darcs"+ where f_fp = anchorPath "" f+ skipAndWarn reason =+ do putWarning opts . text $ "Can't remove " ++ f_fp+ ++ " (" ++ reason ++ ")"+ return Nothing+++rmDescription :: String+rmDescription = "Help newbies find `darcs remove'."++rmHelp :: String+rmHelp =+ "The `darcs rm' command does nothing.\n" +++ "\n" +++ "The normal way to remove a file from version control is simply to\n" +++ "delete it from the working tree. To remove a file from version\n" +++ "control WITHOUT affecting the working tree, see `darcs remove'.\n"++rm :: DarcsCommand [DarcsFlag]+rm = commandStub "rm" rmHelp rmDescription remove++unadd :: DarcsCommand [DarcsFlag]+unadd = commandAlias "unadd" Nothing remove+
+ src/Darcs/UI/Commands/Repair.hs view
@@ -0,0 +1,186 @@+-- Copyright (C) 2002-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Repair+ (+ repair+ , check+ ) 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 )+import System.FilePath ( (</>) )++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, putInfo, commandAlias, amInHashedRepository )+import Darcs.UI.Flags as F+ ( DarcsFlag(Quiet,DryRun)+ , verbosity, dryRun, umask, useIndex+ , useCache, compression, diffAlgorithm )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( UpdateWorking (..) )+import Darcs.Repository.Repair( replayRepository, checkIndex,+ replayRepositoryInTemp,+ RepositoryConsistency(..) )+import Darcs.Repository ( Repository, withRepository,+ readRecorded, RepoJob(..),+ withRepoLock, replacePristine, writePatchSet )+import Darcs.Patch ( RepoPatch, showPatch, PrimOf )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Witnesses.Ordered ( FL(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft )+import Darcs.Repository.Prefs ( filetypeFunction )+import Darcs.Repository.Diff( treeDiff )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Printer ( text, ($$), (<+>) )+import Darcs.Util.Path ( AbsolutePath )+import Storage.Hashed.Tree( Tree )+++repairDescription :: String+repairDescription = "Repair a corrupted repository."++repairHelp :: String+repairHelp =+ "The `darcs repair` command attempts to fix corruption in the current\n" +++ "repository. Currently it can only repair damage to the pristine tree,\n" +++ "which is where most corruption occurs.\n" +++ "This command rebuilds a pristine tree by applying successively the\n" +++ "patches in the repository to an empty tree.\n" +++ "\n" +++ "The flag `--dry-run` make this operation read-only, making darcs exit\n" +++ "unsuccessfully (with a non-zero exit status) if the rebuilt pristine is\n" +++ "different from the current pristine.\n"++repairBasicOpts :: DarcsOption a+ (Maybe String -> O.UseIndex -> O.DryRun -> O.DiffAlgorithm -> a)+repairBasicOpts = O.workingRepoDir ^ O.useIndex ^ O.dryRun ^ O.diffAlgorithm++repairAdvancedOpts :: DarcsOption a (O.UMask -> a)+repairAdvancedOpts = O.umask++repairOpts :: DarcsOption a+ (Maybe String+ -> O.UseIndex+ -> O.DryRun+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UMask+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+repairOpts = repairBasicOpts `withStdOpts` repairAdvancedOpts++repair :: DarcsCommand [DarcsFlag]+repair = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "repair"+ , commandHelp = repairHelp+ , commandDescription = repairDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = repairCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc repairAdvancedOpts+ , commandBasicOptions = odesc repairBasicOpts+ , commandDefaults = defaultFlags repairOpts+ , commandCheckOptions = ocheck repairOpts+ , commandParseOptions = onormalise repairOpts+ }++repairCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+repairCmd _ opts _+ | DryRun `elem` opts = withRepository (useCache opts) (RepoJob (check' opts))+ | otherwise = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ replayRepository (F.diffAlgorithm opts) repository (compression opts) (verbosity opts) $ \state ->+ case state of+ RepositoryConsistent ->+ putStrLn "The repository is already consistent, no changes made."+ BrokenPristine tree -> do+ putStrLn "Fixing pristine tree..."+ replacePristine repository tree+ BrokenPatches tree newps -> do+ putStrLn "Writing out repaired patches..."+ _ <- writePatchSet newps (useCache opts)+ putStrLn "Fixing pristine tree..."+ replacePristine repository tree+ index_ok <- checkIndex repository (Quiet `elem` opts)+ unless index_ok $ do renameFile (darcsdir </> "index") (darcsdir </> "index.bad")+ putStrLn "Bad index discarded."++check'+ :: forall p wR wU wT . (RepoPatch p, ApplyState p ~ Tree)+ => [DarcsFlag] -> Repository p wR wU wT -> IO ()+check' opts repository = do+ state <- replayRepositoryInTemp (F.diffAlgorithm opts) repository (compression opts) (verbosity opts)+ failed <-+ case state of+ RepositoryConsistent -> do+ putInfo opts $ text "The repository is consistent!"+ return False+ BrokenPristine newpris -> do+ brokenPristine newpris+ return True+ BrokenPatches newpris _ -> do+ brokenPristine newpris+ putInfo opts $ text "Found broken patches."+ return True+ bad_index <- if useIndex opts == O.IgnoreIndex+ then return False+ else not <$> checkIndex repository (Quiet `elem` opts)+ when bad_index $ putInfo opts $ text "Bad index."+ exitWith $ if failed || bad_index then ExitFailure 1 else ExitSuccess+ where+ brokenPristine newpris = do+ putInfo opts $ text "Looks like we have a difference..."+ mc' <- (Just `fmap` 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"+ Just mc -> do+ ftf <- filetypeFunction+ Sealed (diff :: FL (PrimOf p) wR wR2)+ <- unFreeLeft `fmap` treeDiff (F.diffAlgorithm opts) ftf newpris mc :: IO (Sealed (FL (PrimOf p) wR))+ putInfo opts $ case diff of+ NilFL -> text "Nothing"+ patch -> text "Difference: " <+> showPatch patch+ putInfo opts $ text "" $$ text "Inconsistent repository!"++-- |check is an alias for repair, with implicit DryRun flag.+check :: DarcsCommand [DarcsFlag]+check = checkAlias { commandCommand = checkCmd+ , commandDescription = checkDesc+ }+ where+ checkAlias = commandAlias "check" Nothing repair+ checkCmd fps fs = commandCommand repair fps (DryRun : fs)+ checkDesc = "Alias for `darcs " ++ commandName repair ++ " --dry-run'."
+ src/Darcs/UI/Commands/Replace.hs view
@@ -0,0 +1,298 @@+-- Copyright (C) 2002-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.UI.Commands.Replace+ ( replace+ , defaultToks+ ) where++import Prelude hiding ( (^), catch )++import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as BS+import Data.Char ( isSpace )+import Data.Maybe ( isJust )+import Control.Applicative( (<$>) )+import Control.Exception ( catch, IOException )+import Control.Monad ( unless, filterM, void )+import Storage.Hashed.Tree( readBlob, modifyTree, findFile, TreeItem(..), Tree+ , makeBlobBS )+import Darcs.Util.Path( SubPath, toFilePath, AbsolutePath )+import Darcs.UI.Flags+ ( DarcsFlag( ForceReplace, Toks )+ , verbosity, useCache, dryRun, umask, diffAlgorithm, fixSubPaths )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( UpdateWorking(..) )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.Repository.Diff( treeDiff )+import Darcs.Patch ( Patchy, PrimPatch, tokreplace, forceTokReplace+ , applyToTree )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Patchy ( Apply )+import Darcs.Patch.RegChars ( regChars )+import Darcs.Repository+ ( withRepoLock+ , RepoJob(..)+ , addToPending+ , applyToWorking+ , readUnrecorded+ , readRecordedAndPending+ , listRegisteredFiles+ )+import Darcs.Repository.Prefs ( FileType(TextFile) )+import Darcs.Repository.Util ( floatSubPath, defaultToks )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL, nullFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..), unFreeLeft, unseal )++#include "impossible.h"++replaceDescription :: String+replaceDescription = "Substitute one word for another."++replaceHelp :: String+replaceHelp =+ "In addition to line-based patches, Darcs supports a limited form of\n" +++ "lexical substitution. Files are treated as sequences of words, and\n" +++ "each occurrence of the old word is replaced by the new word.\n" +++ "This is intended to provide a clean way to rename a function or\n" +++ "variable. Such renamings typically affect lines all through the\n" +++ "source code, so a traditional line-based patch would be very likely to\n" +++ "conflict with other branches, requiring manual merging.\n" +++ "\n" +++ "Files are tokenized according to one simple rule: words are strings of\n" +++ "valid token characters, and everything between them (punctuation and\n" +++ -- FIXME: this heuristic is ham-fisted and silly. Can we drop it?+ "whitespace) is discarded. By default, valid token characters are\n" +++ "letters, numbers and the underscore (i.e. `[A-Za-z0-9_]`). However if\n" +++ "the old and/or new token contains either a hyphen or period, BOTH\n" +++ "hyphen and period are treated as valid (i.e. `[A-Za-z0-9_.-]`).\n" +++ "\n" +++ "The set of valid characters can be customized using the `--token-chars`\n" +++ "option. The argument must be surrounded by square brackets. If a\n" +++ "hyphen occurs between two characters in the set, it is treated as a\n" +++ "set range. For example, in most locales `[A-Z]` denotes all uppercase\n" +++ "letters. If the first character is a caret, valid tokens are taken to\n" +++ "be the complement of the remaining characters. For example, `[^:\\n]`\n" +++ "could be used to match fields in the passwd(5), where records and\n" +++ "fields are separated by newlines and colons respectively.\n" +++ "\n" +++ "If you choose to use `--token-chars`, you are STRONGLY encouraged to do\n" +++ "so consistently. The consequences of using multiple replace patches\n" +++ "with different `--token-chars` arguments on the same file are not well\n" +++ "tested nor well understood.\n" +++ "\n" +++ "By default Darcs will refuse to perform a replacement if the new token\n" +++ "is already in use, because the replacements would be not be\n" +++ "distinguishable from the existing tokens. This behaviour can be\n" +++ "overridden by supplying the `--force` option, but an attempt to `darcs\n" +++ "rollback` the resulting patch will affect these existing tokens.\n" +++ "\n" +++ "Limitations:\n" +++ "\n" +++ "The tokenizer treats files as byte strings, so it is not possible for\n" +++ "`--token-chars` to include multi-byte characters, such as the non-ASCII\n" +++ "parts of UTF-8. Similarly, trying to replace a \"high-bit\" character\n" +++ "from a unibyte encoding will also result in replacement of the same\n" +++ "byte in files with different encodings. For example, an acute a from\n" +++ "ISO 8859-1 will also match an alpha from ISO 8859-7.\n" +++ "\n" +++ "Due to limitations in the patch file format, `--token-chars` arguments\n" +++ "cannot contain literal whitespace. For example, `[^ \\n\\t]` cannot be\n" +++ "used to declare all characters except the space, tab and newline as\n" +++ "valid within a word, because it contains a literal space.\n" +++ "\n" +++ "Unlike POSIX regex(7) bracket expressions, character classes (such as\n" +++ "`[[:alnum:]]`) are NOT supported by `--token-chars`, and will be silently\n" +++ "treated as a simple set of characters.\n"++replaceBasicOpts :: DarcsOption a (Maybe String -> Bool -> Maybe String -> a)+replaceBasicOpts = O.tokens ^ O.forceReplace ^ O.workingRepoDir++replaceAdvancedOpts :: DarcsOption a (O.UseIndex -> O.UMask -> a)+replaceAdvancedOpts = O.useIndex ^ O.umask++replaceOpts :: DarcsOption a+ (Maybe String+ -> Bool+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseIndex+ -> O.UMask+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+replaceOpts = replaceBasicOpts `withStdOpts` replaceAdvancedOpts++replace :: DarcsCommand [DarcsFlag]+replace = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "replace"+ , commandHelp = replaceHelp+ , commandDescription = replaceDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = [ "<OLD>"+ , "<NEW>"+ , "<FILE> ..."+ ]+ , commandCommand = replaceCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = listRegisteredFiles+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc replaceAdvancedOpts+ , commandBasicOptions = odesc replaceBasicOpts+ , commandDefaults = defaultFlags replaceOpts+ , commandCheckOptions = ocheck replaceOpts+ , commandParseOptions = onormalise replaceOpts+ }++replaceCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+replaceCmd fps opts (old : new : relfs@(_ : _)) =+ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $+ \repository -> do+ fs <- fixSubPaths fps relfs+ toks <- chooseToks opts old new+ let checkToken tok = unless (isTok toks tok) $+ fail $ "'" ++ tok ++ "' is not a valid token!"+ mapM_ checkToken [ old, new ]+ working <- readUnrecorded repository Nothing+ pending <- readRecordedAndPending repository+ files <- filterM (exists working) fs+ Sealed replacePs <- mapSeal concatFL . toFL <$>+ mapM (doReplace toks pending working) files+ addToPending repository YesUpdateWorking replacePs+ void $ applyToWorking repository (verbosity opts) replacePs `catch` \(e :: IOException) ->+ fail $ "Can't do replace on working!\n"+ ++ "Perhaps one of the files already" ++ " contains '"+ ++ new ++ "'?\n"+ ++ show e+ where+ exists tree file = if isJust $ findFile tree (floatSubPath file)+ then return True+ else do putStrLn $ skipmsg file+ return False++ skipmsg f = "Skipping file '" ++ toFilePath f+ ++ "' which isn't in the repository."++ doReplace :: forall prim . (Patchy prim, PrimPatch prim,+ ApplyState prim ~ Tree) => String -> Tree IO -> Tree IO+ -> SubPath -> IO (FreeLeft (FL prim))+ doReplace toks pend work f = do+ let maybeReplace p = isJust <$> maybeApplyToTree replacePatch p+ workReplaced <- maybeReplace work+ pendReplaced <- maybeReplace pend+ if workReplaced && pendReplaced+ then return $ joinGap (:>:) (freeGap replacePatch) gapNilFL+ else if ForceReplace `elem` opts+ then getForceReplace f toks work+ else putStrLn existsMsg >> return gapNilFL+ where+ existsMsg = "Skipping file '" ++ fp ++ "'\nPerhaps the recorded"+ ++ " version of this file already contains '" ++ new+ ++ "'?\nUse the --force option to override."+ gapNilFL = emptyGap NilFL+ fp = toFilePath f+ replacePatch = tokreplace fp toks old new++ ftf _ = TextFile++ -- | getForceReplace returns the list of patches that consists first of+ -- hunk patches to normalise all occurences of the target token (changing+ -- them back to the source token) and then the replace patches from+ -- oldToken -> newToken.+ getForceReplace :: PrimPatch prim => SubPath -> String -> Tree IO+ -> IO (FreeLeft (FL prim))+ getForceReplace f toks tree = do+ let path = floatSubPath f+ content <- readBlob $ fromJust $ findFile tree path+ let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old)+ (BS.concat $ BL.toChunks content)+ tree' = modifyTree tree path . Just . File $ makeBlobBS newcontent+ normaliseNewTokPatch <- treeDiff (diffAlgorithm opts) ftf tree tree'+ unless (unseal nullFL (unFreeLeft normaliseNewTokPatch)) $+ putStrLn $ "Don't be surprised!\n"+ ++ "I've changed all instances of '" ++ new ++ "' to '"+ ++ old ++ "' first\n"+ ++ "so that darcs replace can token-replace them"+ ++ " back into '" ++ new ++ "' again."+ return . joinGap (+>+) normaliseNewTokPatch $ freeGap $+ tokreplace (toFilePath f) toks old new :>: NilFL+replaceCmd _ _ [_, _] = fail "You need to supply a list of files to replace in!"+replaceCmd _ _ _ = fail "Usage: darcs replace OLD NEW [FILES]"++-- | Attempts to apply a given replace patch to a Tree. If the apply fails (if+-- the file the patch applies to already contains the target token), we return+-- Nothing, otherwise we return the updated Tree.+maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p wX wY -> Tree IO+ -> IO (Maybe (Tree IO))+maybeApplyToTree patch tree =+ (Just `fmap` applyToTree patch tree) `catch` (\(_ :: IOException) -> return Nothing)++filenameToks :: String+filenameToks = "A-Za-z_0-9\\-\\."++-- | Given a set of characters and a string, returns true iff the string+-- contains only characters from the set. A set beginning with a caret (@^@) is+-- treated as a complementary set.+isTok :: String -> String -> Bool+isTok _ "" = False+isTok toks s = all (regChars toks) s++-- | This function checks for @--token-chars@ on the command-line. If found,+-- it validates the argument and returns it, without the surrounding square+-- brackets. Otherwise, it returns either 'defaultToks' or 'filenameToks' as+-- explained in 'replaceHelp'.+--+-- Note: Limitations in the current replace patch file format prevents tokens+-- and token-char specifiers from containing any whitespace.+chooseToks :: [DarcsFlag] -> String -> String -> IO String+chooseToks (Toks t : _) a b+ | length t <= 2 =+ badTokenSpec $ "It must contain more than 2 characters, because it"+ ++ " should be enclosed in square brackets"+ | head t /= '[' || last t /= ']' =+ badTokenSpec "It should be enclosed in square brackets"+ | '^' == head tok && length tok == 1 =+ badTokenSpec "Must be at least one character in the complementary set"+ | any isSpace t =+ badTokenSpec "Space is not allowed in the spec"+ | any isSpace a = badTokenSpec $ spaceyToken a+ | any isSpace b = badTokenSpec $ spaceyToken b+ | not (isTok tok a) = badTokenSpec $ notAToken a+ | not (isTok tok b) = badTokenSpec $ notAToken b+ | otherwise = return tok+ where+ tok = init $ tail t :: String+ badTokenSpec msg = fail $ "Bad token spec: '" ++ t ++ "' (" ++ msg ++ ")"+ spaceyToken x = x ++ " must not contain any space"+ notAToken x = x ++ " is not a token, according to your spec"++chooseToks (_ : fs) a b = chooseToks fs a b+chooseToks [] a b = if isTok defaultToks a && isTok defaultToks b+ then return defaultToks+ else return filenameToks
+ src/Darcs/UI/Commands/Revert.hs view
@@ -0,0 +1,169 @@+-- Copyright (C) 2002-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Revert ( revert ) where++import Prelude hiding ( (^), catch )++import Control.Applicative ( (<$>) )+import Control.Exception ( catch, IOException )+import Control.Monad ( when )+import Data.List ( sort )++import Darcs.UI.Flags+ ( DarcsFlag( Debug ), diffingOpts, verbosity, diffAlgorithm, isInteractive, isUnified+ , dryRun, umask, useCache, fixSubPaths )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( UpdateWorking(..) )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Commands.Util ( announceFiles )+import Darcs.UI.Commands.Unrevert ( writeUnrevert )+import Darcs.Util.Path ( toFilePath, AbsolutePath )+import Darcs.Repository+ ( withRepoLock+ , RepoJob(..)+ , addToPending+ , applyToWorking+ , readRecorded+ , unrecordedChanges+ , listRegisteredFiles+ )+import Darcs.Patch ( invert, effectOnFilePaths, commute )+import Darcs.Patch.Split ( reversePrimSplitter )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), nullFL, (+>+) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.UI.SelectChanges+ ( selectChanges+ , WhichChanges(Last)+ , selectionContextPrim+ , runSelection+ )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+import Darcs.Patch.TouchesFiles ( chooseTouching )+++revertDescription :: String+revertDescription = "Discard unrecorded changes."++revertHelp :: String+revertHelp =+ "The `darcs revert` command discards unrecorded changes the working\n" +++ "tree. As with `darcs record`, you will be asked which hunks (changes)\n" +++ "to revert. The `--all` switch can be used to avoid such prompting. If\n" +++ "files or directories are specified, other parts of the working tree\n" +++ "are not reverted.\n" +++ "\n" +++ "In you accidentally reverted something you wanted to keep (for\n" +++ "example, typing `darcs rev -a` instead of `darcs rec -a`), you can\n" +++ "immediately run `darcs unrevert` to restore it. This is only\n" +++ "guaranteed to work if the repository has not changed since `darcs\n" +++ "revert` ran.\n"++revertBasicOpts :: DarcsOption a+ (Maybe Bool -> Maybe String -> O.WithContext -> O.DiffAlgorithm -> a)+revertBasicOpts+ = O.interactive -- True+ ^ O.workingRepoDir+ ^ O.withContext+ ^ O.diffAlgorithm++revertAdvancedOpts :: DarcsOption a (O.UseIndex -> O.UMask -> a)+revertAdvancedOpts = O.useIndex ^ O.umask++revertOpts :: DarcsOption a+ (Maybe Bool+ -> Maybe String+ -> O.WithContext+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseIndex+ -> O.UMask+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+revertOpts = revertBasicOpts `withStdOpts` revertAdvancedOpts++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = []+ , S.diffAlgorithm = diffAlgorithm flags+ , S.interactive = isInteractive flags+ , S.selectDeps = O.PromptDeps -- option not supported, use default+ , S.summary = O.NoSummary -- option not supported, use default+ , S.withContext = isUnified flags+ }++revert :: DarcsCommand [DarcsFlag]+revert = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "revert"+ , commandHelp = revertHelp+ , commandDescription = revertDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+ , commandCommand = revertCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = listRegisteredFiles+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc revertAdvancedOpts+ , commandBasicOptions = odesc revertBasicOpts+ , commandDefaults = defaultFlags revertOpts+ , commandCheckOptions = ocheck revertOpts+ , commandParseOptions = onormalise revertOpts+ }++revertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+revertCmd fps opts args =+ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ files <- if null args then return Nothing+ else Just . sort <$> fixSubPaths fps args+ announceFiles files "Reverting changes in"+ changes <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository files+ let pre_changed_files = effectOnFilePaths (invert changes) . map toFilePath <$> files+ recorded <- readRecorded repository+ Sealed touching_changes <- return (chooseTouching pre_changed_files changes)+ (case touching_changes of+ NilFL -> putStrLn "There are no changes to revert!"+ _ -> do+ let context = selectionContextPrim+ Last "revert" (patchSelOpts opts)+ (Just reversePrimSplitter) pre_changed_files (Just recorded)+ (norevert:>p) <- runSelection (selectChanges changes) context+ if nullFL p+ then putStrLn $ "If you don't want to revert after all," +++ " that's fine with me!"+ else do+ addToPending repository YesUpdateWorking $ invert p+ when (Debug `elem` opts) $ putStrLn "About to write the unrevert file."+ case commute (norevert:>p) of+ Just (p':>_) -> writeUnrevert repository p' recorded NilFL+ Nothing -> writeUnrevert repository (norevert+>+p) recorded NilFL+ when (Debug `elem` opts) $ putStrLn "About to apply to the working directory."+ _ <- applyToWorking repository (verbosity opts) (invert p) `catch` \(e :: IOException) ->+ fail ("Unable to apply inverse patch!" ++ show e)+ return ()) :: IO ()+ putStrLn "Finished reverting."+
+ src/Darcs/UI/Commands/Rollback.hs view
@@ -0,0 +1,199 @@+-- Copyright (C) 2002-2004,2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.UI.Commands.Rollback ( rollback ) where++import Prelude hiding ( (^), catch )++import Control.Applicative ( (<$>) )+import Control.Exception ( catch, IOException )+import Control.Monad ( when )+import Data.List ( sort )+import Storage.Hashed.Tree( Tree )+import System.Exit ( exitSuccess )++import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Match ( firstMatch )+import Darcs.Patch.PatchInfoAnd ( n2pia )+import Darcs.Patch ( RepoPatch, invert, effect, fromPrims, sortCoalesceFL,+ canonize, anonymous, PrimOf )+import Darcs.Patch.Set ( PatchSet(..), newset2FL )+import Darcs.Patch.Split ( reversePrimSplitter )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), RL(..), concatFL,+ nullFL, mapFL_FL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Repository.Flags ( AllowConflicts (..), UseIndex(..), Reorder(..),+ ScanKnown(..), UpdateWorking(..), DryRun(NoDryRun))+import Darcs.Repository ( Repository, withRepoLock, RepoJob(..),+ applyToWorking, readRepo,+ finalizeRepositoryChanges, tentativelyAddToPending,+ considerMergeToWorking, listRegisteredFiles )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, setEnvDarcsPatches,+ amInHashedRepository )+import Darcs.UI.Commands.Unrecord ( getLastPatches )+import Darcs.UI.Commands.Util ( announceFiles )+import Darcs.UI.Flags as F ( DarcsFlag(Quiet), verbosity, umask, useCache,+ compression, externalMerge, wantGuiPause,+ diffAlgorithm, fixSubPaths, isInteractive )+import Darcs.UI.Options+ ( DarcsOption, (^), odesc, ocheck, onormalise+ , defaultFlags, parseFlags+ )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.SelectChanges ( selectChanges, WhichChanges(..),+ selectionContext, selectionContextPrim,+ runSelection )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+import Darcs.Util.Path ( toFilePath, AbsolutePath )+import Darcs.Util.Progress ( debugMessage )++rollbackDescription :: String+rollbackDescription =+ "Apply the inverse of recorded changes to the working copy."++rollbackHelp :: String+rollbackHelp = unlines+ [ "Rollback is used to undo the effects of some changes from patches"+ , "in the repository. The selected changes are undone in your working"+ , "copy, but the repository is left unchanged. First you are offered a"+ , "choice of which patches to undo, then which changes within the"+ , "patches to undo."+ , ""+ , "Before doing `rollback`, you may want to temporarily undo the changes"+ , "of your working copy (if there are) and save them for later use."+ , "To do so, you can run `revert`, then run `rollback`, record a patch,"+ , "and run `unrevert` to restore the saved changes into your working copy."+ ]++rollbackBasicOpts :: DarcsOption a+ ([O.MatchFlag]+ -> Maybe Bool -> Maybe String -> O.DiffAlgorithm -> a)+rollbackBasicOpts+ = O.matchSeveralOrLast+ ^ O.interactive -- True+ ^ O.workingRepoDir+ ^ O.diffAlgorithm++rollbackAdvancedOpts :: DarcsOption a (O.UMask -> a)+rollbackAdvancedOpts = O.umask++rollbackOpts :: DarcsOption a+ ([O.MatchFlag]+ -> Maybe Bool+ -> Maybe String+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UMask+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+rollbackOpts = rollbackBasicOpts `withStdOpts` rollbackAdvancedOpts++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = parseFlags O.matchSeveralOrLast flags+ , S.diffAlgorithm = diffAlgorithm flags+ , S.interactive = isInteractive flags+ , S.selectDeps = O.PromptDeps+ , S.summary = O.NoSummary+ , S.withContext = O.NoContext+ }++rollback :: DarcsCommand [DarcsFlag]+rollback = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "rollback"+ , commandHelp = rollbackHelp+ , commandDescription = rollbackDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+ , commandCommand = rollbackCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = listRegisteredFiles+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc rollbackAdvancedOpts+ , commandBasicOptions = odesc rollbackBasicOpts+ , commandDefaults = defaultFlags rollbackOpts+ , commandCheckOptions = ocheck rollbackOpts+ , commandParseOptions = onormalise rollbackOpts+ }++exitIfNothingSelected :: FL p wX wY -> String -> IO ()+exitIfNothingSelected ps what =+ when (nullFL ps) $ putStrLn ("No " ++ what ++ " selected!") >> exitSuccess++rollbackCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+rollbackCmd fps opts args = withRepoLock NoDryRun (useCache opts)+ YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ files <- if null args+ then return Nothing+ else Just . sort <$> fixSubPaths fps args+ when (files == Just []) $+ fail "No valid arguments were given."+ announceFiles files "Rolling back changes in"+ allpatches <- readRepo repository+ let matchFlags = parseFlags O.matchSeveralOrLast opts+ (_ :> patches) <- return $+ if firstMatch matchFlags+ then getLastPatches matchFlags allpatches+ else PatchSet NilRL NilRL :> newset2FL allpatches+ let filesFps = map toFilePath <$> files+ patchCtx = selectionContext LastReversed "rollback" (patchSelOpts opts) Nothing filesFps+ (_ :> ps) <-+ runSelection (selectChanges patches) patchCtx+ exitIfNothingSelected ps "patches"+ setEnvDarcsPatches ps+ let hunkContext = selectionContextPrim Last "rollback" (patchSelOpts opts)+ (Just reversePrimSplitter) filesFps Nothing+ hunks = concatFL . mapFL_FL (canonize $ F.diffAlgorithm opts) . sortCoalesceFL . effect $ ps+ whatToUndo <- runSelection (selectChanges hunks) hunkContext+ undoItNow opts repository whatToUndo++undoItNow :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)+ => [DarcsFlag] -> Repository p wR wU wT+ -> (q :> FL (PrimOf p)) wA wT -> IO ()+undoItNow opts repo (_ :> prims) = do+ exitIfNothingSelected prims "changes"+ rbp <- n2pia `fmap` anonymous (fromPrims $ invert prims)+ Sealed pw <- considerMergeToWorking repo "rollback"+ YesAllowConflictsAndMark YesUpdateWorking+ (externalMerge opts) (wantGuiPause opts)+ (compression opts) (verbosity opts) NoReorder+ (UseIndex, ScanKnown, F.diffAlgorithm opts)+ NilFL (rbp :>: NilFL)+ tentativelyAddToPending repo YesUpdateWorking pw+ finalizeRepositoryChanges repo YesUpdateWorking+ (compression opts)+ _ <- applyToWorking repo (verbosity opts) pw+ `catch`+ \(e :: IOException) -> fail $+ "error applying rolled back patch to working directory\n"+ ++ show e+ debugMessage "Finished applying unrecorded rollback patch"+ when (F.Quiet `notElem` opts) $+ putStrLn "Changes rolled back in working directory"+
+ src/Darcs/UI/Commands/Send.hs view
@@ -0,0 +1,563 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, TypeOperators, OverloadedStrings #-}++module Darcs.UI.Commands.Send ( send ) where++import Prelude hiding ( (^), catch )++import System.Exit+ ( exitSuccess+#ifndef HAVE_MAPI+ , ExitCode ( ExitFailure )+ , exitWith+#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 )+#ifdef HAVE_HTTP+import Data.List ( stripPrefix )+#endif+import Data.Maybe ( isNothing, fromMaybe )++import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts+ , putInfo+ , putVerbose+ , printDryRunMessageAndExit+ , setEnvDarcsPatches+ , defaultRepo+ , amInHashedRepository+ )+import Darcs.UI.Flags+ ( DarcsFlag( Target+ , Context+ , Mail+ , DryRun+ , Quiet+ , AllowUnrelatedRepos+ )+ , willRemoveLogFile, doReverse, dryRun, useCache, remoteRepos, setDefault+ , fixUrl+ , getCc+ , getAuthor+ , getSubject+ , getInReplyTo+ , getSendmailCmd+ , getOutput+ , getCharset+ , verbosity+ , hasSummary+ , isInteractive+ , hasAuthor+ , hasLogfile+ , selectDeps+ , minimize+ , editDescription+ )+import Darcs.UI.Options+ ( DarcsOption, (^), odesc, ocheck, onormalise+ , defaultFlags, parseFlags+ )+import qualified Darcs.UI.Options.All as O++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, patchDesc )+import Darcs.Repository ( PatchSet, Repository,+ identifyRepositoryFor, withRepository, RepoJob(..),+ readRepo, readRecorded, prefsUrl, checkUnrelatedRepos )+import Darcs.Patch.Set ( Origin )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch ( RepoPatch, description, applyToTree, invert )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Ordered+ ( FL(..), (:>)(..), (:\/:)(..),+ mapFL, mapFL_FL, lengthFL, nullFL )+import Darcs.Patch.Bundle ( minContext, makeBundleN, scanContextFile, patchFilename )+import Darcs.Repository.Prefs ( addRepoSource, getPreflist )+import Darcs.Repository.External ( fetchFilePS, Cachable(..) )+import Darcs.UI.External+ ( signString+ , sendEmailDoc+ , generateEmail+ , editFile+ , catchall+ , getSystemEncoding+ , isUTF8Locale+#ifndef HAVE_MAPI+ , haveSendmail+#endif+ )+import Darcs.Util.ByteString ( mmapFilePS, isAscii )+import qualified Data.ByteString.Char8 as BC (unpack)+import Darcs.Repository.Lock+ ( withOpenTemp+ , writeDocBinFile+ , readDocBinFile+ , removeFileMayNotExist+ )+import Darcs.UI.SelectChanges+ ( selectChanges+ , WhichChanges(..)+ , selectionContext+ , runSelection+ )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+import Darcs.Patch.Depends ( findCommonWithThem )+import Darcs.Util.Prompt ( askUser, promptYorn )+import Data.Text.Encoding ( decodeUtf8' )+import Darcs.Util.Progress ( debugMessage )+import Darcs.UI.Email ( makeEmail )+import Darcs.Util.Printer+ ( Doc, vsep, text, ($$), (<+>), (<>), putDoc, putDocLn+ , renderPS, RenderMode(..)+ )+import Darcs.Util.Path ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd,+ getCurrentDirectory, useAbsoluteOrStd, makeAbsoluteOrStd )+import Darcs.Util.Download.HTTP ( postUrl )+import Darcs.Util.Workaround ( renameFile )+import Darcs.Util.Global ( darcsSendMessage, darcsSendMessageFinal )+import Darcs.Util.SignalHandler ( catchInterrupt )++import qualified Darcs.UI.Message.Send as Msg+#include "impossible.h"++sendBasicOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.SelectDeps+ -> Maybe Bool+ -> O.HeaderFields+ -> Maybe String+ -> Maybe String+ -> (Bool, Maybe String)+ -> Maybe O.Output+ -> O.Sign+ -> O.DryRun+ -> O.XmlOutput+ -> Maybe O.Summary+ -> Bool+ -> Maybe Bool+ -> Maybe String+ -> Bool+ -> Bool+ -> a)+sendBasicOpts+ = O.matchSeveral+ ^ O.selectDeps+ ^ O.interactive -- True+ ^ O.headerFields+ ^ O.author+ ^ O.charset+ ^ O.sendmail+ ^ O.output+ ^ O.sign+ ^ O.dryRunXml+ ^ O.summary+ ^ O.editDescription+ ^ O.setDefault+ ^ O.workingRepoDir+ ^ O.minimize+ ^ O.allowUnrelatedRepos++sendAdvancedOpts :: DarcsOption a+ (O.Logfile+ -> O.RemoteRepos+ -> Maybe AbsolutePath+ -> Bool+ -> O.NetworkOptions+ -> a)+sendAdvancedOpts+ = O.logfile+ ^ O.remoteRepos+ ^ O.sendToContext + ^ O.changesReverse+ ^ O.network++sendOpts :: DarcsOption a+ ([O.MatchFlag]+ -> O.SelectDeps+ -> Maybe Bool+ -> O.HeaderFields+ -> Maybe String+ -> Maybe String+ -> (Bool, Maybe String)+ -> Maybe O.Output+ -> O.Sign+ -> O.DryRun+ -> O.XmlOutput+ -> Maybe O.Summary+ -> Bool+ -> Maybe Bool+ -> Maybe String+ -> Bool+ -> Bool+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.Logfile+ -> O.RemoteRepos+ -> Maybe AbsolutePath+ -> Bool+ -> O.NetworkOptions+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+sendOpts = sendBasicOpts `withStdOpts` sendAdvancedOpts++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = parseFlags O.matchSeveral flags+ , S.diffAlgorithm = O.PatienceDiff+ , S.interactive = isInteractive flags+ , S.selectDeps = selectDeps flags+ , S.summary = hasSummary O.NoSummary flags+ , S.withContext = O.NoContext+ }++send :: DarcsCommand [DarcsFlag]+send = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "send"+ , commandHelp = Msg.cmdHelp+ , commandDescription = Msg.cmdDescription+ , commandExtraArgs = 1+ , commandExtraArgHelp = ["[REPOSITORY]"]+ , commandCommand = sendCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = getPreflist "repos"+ , commandArgdefaults = defaultRepo+ , commandAdvancedOptions = odesc sendAdvancedOpts+ , commandBasicOptions = odesc sendBasicOpts+ , commandDefaults = defaultFlags sendOpts+ , commandCheckOptions = ocheck sendOpts+ , commandParseOptions = onormalise sendOpts+ }++sendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+sendCmd fps input_opts [""] = sendCmd fps input_opts []+sendCmd (_,o) input_opts [unfixedrepodir] =+ withRepository (useCache input_opts) $ RepoJob $+ \(repository :: Repository p wR wU wR) -> do+ context_ps <- the_context input_opts+ case context_ps of+ Just them -> do+ wtds <- decideOnBehavior input_opts (Nothing :: Maybe (Repository p wR wU wR))+ sendToThem repository input_opts wtds "CONTEXT" them+ Nothing -> do+ repodir <- fixUrl o unfixedrepodir+ -- Test to make sure we aren't trying to push to the current repo+ here <- getCurrentDirectory+ when (repodir == toFilePath here) $+ fail Msg.cannotSendToSelf+ old_default <- getPreflist "defaultrepo"+ when (old_default == [repodir] && Quiet `notElem` input_opts) $+ putDocLn (Msg.creatingPatch repodir)+ repo <- identifyRepositoryFor repository (useCache input_opts) repodir+ them <- readRepo repo+ addRepoSource repodir (dryRun input_opts) (remoteRepos input_opts) (setDefault False input_opts)+ wtds <- decideOnBehavior input_opts (Just repo)+ sendToThem repository input_opts wtds repodir them+ where the_context [] = return Nothing+ the_context (Context foo:_)+ = Just `fmap` scanContextFile (toFilePath foo)+ the_context (_:fs) = the_context fs+sendCmd _ _ _ = impossible++sendToThem :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> [DarcsFlag] -> [WhatToDo] -> String+ -> PatchSet p Origin wX -> IO ()+sendToThem repo opts wtds their_name them = do+#ifndef HAVE_MAPI+ -- Check if the user has sendmail or provided a --sendmail-cmd+ -- (unless -o/-O or --dry-run is used)+ sendmail <- haveSendmail+ sm_cmd <- getSendmailCmd opts+ when (isNothing (getOutput opts "") && DryRun `notElem` opts &&+ not sendmail && sm_cmd == "") $ do+ putInfo opts Msg.noWorkingSendmail+ exitWith $ ExitFailure 1+#endif+ us <- readRepo repo+ common :> us' <- return $ findCommonWithThem us them+ checkUnrelatedRepos (AllowUnrelatedRepos `elem` opts) us them+ case us' of+ NilFL -> do putInfo opts Msg.nothingSendable+ exitSuccess+ _ -> putVerbose opts $ Msg.selectionIs (mapFL description us')+ pristine <- readRecorded repo+ let direction = if doReverse opts then FirstReversed else First+ context = selectionContext direction "send" (patchSelOpts opts) Nothing Nothing+ (to_be_sent :> _) <- runSelection (selectChanges us') context+ printDryRunMessageAndExit "send"+ (verbosity opts)+ (hasSummary O.NoSummary opts)+ (dryRun opts)+ O.NoXml+ (isInteractive opts)+ to_be_sent+ when (nullFL to_be_sent) $ do+ putInfo opts Msg.selectionIsNull+ exitSuccess+ setEnvDarcsPatches to_be_sent++ let genFullBundle = prepareBundle opts common (Right (pristine, us':\/:to_be_sent))+ bundle <- if not (minimize opts)+ then genFullBundle+ else do putInfo opts "Minimizing context, to send with full context hit ctrl-C..."+ ( case minContext common to_be_sent of+ Sealed (common' :> to_be_sent') -> prepareBundle opts common' (Left to_be_sent') )+ `catchInterrupt` genFullBundle+ here <- getCurrentDirectory+ let make_fname (tb:>:_) = patchFilename $ patchDesc tb+ make_fname _ = impossible+ fname = make_fname to_be_sent+ outname = case getOutput opts fname of+ Just f -> Just f+ Nothing | Mail `elem` opts -> Nothing+ | not $ null [ p | Post p <- wtds] -> Nothing+ | otherwise -> Just (makeAbsoluteOrStd here fname)+ case outname of+ Just fname' -> writeBundleToFile opts to_be_sent bundle fname' wtds their_name+ Nothing -> sendBundle opts to_be_sent bundle fname wtds their_name+++prepareBundle :: forall p wX wY wZ. (RepoPatch p, ApplyState p ~ Tree)+ => [DarcsFlag] -> PatchSet p Origin wZ+ -> Either (FL (PatchInfoAnd p) wX wY)+ (Tree IO, (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wX wY)+ -> IO Doc+prepareBundle opts common e = do+ unsig_bundle <-+ case e of+ (Right (pristine, us' :\/: to_be_sent)) -> do+ pristine' <- applyToTree (invert $ mapFL_FL hopefully us') pristine+ makeBundleN (Just pristine')+ (unsafeCoerceP common)+ (mapFL_FL hopefully to_be_sent)+ Left to_be_sent -> makeBundleN Nothing+ (unsafeCoerceP common)+ (mapFL_FL hopefully to_be_sent)+ signString (parseFlags O.sign opts) unsig_bundle++sendBundle :: forall p wX wY . (RepoPatch p, ApplyState p ~ Tree)+ => [DarcsFlag] -> FL (PatchInfoAnd p) wX wY+ -> Doc -> String -> [WhatToDo] -> String -> IO ()+sendBundle opts to_be_sent bundle fname wtds their_name=+ let+ auto_subject :: forall pp wA wB . FL (PatchInfoAnd pp) wA wB -> String+ auto_subject (p:>:NilFL) = "darcs patch: " ++ trim (patchDesc p) 57+ auto_subject (p:>:ps) = "darcs patch: " ++ trim (patchDesc p) 43 +++ " (and " ++ show (lengthFL ps) ++ " more)"+ auto_subject _ = error "Tried to get a name from empty patch list."+ trim st n = if length st <= n then st+ else take (n-3) st ++ "..."+ in do+ thetargets <- getTargets wtds+ from <- getAuthor (hasAuthor opts) False+ let thesubject = fromMaybe (auto_subject to_be_sent) $ getSubject opts+ (mailcontents, mailfile, mailcharset) <- getDescription opts their_name to_be_sent++ let warnMailBody = case mailfile of+ Just mf -> putDocLn $ Msg.emailBackedUp mf+ Nothing -> return ()++ warnCharset msg = do+ confirmed <- promptYorn $ Msg.promptCharSetWarning msg+ unless confirmed $ do+ putDocLn Msg.charsetAborted+ warnMailBody+ exitSuccess++ thecharset <- case getCharset opts of+ -- Always trust provided charset+ providedCset@(Just _) -> return providedCset+ Nothing ->+ case mailcharset of+ Nothing -> do+ warnCharset Msg.charsetCouldNotGuess+ return mailcharset+ Just "utf-8" -> do+ -- Check the locale encoding for consistency+ encoding <- getSystemEncoding+ debugMessage $ Msg.currentEncodingIs encoding+ unless (isUTF8Locale encoding) $+ warnCharset Msg.charsetUtf8MailDiffLocale+ return mailcharset+ -- Trust other cases (us-ascii)+ Just _ -> return mailcharset++ let body = makeEmail their_name+ (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . getInReplyTo $ opts)+ (Just mailcontents)+ thecharset+ bundle+ (Just fname)+ contentAndBundle = Just (mailcontents, bundle)++ sendmail = do+ sm_cmd <- getSendmailCmd opts+ let to = generateEmailToString thetargets+ sendEmailDoc from to thesubject (getCc opts)+ sm_cmd contentAndBundle body >>+ putInfo opts (Msg.success to (getCc opts))+ `catch` \e -> do warnMailBody+ fail $ ioeGetErrorString e++ when (null [ p | Post p <- thetargets]) sendmail+ nbody <- withOpenTemp $ \ (fh,fn) -> do+ let to = generateEmailToString thetargets+ generateEmail fh from to thesubject (getCc opts) body+ hClose fh+ mmapFilePS fn+ forM_ [ p | Post p <- thetargets]+ (\url -> do+ putInfo opts $ Msg.postingPatch url+ postUrl url (BC.unpack nbody) "message/rfc822")+ `catch` (\(_ :: IOException) -> sendmail)+ cleanup opts mailfile++generateEmailToString :: [WhatToDo] -> String+generateEmailToString = intercalate " , " . filter (/= "") . map extractEmail+ where+ extractEmail (SendMail t) = t+ extractEmail _ = ""++cleanup :: (FilePathLike t) => [DarcsFlag] -> Maybe t -> IO ()+cleanup opts (Just mailfile) = when (isNothing (hasLogfile opts) || willRemoveLogFile opts) $+ removeFileMayNotExist mailfile+cleanup _ Nothing = return ()++writeBundleToFile :: forall p wX wY . (RepoPatch p, ApplyState p ~ Tree)+ => [DarcsFlag] -> FL (PatchInfoAnd p) wX wY -> Doc ->+ AbsolutePathOrStd -> [WhatToDo] -> String -> IO ()+writeBundleToFile opts to_be_sent bundle fname wtds their_name =+ do (d,f,_) <- getDescription opts their_name to_be_sent+ let putabs a = do writeDocBinFile a (d $$ bundle)+ putDocLn (Msg.wroteBundle a)+ putstd = putDoc (d $$ bundle)+ useAbsoluteOrStd putabs putstd fname+ let to = generateEmailToString wtds+ unless (null to) $ putInfo opts $ Msg.savedButNotSent to+ cleanup opts f++data WhatToDo+ = Post String -- ^ POST the patch via HTTP+ | SendMail String -- ^ send patch via email++decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Maybe (Repository p wR wU wT) -> IO [WhatToDo]+decideOnBehavior opts remote_repo =+ case the_targets of+ [] -> do wtds <- case remote_repo of+ Nothing -> return []+ Just r -> check_post r+ unless (null wtds) $ announce_recipients wtds+ return wtds+ ts -> do announce_recipients ts+ return ts+ where the_targets = collectTargets opts+#ifdef HAVE_HTTP+ -- the ifdef above is to so that darcs only checks the remote+ -- _darcs/post if we have an implementation of postUrl. See+ -- our HTTP module for more details+ check_post the_remote_repo =+ do p <- ((readPost . BC.unpack) `fmap`+ fetchFilePS (prefsUrl the_remote_repo++"/post")+ (MaxAge 600)) `catchall` return []+ emails <- who_to_email the_remote_repo+ return (p++emails)+ readPost = map parseLine . lines where+ parseLine t = maybe (Post t) SendMail $ stripPrefix "mailto:" t+#else+ check_post = who_to_email+#endif+ who_to_email the_remote_repo =+ do email <- (BC.unpack `fmap`+ fetchFilePS (prefsUrl the_remote_repo++"/email")+ (MaxAge 600))+ `catchall` return ""+ if '@' `elem` email then return . map SendMail $ lines email+ else return []+ announce_recipients emails =+ let pn (SendMail s) = s+ pn (Post p) = p+ msg = Msg.willSendTo (dryRun opts) (map pn emails)+ in if DryRun `elem` opts+ then putInfo opts msg+ else when (null the_targets && isNothing (getOutput opts "")) $+ putInfo opts msg++getTargets :: [WhatToDo] -> IO [WhatToDo]+getTargets [] = fmap ((:[]) . SendMail) $ askUser Msg.promptTarget+getTargets wtds = return wtds++collectTargets :: [DarcsFlag] -> [WhatToDo]+collectTargets flags = [ f t | Target t <- flags ] where+ f url | "http:" `isPrefixOf` url = Post url+ f em = SendMail em++getDescription :: (RepoPatch p, ApplyState p ~ Tree)+ => [DarcsFlag] -> String -> FL (PatchInfoAnd p) wX wY -> IO (Doc, Maybe String, Maybe String)+getDescription opts their_name patches =+ case get_filename of+ Just file -> do+ when (editDescription opts) $ do+ when (isNothing $ hasLogfile opts) $+ writeDocBinFile file patchdesc+ debugMessage $ Msg.aboutToEdit file+ (_, changed) <- editFile file+ unless changed $ do+ confirmed <- promptYorn Msg.promptNoDescriptionChange+ unless confirmed $ do putDocLn Msg.aborted+ exitSuccess+ return ()+ + updatedFile <- updateFilename file+ doc <- readDocBinFile updatedFile+ + return (doc, Just updatedFile, tryGetCharset doc)+ Nothing -> return (patchdesc, Nothing, tryGetCharset patchdesc)+ where patchdesc = text (if lengthFL patches == 1+ then "1 patch"+ else show (lengthFL patches) ++ " patches")+ <+> text "for repository" <+> text their_name <> text ":"+ $$ text ""+ $$ vsep (mapFL description patches)+ updateFilename file = + maybe (renameFile file darcsSendMessageFinal >>+ return darcsSendMessageFinal) (return . toFilePath) $ hasLogfile opts+ get_filename = case hasLogfile opts of+ Just f -> Just $ toFilePath f+ Nothing -> if editDescription opts+ then Just darcsSendMessage+ else Nothing+ tryGetCharset content = let body = renderPS Standard content in+ if isAscii body+ then Just "us-ascii"+ else either (const Nothing)+ (const $ Just "utf-8")+ (decodeUtf8' body)
+ src/Darcs/UI/Commands/SetPref.hs view
@@ -0,0 +1,138 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.UI.Commands.SetPref ( setpref ) where++import System.Exit ( exitWith, ExitCode(..) )+import Control.Monad (when)+import Data.Maybe (fromMaybe)++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Flags ( DarcsFlag, useCache, dryRun, umask)+import Darcs.UI.Options ( DarcsOption, PrimDarcsOption, odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( UpdateWorking (..) )+import Darcs.Repository ( addToPending, withRepoLock, RepoJob(..) )+import Darcs.Patch ( changepref )+import Darcs.Patch.Witnesses.Ordered ( FL(..) )+import Darcs.Repository.Prefs ( getPrefval, changePrefval, )+import Darcs.Util.English ( orClauses )+import Darcs.Util.Path ( AbsolutePath )+#include "impossible.h"++-- | A list of all valid preferences for @_darcs/prefs/prefs@.+validPrefData :: [(String, String)] -- ^ (name, one line description)+validPrefData =+ [("test", "a shell command that runs regression tests"),+ ("predist", "a shell command to run before `darcs dist'"),+ ("boringfile", "the path to a version-controlled boring file"),+ ("binariesfile", "the path to a version-controlled binaries file")]++validPrefs :: [String]+validPrefs = map fst validPrefData++setprefDescription :: String+setprefDescription =+ "Set a preference (" ++ orClauses validPrefs ++ ")."++setprefHelp :: String+setprefHelp =+ "When working on project with multiple repositories and contributors,\n" +++ "it is sometimes desirable for a preference to be set consistently\n" +++ "project-wide. This is achieved by treating a preference set with\n" +++ "`darcs setpref` as an unrecorded change, which can then be recorded\n" +++ "and then treated like any other patch.\n" +++ "\n" +++ "Valid preferences are:\n" +++ "\n" +++ unlines ["* "++x++" -- "++y | (x,y) <- validPrefData] +++ "\n" +++ "For example, a project using GNU autotools, with a `make test` target\n" +++ "to perform regression tests, might enable Darcs' integrated regression\n" +++ "testing with the following command:\n" +++ "\n" +++ " darcs setpref test 'autoconf && ./configure && make && make test'\n" +++ "\n" +++ "Note that merging is not currently implemented for preferences: if two\n" +++ "patches attempt to set the same preference, the last patch applied to\n" +++ "the repository will always take precedence. This is considered a\n" +++ "low-priority bug, because preferences are seldom set.\n"++setprefBasicOpts :: PrimDarcsOption (Maybe String)+setprefBasicOpts = O.workingRepoDir++setprefAdvancedOpts :: PrimDarcsOption O.UMask+setprefAdvancedOpts = O.umask++setprefOpts :: DarcsOption a+ (Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UMask+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+setprefOpts = setprefBasicOpts `withStdOpts` setprefAdvancedOpts++setpref :: DarcsCommand [DarcsFlag]+setpref = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "setpref"+ , commandHelp = setprefHelp+ , commandDescription = setprefDescription+ , commandExtraArgs = 2+ , commandExtraArgHelp = ["<PREF>", "<VALUE>"]+ , commandCommand = setprefCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = return validPrefs+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc setprefAdvancedOpts+ , commandBasicOptions = odesc setprefBasicOpts+ , commandDefaults = defaultFlags setprefOpts+ , commandCheckOptions = ocheck setprefOpts+ , commandParseOptions = onormalise setprefOpts+ }++setprefCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+setprefCmd _ opts [pref,val] =+ withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ when (' ' `elem` pref) $ do+ putStrLn $ "'"++pref+++ "' is not a valid preference name: no spaces allowed!"+ exitWith $ ExitFailure 1+ when (pref `notElem` validPrefs) $ do+ putStrLn $ "'"++pref++"' is not a valid preference name!"+ putStrLn $ "Try one of: " ++ unwords validPrefs+ exitWith $ ExitFailure 1+ oval <- getPrefval pref+ let old = fromMaybe "" oval+ when ('\n' `elem` val) $ do+ putStrLn $ val ++ "is not a valid preference value: newlines forbidden!"+ exitWith $ ExitFailure 1+ changePrefval pref old val+ putStrLn $ "Changing value of "++pref++" from '"++old++"' to '"++val++"'"+ addToPending repository YesUpdateWorking (changepref pref old val :>: NilFL)+setprefCmd _ _ _ = impossible+
+ src/Darcs/UI/Commands/Show.hs view
@@ -0,0 +1,89 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Show ( showCommand, list, query ) where++import Darcs.UI.Commands ( DarcsCommand(..)+ , normalCommand, hiddenCommand+ , commandAlias, amInRepository+ )+import Darcs.UI.Commands.ShowAuthors ( showAuthors )+import Darcs.UI.Commands.ShowBug ( showBug )+import Darcs.UI.Commands.ShowContents ( showContents )+import Darcs.UI.Commands.ShowFiles ( showFiles, manifestCmd, toListManifest )+import Darcs.UI.Commands.ShowTags ( showTags )+import Darcs.UI.Commands.ShowRepo ( showRepo )+import Darcs.UI.Commands.ShowIndex ( showIndex, showPristineCmd )+import Darcs.UI.Commands.ShowPatchIndex ( showPatchIndexAll, showPatchIndexFiles, showPatchIndexStatus, patchIndexTest )+import Darcs.UI.Flags ( DarcsFlag )++showDescription :: String+showDescription = "Show information which is stored by darcs."++showHelp :: String+showHelp =+ "Use the `--help` option with the subcommands to obtain help for\n"+++ "subcommands (for example, `darcs show files --help`).\n" +++ "\n" +++ "In previous releases, this command was called `darcs query`.\n" +++ "Currently this is a deprecated alias.\n"++showCommand :: DarcsCommand [DarcsFlag]+showCommand = SuperCommand+ { commandProgramName = "darcs"+ , commandName = "show"+ , commandHelp = showHelp+ , commandDescription = showDescription+ , commandPrereq = amInRepository+ , commandSubCommands =+ [ hiddenCommand showBug+ , normalCommand showContents+ , normalCommand showFiles, hiddenCommand showManifest+ , normalCommand showIndex+ , normalCommand showPristine+ , normalCommand showRepo+ , normalCommand showAuthors+ , normalCommand showTags+ , normalCommand showPatchIndexAll+ , normalCommand showPatchIndexFiles+ , normalCommand showPatchIndexStatus+ , normalCommand patchIndexTest ]+ }++query :: DarcsCommand [DarcsFlag]+query = commandAlias "query" Nothing showCommand++list :: DarcsCommand [DarcsFlag]+list = commandAlias "list" Nothing showCommand++-- unfortunately, aliases for sub-commands have to live in their parent command+-- to avoid an import cycle+showPristine :: DarcsCommand [DarcsFlag]+showPristine = (commandAlias "pristine" (Just showCommand) showIndex) {+ commandCommand = showPristineCmd,+ commandDescription = "Dump contents of pristine cache.",+ commandHelp =+ "The `darcs show pristine` command lists all version-controlled files " +++ "and directories along with the hashes of their pristine copies. " +++ "For files, the fields correspond to file size, sha256 of the pristine " +++ "file content and the filename." }++showManifest :: DarcsCommand [DarcsFlag]+showManifest = (commandAlias "manifest" (Just showCommand) showFiles) {+ commandCommand = manifestCmd toListManifest+}+
+ src/Darcs/UI/Commands/ShowAuthors.hs view
@@ -0,0 +1,228 @@+-- Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael, Tomas Caithaml+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.ShowAuthors+ ( showAuthors, Spelling, compiledAuthorSpellings, canonizeAuthor, rankAuthors+ ) where++import Prelude hiding ( (^), catch )++import Control.Arrow ( (&&&), (***) )+import Control.Exception ( catch, IOException )+import Data.Char ( toLower, isSpace )+import Data.Function ( on )+import Data.List ( isInfixOf, sortBy, groupBy, group, sort )+import Data.Maybe( isJust )+import Data.Ord ( comparing )+import Text.ParserCombinators.Parsec hiding ( lower, count, Line )+import Text.ParserCombinators.Parsec.Error+import Text.Regex ( Regex, mkRegexWithOpts, matchRegex )++import Darcs.UI.Flags ( DarcsFlag(Verbose), useCache )+import Darcs.UI.Options ( DarcsOption, oid, odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O ( workingRepoDir, StdCmdAction, Verbosity, UseCache )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, putWarning, amInRepository )+import Darcs.UI.External ( viewDoc )+import Darcs.Patch.PatchInfoAnd ( info )+import Darcs.Patch.Info ( piAuthor )+import Darcs.Patch.Set ( newset2RL )+import Darcs.Repository ( readRepo, withRepository, RepoJob(..) )+import Darcs.Patch.Witnesses.Ordered ( mapRL )+import Darcs.Util.Printer ( text )+import Darcs.Util.Path ( AbsolutePath )+import qualified Darcs.Util.Ratified as Ratified ( readFile )++data Spelling = Spelling String String [Regex] -- name, email, regexps+type ParsedLine = Maybe Spelling -- Nothing for blank lines++showAuthorsDescription :: String+showAuthorsDescription = "List authors by patch count."++showAuthorsHelp :: String+showAuthorsHelp =+ "The `darcs show authors` command lists the authors of the current\n" +++ "repository, sorted by the number of patches contributed. With the\n" +++ "`--verbose` option, this command simply lists the author of each patch\n" +++ "(without aggregation or sorting).\n" +++ "\n" +++ "An author's name or email address may change over time. To tell Darcs\n" +++ "when multiple author strings refer to the same individual, create an\n" +++ "`.authorspellings` file in the root of the working tree. Each line in\n" +++ "this file begins with an author's canonical name and address, and may\n" +++ "be followed by a comma separated list of extended regular expressions.\n" +++ "Blank lines and lines beginning with two hyphens are ignored.\n" +++ "The format of `.authorspelling` can be described by this pattern:\n" +++ "\n" +++ " name <address> [, regexp ]*\n" +++ "\n" +++ "There are some pitfalls concerning special characters:\n" +++ "Whitespaces are stripped, if you need space in regexp use [ ]. \n" +++ "Because comma serves as a separator you have to escape it if you want\n" +++ "it in regexp. Note that `.authorspelling` use extended regular\n" +++ "expressions so +, ? and so on are metacharacters and you need to \n" +++ "escape them to be interpreted literally.\n" +++ "\n" +++ "Any patch with an author string that matches the canonical address or\n" +++ "any of the associated regexps is considered to be the work of that\n" +++ "author. All matching is case-insensitive and partial (it can match a\n" +++ "substring). Use ^,$ to match the whole string in regexps\n" +++ "\n" +++ "Currently this canonicalization step is done only in `darcs show\n" +++ "authors`. Other commands, such as `darcs changes` use author strings\n" +++ "verbatim.\n" +++ "\n" +++ "An example `.authorspelling` file is:\n" +++ "\n" +++ " -- This is a comment.\n" +++ " Fred Nurk <fred@example.com>\n" +++ " John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n" +++ " Chuck Jones\\, Jr. <chuck@pobox.com>, cj\\+user@example.com\n"++showAuthorsBasicOpts :: DarcsOption a (Maybe String -> a)+showAuthorsBasicOpts = O.workingRepoDir++showAuthorsOpts :: DarcsOption a+ (Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+showAuthorsOpts = showAuthorsBasicOpts `withStdOpts` oid++showAuthors :: DarcsCommand [DarcsFlag]+showAuthors = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "authors"+ , commandHelp = showAuthorsHelp+ , commandDescription = showAuthorsDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = authorsCmd+ , commandPrereq = amInRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = odesc showAuthorsBasicOpts+ , commandDefaults = defaultFlags showAuthorsOpts+ , commandCheckOptions = ocheck showAuthorsOpts+ , commandParseOptions = onormalise showAuthorsOpts+ }++authorsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+authorsCmd _ flags _ = withRepository (useCache flags) $ RepoJob $ \repository -> do+ patches <- readRepo repository+ spellings <- compiledAuthorSpellings flags+ let authors = mapRL (piAuthor . info) $ newset2RL patches+ viewDoc $ text $ unlines $+ if Verbose `elem` flags+ then authors+ else rankAuthors spellings authors++rankAuthors :: [Spelling] -> [String] -> [String]+rankAuthors spellings authors =+ -- A list of the form ["#<rank> <count> <canonical name>"].+ -- Turn the final result into a list of strings.+ map (\ (rank, (count, name)) -> "#" ++ show rank ++ "\t"+ ++ show count ++ "\t" ++ name) .+ zip ([1..] :: [Int]) .+ -- Sort by descending patch count.+ reverse $ sortBy (comparing fst) .+ -- Combine duplicates from a list [(count, canonized name)]+ -- with duplicates canonized names (see next comment).+ map ((sum *** head) . unzip) .+ groupBy ((==) `on` snd) .+ sortBy (comparing snd) .+ -- Because it would take a long time to canonize "foo" into+ -- "foo <foo@bar.baz>" once per patch, the code below+ -- generates a list [(count, canonized name)].+ map (length &&& (canonizeAuthor spellings . head)) .+ group $ sort authors++canonizeAuthor :: [Spelling] -> String -> String+canonizeAuthor spells author = getName canonicals+ where+ getName [] = author+ getName (Spelling name email _ : _) = name ++ " <" ++ email ++ ">"+ canonicals = filter (ismatch author) spells+ ismatch s (Spelling _ mail regexps) =+ s `correspondsTo` mail || any (s `contains_regex`) regexps+ contains_regex a r = isJust $ matchRegex r a+ correspondsTo a b = lower b `isInfixOf` lower a+ lower = map toLower++compiledAuthorSpellings :: [DarcsFlag] -> IO [Spelling]+compiledAuthorSpellings flags = do+ let as_file = ".authorspellings"+ contents <- Ratified.readFile -- never unlinked from within darcs+ as_file `catch` (\(_ :: IOException) -> return "")+ let parse_results = map (parse sentence as_file) $ lines contents+ clean 1 parse_results+ where+ clean :: Int -> [Either ParseError ParsedLine] -> IO [Spelling]+ clean _ [] = return []+ -- print parse error+ clean n (Left err : xs) = do+ let npos = setSourceLine (errorPos err) n+ putWarning flags . text . show $ setErrorPos npos err+ clean (n + 1) xs+ -- skip blank line+ clean n (Right Nothing : xs) = clean (n + 1) xs+ -- unwrap Spelling+ clean n (Right (Just a) : xs) = do+ as <- clean (n + 1) xs+ return (a : as)++----------+-- PARSERS++sentence :: Parser ParsedLine+sentence = spaces >> (comment <|> blank <|> addressline)+ where+ comment = string "--" >> return Nothing+ blank = eof >> return Nothing++addressline :: Parser ParsedLine+addressline = do+ name <- canonicalName <?> "Canonical name"+ addr <- between (char '<') (char '>') (many1 (noneOf ">")) <?> "Address"+ spaces+ rest <- option [] (char ',' >> regexp `sepBy` char ',')+ <?> "List of regexps"+ return $ Just $ Spelling (strip name) addr (compile rest)+ where+ strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse+ makeRegex s = mkRegexWithOpts s True False+ compile = map makeRegex . filter (not . null) . map strip++ parseComma = string "\\," >> return ','++ regexp :: Parser String+ regexp = many1 p <?> "Regular expression"+ where+ p = try parseComma <|> noneOf ","++ canonicalName :: Parser String+ canonicalName = many1 p+ where+ p = try parseComma <|> noneOf ",<"
+ src/Darcs/UI/Commands/ShowBug.hs view
@@ -0,0 +1,77 @@+-- Copyright (C) 2007 Eric Kow+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.UI.Commands.ShowBug ( showBug ) where++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository )+import Darcs.UI.Flags ( DarcsFlag )+import Darcs.UI.Options ( DarcsOption, oid, odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O ( workingRepoDir, StdCmdAction, Verbosity, UseCache )+import Darcs.Util.Path ( AbsolutePath )+#include "impossible.h"++showBugDescription :: String+showBugDescription = "Simulate a run-time failure."++showBugHelp :: String+showBugHelp =+ "Show bug can be used to see what darcs would show you if you encountered.\n"+ ++"a bug in darcs.\n"++showBugBasicOpts :: DarcsOption a (Maybe String -> a)+showBugBasicOpts = O.workingRepoDir++showBugOpts :: DarcsOption a+ (Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)++showBugOpts = showBugBasicOpts `withStdOpts` oid++showBug :: DarcsCommand [DarcsFlag]+showBug = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "bug"+ , commandHelp = showBugHelp+ , commandDescription = showBugDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = showBugCmd+ , commandPrereq = findRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = odesc showBugBasicOpts+ , commandDefaults = defaultFlags showBugOpts+ , commandCheckOptions = ocheck showBugOpts+ , commandParseOptions = onormalise showBugOpts+ }++showBugCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+showBugCmd _ _ _ = bug "This is actually a fake bug in darcs."+
+ src/Darcs/UI/Commands/ShowContents.hs view
@@ -0,0 +1,122 @@+-- Copyright (C) 2007 Eric Kow+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.ShowContents ( showContents ) where++import Prelude hiding ( (^) )++import Control.Monad ( filterM, forM_, forM, unless )+import System.IO ( stdout )++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository )+import Darcs.UI.Flags ( DarcsFlag, useCache, fixSubPaths )+import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O ( MatchFlag, matchOne, workingRepoDir, StdCmdAction, Verbosity, UseCache )+import Darcs.Patch.ApplyMonad ( withFiles )+import Darcs.Patch.Match+ ( haveNonrangeMatch+ , applyInvToMatcher+ , nonrangeMatcher+ , InclusiveOrExclusive(..)+ , matchExists+ , applyNInv+ , hasIndexRange )+import Darcs.Repository ( withRepository, RepoJob(..), readRepo, readRecorded, repoPatchType )+import qualified Storage.Hashed.Monad as HSM+import Darcs.Util.Path( floatPath, anchorPath, FileName, fp2fn,+ sp2fn, toFilePath, AbsolutePath )++showContentsDescription :: String+showContentsDescription = "Outputs a specific version of a file."++showContentsHelp :: String+showContentsHelp =+ "Show contents can be used to display an earlier version of some file(s).\n"+++ "If you give show contents no version arguments, it displays the recorded\n"+++ "version of the file(s).\n"++showContentsBasicOpts :: DarcsOption a ([O.MatchFlag] -> Maybe String -> a)+showContentsBasicOpts = O.matchOne ^ O.workingRepoDir++showContentsOpts :: DarcsOption a+ ([O.MatchFlag]+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+showContentsOpts = O.matchOne ^ O.workingRepoDir `withStdOpts` oid++showContents :: DarcsCommand [DarcsFlag]+showContents = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "contents"+ , commandHelp = showContentsHelp+ , commandDescription = showContentsDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[FILE]..."]+ , commandCommand = showContentsCmd+ , commandPrereq = findRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = odesc showContentsBasicOpts+ , commandDefaults = defaultFlags showContentsOpts+ , commandCheckOptions = ocheck showContentsOpts+ , commandParseOptions = onormalise showContentsOpts+ }++showContentsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+showContentsCmd _ _ [] = fail "show contents needs at least one argument."+showContentsCmd fps opts args = withRepository (useCache opts) $ RepoJob $ \repository -> do+ path_list <- map sp2fn `fmap` fixSubPaths fps args+ pristine <- readRecorded repository+ unapply <- let matchFlags = parseFlags O.matchOne opts+ in+ if haveNonrangeMatch (repoPatchType repository) matchFlags+ then do+ patchset <- readRepo repository+ case nonrangeMatcher matchFlags of+ -- Index cannot be a Matcher, so handle it manually.+ Nothing -> case hasIndexRange matchFlags of+ Just (n, m) | n == m -> return $ applyNInv (n-1) patchset+ _ -> fail "Couldn't obtain a valid matcher."+ Just m -> do+ unless (matchExists m patchset) $+ fail $ "Couldn't match pattern " ++ show m+ return $ applyInvToMatcher Exclusive m patchset+ else return (return ())+ let dump :: HSM.TreeIO [(FileName, B.ByteString)]+ dump = do+ let floatedPaths = map (floatPath . toFilePath) path_list+ okpaths <- filterM HSM.fileExists floatedPaths+ forM okpaths $ \f -> do+ content <- (B.concat . BL.toChunks) `fmap` HSM.readFile f+ return (fp2fn $ ("./" ++) $ anchorPath "" f, content)+ files <- flip withFiles unapply `fmap` fst+ `fmap` HSM.virtualTreeIO dump pristine+ forM_ files $ \(_, f) -> B.hPut stdout f
+ src/Darcs/UI/Commands/ShowFiles.hs view
@@ -0,0 +1,169 @@+-- Copyright (C) 2005 Florian Weimer+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+module Darcs.UI.Commands.ShowFiles ( showFiles+ , manifestCmd, toListManifest -- for alias+ , manifest+ ) where++import Prelude hiding ( (^) )+import Darcs.UI.Flags ( DarcsFlag, useCache )+import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise+ , defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )+import Darcs.Repository ( Repository, withRepository,+ RepoJob(..), repoPatchType )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Repository.State ( readRecorded, readRecordedAndPending )+import Storage.Hashed.Tree( Tree, TreeItem(..), list, expand )+import Darcs.Util.Path( anchorPath, AbsolutePath )+import Storage.Hashed.Plain( readPlainTree )+import System.FilePath ( splitDirectories )++import Data.List( isPrefixOf )++import Darcs.Patch.Match ( haveNonrangeMatch )+import Darcs.Repository.Match ( getNonrangeMatch )+import Darcs.Repository.Lock ( withDelayedDir )++showFilesDescription :: String+showFilesDescription = "Show version-controlled files in the working copy."++showFilesHelp :: String+showFilesHelp =+ "The `darcs show files` command lists those files and directories in\n" +++ "the working tree that are under version control. This command is\n" +++ "primarily for scripting purposes; end users will probably want `darcs\n" +++ "whatsnew --summary`.\n" +++ "\n" +++ "A file is \"pending\" if it has been added but not recorded. By\n" +++ "default, pending files (and directories) are listed; the `--no-pending`\n" +++ "option prevents this.\n" +++ "\n" +++ "By default `darcs show files` lists both files and directories, but\n" +++ "the alias `darcs show manifest` only lists files. The `--files`,\n" +++ "`--directories`, `--no-files` and `--no-directories` modify this behaviour.\n" +++ "\n" +++ "By default entries are one-per-line (i.e. newline separated). This\n" +++ "can cause problems if the files themselves contain newlines or other\n" +++ "control characters. To get around this, the `--null` option uses the\n" +++ "null character instead. The script interpreting output from this\n" +++ "command needs to understand this idiom; `xargs -0` is such a command.\n" +++ "\n" +++ "For example, to list version-controlled files by size:\n" +++ "\n" +++ " darcs show files -0 | xargs -0 ls -ldS\n"++showFilesBasicOpts :: DarcsOption a+ (Bool -> Bool -> Bool -> Bool -> [O.MatchFlag] -> Maybe String -> a)+showFilesBasicOpts+ = O.files+ ^ O.directories+ ^ O.pending+ ^ O.nullFlag+ ^ O.matchOne+ ^ O.workingRepoDir++showFilesOpts :: DarcsOption a+ (Bool+ -> Bool+ -> Bool+ -> Bool+ -> [O.MatchFlag]+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+showFilesOpts = showFilesBasicOpts `withStdOpts` oid++showFiles :: DarcsCommand [DarcsFlag]+showFiles = DarcsCommand {+ commandProgramName = "darcs",+ commandName = "files",+ commandHelp = showFilesHelp,+ commandDescription = showFilesDescription,+ commandExtraArgs = -1,+ commandExtraArgHelp = ["[FILE or DIRECTORY]..."],+ commandCommand = manifestCmd toListFiles,+ commandPrereq = amInRepository,+ commandGetArgPossibilities = return [],+ commandArgdefaults = nodefaults,+ commandAdvancedOptions = [],+ commandBasicOptions = odesc showFilesBasicOpts,+ commandDefaults = defaultFlags showFilesOpts,+ commandCheckOptions = ocheck showFilesOpts,+ commandParseOptions = onormalise showFilesOpts }++toListFiles, toListManifest :: [DarcsFlag] -> Tree m -> [FilePath]+toListFiles opts = filesDirs (parseFlags O.files opts) (parseFlags O.directories opts)+toListManifest opts = filesDirs (parseFlags O.files opts) (parseFlags O.directories opts)++filesDirs :: Bool -> Bool -> Tree m -> [FilePath]+filesDirs False False _ = []+filesDirs False True t = "." : [ anchorPath "." p | (p, SubTree _) <- list t ]+filesDirs True False t = [ anchorPath "." p | (p, File _) <- list t ]+filesDirs True True t = "." : map (anchorPath "." . fst) (list t)++manifest :: [DarcsFlag] -> [String] -> IO [FilePath]+manifest = manifestHelper toListFiles++manifestCmd :: ([DarcsFlag] -> Tree IO -> [FilePath])+ -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+manifestCmd to_list _ opts argList =+ mapM_ output =<< manifestHelper to_list opts argList+ where+ output_null name = do { putStr name ; putChar '\0' }+ output = if parseFlags O.nullFlag opts then output_null else putStrLn++manifestHelper :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> [DarcsFlag] -> [String] -> IO [FilePath]+manifestHelper to_list opts argList = do+ list' <- to_list opts `fmap` withRepository (useCache opts) (RepoJob myslurp)+ case argList of+ [] -> return list'+ prefixes -> return (onlysubdirs prefixes list')+ where myslurp :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wR -> IO (Tree IO)+ myslurp r = do let fRevisioned = haveNonrangeMatch (repoPatchType r) (parseFlags O.matchOne opts)+ fPending = parseFlags O.pending opts+ -- this covers all 4 possibilities+ expand =<< case (fRevisioned,fPending) of+ (True,False) -> slurpRevision opts r+ (True,True) -> error "can't mix revisioned and pending flags"+ (False,False) -> readRecorded r+ (False,True) -> readRecordedAndPending r -- pending is default+ isParentDir a' b' =+ let a = splitDirectories a'+ b = splitDirectories b'+ in (a `isPrefixOf` b) || (("." : a) `isPrefixOf` b)+ onlysubdirs dirs = filter (\p -> any (`isParentDir` p) dirs)++slurpRevision :: (RepoPatch p, ApplyState p ~ Tree)+ => [DarcsFlag] -> Repository p wR wU wR -> IO (Tree IO)+slurpRevision opts r = withDelayedDir "revisioned.showfiles" $ \_ -> do+ getNonrangeMatch r (parseFlags O.matchOne opts)+ expand =<< readPlainTree "."+
+ src/Darcs/UI/Commands/ShowIndex.hs view
@@ -0,0 +1,124 @@+-- Copyright (C) 2009 Petr Rockai+--+-- 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.++{-# LANGUAGE CPP #-}+module Darcs.UI.Commands.ShowIndex+ ( showIndex+ , showPristineCmd -- for alias+ ) where++import Control.Applicative ( (<$>) )+import Control.Monad ( (>=>) )+import Darcs.UI.Flags ( DarcsFlag(NullFlag), useCache )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )+import Prelude hiding ( (^) )+import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository ( withRepository, RepoJob(..), readIndex )+import Darcs.Repository.State ( readRecorded )++import Storage.Hashed( floatPath )+import Storage.Hashed.Hash( encodeBase16, Hash( NoHash ) )+import Storage.Hashed.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) )+import Storage.Hashed.Index( updateIndex, listFileIDs )+import Darcs.Util.Path( anchorPath, AbsolutePath )++import System.Posix.Types ( FileID )++import qualified Data.ByteString.Char8 as BS+import Data.Maybe ( fromJust )+import qualified Data.Map as M ( Map, lookup, fromList )++showIndexBasicOpts :: DarcsOption a+ (Bool -> Bool -> Bool -> Maybe String -> a)+showIndexBasicOpts = O.files ^ O.directories ^ O.nullFlag ^ O.workingRepoDir++showIndexOpts :: DarcsOption a+ (Bool+ -> Bool+ -> Bool+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+showIndexOpts = showIndexBasicOpts `withStdOpts` oid++showIndex :: DarcsCommand [DarcsFlag]+showIndex = DarcsCommand {+ commandProgramName = "darcs",+ commandName = "index",+ commandDescription = "Dump contents of working tree index.",+ commandHelp =+ "The `darcs show index` command lists all version-controlled files and " +++ "directories along with their hashes as stored in `_darcs/index`. " +++ "For files, the fields correspond to file size, sha256 of the current " +++ "file content and the filename.",+ commandExtraArgs = 0,+ commandExtraArgHelp = [],+ commandCommand = showIndexCmd,+ commandPrereq = amInRepository,+ commandGetArgPossibilities = return [],+ commandArgdefaults = nodefaults,+ commandAdvancedOptions = [],+ commandBasicOptions = odesc showIndexBasicOpts,+ commandDefaults = defaultFlags showIndexOpts,+ commandCheckOptions = ocheck showIndexOpts,+ commandParseOptions = onormalise showIndexOpts }++dump :: [DarcsFlag] -> Maybe (M.Map FilePath FileID) -> Tree IO -> IO ()+dump opts fileids tree = do+ let line | NullFlag `elem` opts = \t -> putStr t >> putChar '\0'+ | otherwise = putStrLn+ output (p, i) = do+ let hash = case itemHash i of+ NoHash -> "(no hash available)"+ h -> BS.unpack $ encodeBase16 h+ path = anchorPath "" p+ isdir = case i of+ SubTree _ -> "/"+ _ -> ""+ fileid = case fileids of+ Nothing -> ""+ Just fileids' -> " " ++ (show $ fromJust $ M.lookup path fileids')+ line $ hash ++ fileid ++ " " ++ path ++ isdir+ x <- expand tree+ mapM_ output $ (floatPath ".", SubTree x) : list x++showIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+showIndexCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ \repo ->+ do index <- readIndex repo+ index_tree <- updateIndex index+ fileids <- (M.fromList . map (\((a,_),b) -> (anchorPath "" a,b))) <$> listFileIDs index+ dump opts (Just fileids) index_tree++showPristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+showPristineCmd _ opts _ = withRepository (useCache opts) $ RepoJob $+ readRecorded >=> dump opts Nothing+
+ src/Darcs/UI/Commands/ShowPatchIndex.hs view
@@ -0,0 +1,132 @@+module Darcs.UI.Commands.ShowPatchIndex ( showPatchIndexFiles, showPatchIndexAll, showPatchIndexStatus, patchIndexTest ) where+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Flags ( DarcsFlag, useCache )+import Prelude hiding ( (^) )+import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Repository.InternalTypes ( Repository(..) )+import Darcs.Repository ( withRepository, RepoJob(..) )+import Darcs.Repository.PatchIndex+import Control.Arrow ()++showPatchIndexBasicOpts :: DarcsOption a+ (Bool -> Bool -> Bool -> Maybe String -> a)+showPatchIndexBasicOpts = O.files ^ O.directories ^ O.nullFlag ^ O.workingRepoDir++showPatchIndexOpts :: DarcsOption a+ (Bool+ -> Bool+ -> Bool+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+showPatchIndexOpts = showPatchIndexBasicOpts `withStdOpts` oid++showPatchIndexAll :: DarcsCommand [DarcsFlag]+showPatchIndexAll = DarcsCommand {+ commandProgramName = "darcs",+ commandName = "patch-index-all",+ commandDescription = "Dump complete content of patch index.",+ commandHelp =+ "The `darcs show patch-index all' command lists all information in the patch index",+ commandExtraArgs = 0,+ commandExtraArgHelp = [],+ commandCommand = showPatchIndexAllCmd,+ commandPrereq = amInHashedRepository,+ commandGetArgPossibilities = return [],+ commandArgdefaults = nodefaults,+ commandAdvancedOptions = [],+ commandBasicOptions = odesc showPatchIndexBasicOpts,+ commandDefaults = defaultFlags showPatchIndexOpts,+ commandCheckOptions = ocheck showPatchIndexOpts,+ commandParseOptions = onormalise showPatchIndexOpts }++showPatchIndexFiles :: DarcsCommand [DarcsFlag]+showPatchIndexFiles = DarcsCommand {+ commandProgramName = "darcs",+ commandName = "patch-index-files",+ commandDescription = "Dump current files registered in patch index.",+ commandHelp =+ "The `darcs show patch-index files' command lists all current files registered in the patch index",+ commandExtraArgs = 0,+ commandExtraArgHelp = [],+ commandCommand = showPatchIndexFilesCmd,+ commandPrereq = amInHashedRepository,+ commandGetArgPossibilities = return [],+ commandArgdefaults = nodefaults,+ commandAdvancedOptions = [],+ commandBasicOptions = odesc showPatchIndexBasicOpts,+ commandDefaults = defaultFlags showPatchIndexOpts,+ commandCheckOptions = ocheck showPatchIndexOpts,+ commandParseOptions = onormalise showPatchIndexOpts }++showPatchIndexStatus :: DarcsCommand [DarcsFlag]+showPatchIndexStatus = DarcsCommand {+ commandProgramName = "darcs",+ commandName = "patch-index-status",+ commandDescription = " Report patch-index status",+ commandHelp =+ "The `darcs show patch-index-status' reports if the patch index is in sync, out of sync, or does not exist",+ commandExtraArgs = 0,+ commandExtraArgHelp = [],+ commandCommand = showPatchIndexStatus',+ commandPrereq = amInHashedRepository,+ commandGetArgPossibilities = return [],+ commandArgdefaults = nodefaults,+ commandAdvancedOptions = [],+ commandBasicOptions = odesc showPatchIndexBasicOpts,+ commandDefaults = defaultFlags showPatchIndexOpts,+ commandCheckOptions = ocheck showPatchIndexOpts,+ commandParseOptions = onormalise showPatchIndexOpts }++patchIndexTest :: DarcsCommand [DarcsFlag]+patchIndexTest = DarcsCommand {+ commandProgramName = "darcs",+ commandName = "patch-index-test",+ commandDescription = "Test patch-index",+ commandHelp =+ "The `darcs show patch-index-test' tests patch index",+ commandExtraArgs = 0,+ commandExtraArgHelp = [],+ commandCommand = piTest',+ commandPrereq = amInHashedRepository,+ commandGetArgPossibilities = return [],+ commandArgdefaults = nodefaults,+ commandAdvancedOptions = [],+ commandBasicOptions = odesc showPatchIndexBasicOpts,+ commandDefaults = defaultFlags showPatchIndexOpts,+ commandCheckOptions = ocheck showPatchIndexOpts,+ commandParseOptions = onormalise showPatchIndexOpts }++showPatchIndexAllCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+showPatchIndexAllCmd _ opts _ =+ withRepository (useCache opts) $ RepoJob $ \(Repo repodir _ _ _) ->+ dumpPatchIndex repodir++showPatchIndexFilesCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+showPatchIndexFilesCmd _ opts _ = withRepository (useCache opts) $ RepoJob $ \(Repo repodir _ _ _) ->+ dumpPatchIndexFiles repodir++showPatchIndexStatus' :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+showPatchIndexStatus' _ opts _ = withRepository (useCache opts) $ RepoJob $ \(repo@(Repo repodir _ _ _)) -> do+ ex <- doesPatchIndexExist repodir+ if ex+ then do+ sy <- isPatchIndexInSync repo+ if sy+ then putStrLn "Patch Index is in sync with repo."+ else putStrLn "Patch Index is outdated. Run darcs optimize enable-patch-index"+ else putStrLn "Patch Index is not yet created. Run darcs optimize enable-patch-index"++piTest' :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+piTest' _ opts _ = withRepository (useCache opts) $ RepoJob piTest
+ src/Darcs/UI/Commands/ShowRepo.hs view
@@ -0,0 +1,174 @@+-- Copyright (C) 2007 Kevin Quick+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+module Darcs.UI.Commands.ShowRepo ( showRepo ) where++import Prelude hiding ( (^) )+import Data.Char ( toLower, isSpace )+import Data.List ( intercalate )+import Control.Monad ( when, unless, liftM )+import Text.Html ( tag, stringToHtml )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.UI.Flags ( DarcsFlag(XMLOutput, Verbose, NoFiles), useCache )+import Darcs.UI.Options ( DarcsOption, (^), oid, odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )+import Darcs.Repository ( withRepository, RepoJob(..), readRepo )+import Darcs.Repository.Internal ( Repository(..) )+import Darcs.Repository.InternalTypes ( Pristine(..) )+import Darcs.Repository.Cache ( Cache(..) )+import Darcs.Repository.Format ( RepoFormat(..) )+import Darcs.Repository.Prefs ( getPreflist )+import Darcs.Repository.Motd ( getMotd )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Set ( newset2RL )+import Darcs.Patch.Witnesses.Ordered ( lengthRL )+import qualified Data.ByteString.Char8 as BC (unpack)+import Darcs.Patch.Apply( ApplyState )+import Storage.Hashed.Tree ( Tree )++showRepoHelp :: String+showRepoHelp =+ "The `darcs show repo` command displays statistics about the current\n" +++ "repository, allowing third-party scripts to access this information\n" +++ "without inspecting `_darcs` directly (and without breaking when the\n" +++ "`_darcs` format changes).\n" +++ "\n" +++ "By default, the number of patches is shown. If this data isn't\n" +++ "needed, use `--no-files` to accelerate this command from O(n) to O(1).\n" +++ "\n" +++ "By default, output is in a human-readable format. The `--xml-output`\n" +++ "option can be used to generate output for machine postprocessing.\n"++showRepoDescription :: String+showRepoDescription = "Show repository summary information"++showRepoBasicOpts :: DarcsOption a (Maybe String -> Bool -> O.XmlOutput -> a)+showRepoBasicOpts = O.workingRepoDir ^ O.files ^ O.xmloutput++showRepoOpts :: DarcsOption a+ (Maybe String+ -> Bool+ -> O.XmlOutput+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+showRepoOpts = showRepoBasicOpts `withStdOpts` oid++showRepo :: DarcsCommand [DarcsFlag]+showRepo = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "repo"+ , commandHelp = showRepoHelp+ , commandDescription = showRepoDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = repoCmd+ , commandPrereq = amInRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = odesc showRepoBasicOpts+ , commandDefaults = defaultFlags showRepoOpts+ , commandCheckOptions = ocheck showRepoOpts+ , commandParseOptions = onormalise showRepoOpts+ }++repoCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+repoCmd _ opts _ = let put_mode = if XMLOutput `elem` opts then showInfoXML else showInfoUsr+ in withRepository (useCache opts) $ RepoJob $ \repository -> actuallyShowRepo (putInfo put_mode) repository opts++-- Some convenience functions to output a labelled text string or an+-- XML tag + value (same API). If no value, output is suppressed+-- entirely. Borrow some help from Text.Html to perform XML output.++type ShowInfo = String -> String -> String++showInfoXML :: ShowInfo+showInfoXML t i = show $ tag (safeTag t) $ stringToHtml i++safeTag :: String -> String+safeTag [] = []+safeTag (' ':cs) = safeTag cs+safeTag ('#':cs) = "num_" ++ safeTag cs+safeTag (c:cs) = toLower c : safeTag cs++-- labelled strings: labels are right-aligned at 14 characters;+-- subsequent lines in multi-line output are indented accordingly.+showInfoUsr :: ShowInfo+showInfoUsr t i = replicate (14 - length t) ' ' ++ t ++ ": " +++ intercalate ('\n' : replicate 16 ' ') (lines i) ++ "\n"++type PutInfo = String -> String -> IO ()+putInfo :: ShowInfo -> PutInfo+putInfo m t i = unless (null i) (putStr $ m t i)++-- Primary show-repo operation. Determines ordering of output for+-- sub-displays. The `out' argument is one of the above operations to+-- output a labelled text string or an XML tag and contained value.++actuallyShowRepo :: (RepoPatch p, ApplyState p ~ Tree)+ => PutInfo -> Repository p wR wU wR -> [DarcsFlag] -> IO ()+actuallyShowRepo out r@(Repo loc rf pris cs) opts = do+ when (XMLOutput `elem` opts) (putStr "<repository>\n")+ when (Verbose `elem` opts) (out "Show" $ show r)+ showRepoFormat out rf+ out "Root" loc+ showRepoAux out pris cs+ showRepoPrefs out+ unless (NoFiles `elem` opts) (numPatches r >>= (out "Num Patches" . show ))+ showRepoMOTD out r+ when (XMLOutput `elem` opts) (putStr "</repository>\n")++-- Most of the actual elements being displayed are part of the Show+-- class; that's fine for a Haskeller, but not for the common user, so+-- the routines below work to provide more human-readable information+-- regarding the repository elements.++showRepoFormat :: PutInfo -> RepoFormat -> IO ()+showRepoFormat out rf = out "Format" . intercalate ", " . lines . show $ rf++showRepoAux :: PutInfo -> Pristine -> Cache -> IO ()+showRepoAux out pris cs =+ do out "Pristine" $ show pris+ out "Cache" $ intercalate ", " $ lines $ show cs+++showRepoPrefs :: PutInfo -> IO ()+showRepoPrefs out = do+ getPreflist "prefs" >>= mapM_ prefOut+ getPreflist "author" >>= out "Author" . unlines+ getPreflist "defaultrepo" >>= out "Default Remote" . unlines+ where prefOut = uncurry out . (\(p,v) -> (p++" Pref", dropWhile isSpace v)) . break isSpace++showRepoMOTD :: RepoPatch p => PutInfo -> Repository p wR wU wR -> IO ()+showRepoMOTD out (Repo loc _ _ _) = getMotd loc >>= out "MOTD" . BC.unpack++-- Support routines to provide information used by the PutInfo operations above.++numPatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p wR wU wR -> IO Int+numPatches r = (lengthRL . newset2RL) `liftM` readRepo r+
+ src/Darcs/UI/Commands/ShowTags.hs view
@@ -0,0 +1,108 @@+-- Copyright (C) 2007 Florian Weimer+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.ShowTags+ ( showTags+ ) where++import Control.Monad ( unless, join )+import Data.Maybe ( fromMaybe )+import System.IO ( stderr, hPutStrLn )++import Darcs.Patch.Set ( PatchSet(..) )+import Darcs.Patch.MaybeInternal ( MaybeInternal )+import Darcs.Repository ( readRepo, withRepositoryDirectory, RepoJob(..) )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository )+import Darcs.UI.Commands.Tag ( getTags )+import Darcs.UI.Flags ( DarcsFlag, useCache, getRepourl )+import Darcs.UI.Options+ ( DarcsOption, PrimDarcsOption+ , oid, odesc, ocheck, onormalise, defaultFlags+ )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Text ( formatText )+import Darcs.Util.Path ( AbsolutePath )++showTagsDescription :: String+showTagsDescription = "Show all tags in the repository."++showTagsHelp :: String+showTagsHelp = formatText 80+ [ "The tags command writes a list of all tags in the repository to "+ ++ "standard output."+ , "Tab characters (ASCII character 9) in tag names are changed to spaces "+ ++ "for better interoperability with shell tools. A warning is printed "+ ++ "if this happens."+ ]++showTagsBasicOpts :: PrimDarcsOption (Maybe String)+showTagsBasicOpts = O.possiblyRemoteRepo++showTagsOpts :: DarcsOption a+ (Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+showTagsOpts = showTagsBasicOpts `withStdOpts` oid++showTags :: DarcsCommand [DarcsFlag]+showTags = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "tags"+ , commandHelp = showTagsHelp+ , commandDescription = showTagsDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = tagsCmd+ , commandPrereq = findRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = odesc showTagsBasicOpts+ , commandDefaults = defaultFlags showTagsOpts+ , commandCheckOptions = ocheck showTagsOpts+ , commandParseOptions = onormalise showTagsOpts+ }++tagsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+tagsCmd _ opts _ = let repodir = fromMaybe "." (getRepourl opts) in+ withRepositoryDirectory (useCache opts) repodir $ RepoJob $ \repo ->+ readRepo repo >>= printTags+ where+ printTags :: MaybeInternal p => PatchSet p wW wZ -> IO ()+ printTags = join . fmap (sequence_ . map process) . getTags+ process :: String -> IO ()+ process t = normalize t t False >>= putStrLn+ normalize :: String -> String -> Bool -> IO String+ normalize _ [] _ = return []+ normalize t (x : xs) flag =+ if x == '\t' then do+ unless flag $+ hPutStrLn stderr $ "warning: tag with TAB character: " ++ t+ rest <- normalize t xs True+ return $ ' ' : rest+ else do+ rest <- normalize t xs flag+ return $ x : rest
+ src/Darcs/UI/Commands/Tag.hs view
@@ -0,0 +1,236 @@+-- Copyright (C) 2003-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Tag ( tag, getTags ) where++import Prelude hiding ( (^) )+import Control.Applicative ( (<$>) )+import Control.Monad ( when )+import Data.Maybe ( catMaybes )++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Commands.Record ( getLog )+import Darcs.UI.Flags+ ( DarcsFlag(AskDeps), getDate, compression, verbosity, useCache, umask, getAuthor+ , hasAuthor, diffAlgorithm )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Patch.PatchInfoAnd ( n2pia, hopefully )+import Darcs.Repository ( withRepoLock, Repository, RepoJob(..), readRepo,+ tentativelyAddPatch, finalizeRepositoryChanges,+ )+import Darcs.Patch+ ( infopatch, adddeps, Patchy, PrimPatch, PrimOf+ , RepoPatch+ )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Info ( patchinfo, piTag )+import Darcs.Patch.Depends ( getUncovered )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )+import Darcs.Patch.MaybeInternal ( MaybeInternal(patchInternalChecker), InternalChecker(..) )+import Darcs.Patch.Named ( patchcontents )+import Darcs.Patch.Set ( PatchSet(..), emptyPatchSet, appendPSFL, newset2FL )+import Darcs.Patch.Witnesses.Ordered ( FL(..), filterOutRLRL, (:>)(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )+import Darcs.UI.SelectChanges+ ( selectChanges+ , WhichChanges(..)+ , selectionContext+ , runSelection+ , PatchSelectionContext(allowSkipAll)+ )+import qualified Darcs.UI.SelectChanges as S+import Darcs.Repository.Util ( patchSetfMap )+import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) )+import Darcs.Util.Path ( AbsolutePath )++import Storage.Hashed.Tree( Tree )++import System.IO ( hPutStr, stderr )++tagDescription :: String+tagDescription = "Name the current repository state for future reference."++tagHelp :: String+tagHelp =+ "The `darcs tag` command names the current repository state, so that it\n" +++ "can easily be referred to later. Every *important* state should be\n" +++ "tagged; in particular it is good practice to tag each stable release\n" +++ "with a number or codename. Advice on release numbering can be found\n" +++ "at <http://producingoss.com/en/development-cycle.html>.\n" +++ "\n" +++ "To reproduce the state of a repository `R` as at tag `t`, use the\n" +++ "command `darcs get --tag t R`. The command `darcs show tags` lists\n" +++ "all tags in the current repository.\n" +++ "\n" +++ "Tagging also provides significant performance benefits: when Darcs\n" +++ "reaches a shared tag that depends on all antecedent patches, it can\n" +++ "simply stop processing.\n" +++ "\n" +++ "Like normal patches, a tag has a name, an author, a timestamp and an\n" +++ "optional long description, but it does not change the working tree.\n" +++ "A tag can have any name, but it is generally best to pick a naming\n" +++ "scheme and stick to it.\n" +++ "\n" +++ "By default a tag names the entire repository state at the time the tag\n" +++ "is created. If the --ask-deps option is used, the patches to include\n" +++ "as part of the tag can be explicitly selected.\n" +++ "\n" +++ "The `darcs tag` command accepts the `--pipe` option, which behaves as\n" +++ "described in `darcs record`.\n"++tagBasicOpts :: DarcsOption a+ (Maybe String+ -> Maybe String+ -> Bool+ -> Maybe O.AskLongComment+ -> Bool+ -> Maybe String+ -> a)+tagBasicOpts+ = O.patchname+ ^ O.author+ ^ O.pipe+ ^ O.askLongComment+ ^ O.askdeps+ ^ O.workingRepoDir++tagAdvancedOpts :: DarcsOption a (O.Compression -> O.UMask -> a)+tagAdvancedOpts = O.compress ^ O.umask++tagOpts :: DarcsOption a+ (Maybe String+ -> Maybe String+ -> Bool+ -> Maybe O.AskLongComment+ -> Bool+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.Compression+ -> O.UMask+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+tagOpts = tagBasicOpts `withStdOpts` tagAdvancedOpts++tag :: DarcsCommand [DarcsFlag]+tag = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "tag"+ , commandHelp = tagHelp+ , commandDescription = tagDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[TAGNAME]"]+ , commandCommand = tagCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc tagAdvancedOpts+ , commandBasicOptions = odesc tagBasicOpts+ , commandDefaults = defaultFlags tagOpts+ , commandCheckOptions = ocheck tagOpts+ , commandParseOptions = onormalise tagOpts+ }++filterNonInternal :: MaybeInternal p => PatchSet p wX wY -> PatchSet p wX wY+filterNonInternal =+ case patchInternalChecker of+ Nothing -> id+ Just f -> \(PatchSet ps ts) -> PatchSet (filterOutRLRL (isInternal f . patchcontents . hopefully) ps) ts++tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+tagCmd _ opts args =+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \(repository :: Repository p wR wU wR) -> do+ date <- getDate (hasPipe opts)+ the_author <- getAuthor (hasAuthor opts) (hasPipe opts)+ patches <- readRepo repository+ tags <- getTags patches+ let nonInternalPatches = filterNonInternal patches+ Sealed chosenPatches <-+ if AskDeps `elem` opts+ then mapSeal (appendPSFL emptyPatchSet) <$> askAboutTagDepends opts (newset2FL nonInternalPatches)+ else return $ Sealed nonInternalPatches+ let deps = getUncovered chosenPatches+ (name, long_comment) <- get_name_log (NilFL :: FL (PrimOf p) wA wA) args tags+ myinfo <- patchinfo date name the_author long_comment+ let mypatch = infopatch myinfo NilFL+ _ <- tentativelyAddPatch repository (compression opts) (verbosity opts) YesUpdateWorking+ $ n2pia $ adddeps mypatch deps+ finalizeRepositoryChanges repository YesUpdateWorking (compression opts)+ putStrLn $ "Finished tagging patch '"++name++"'"+ where get_name_log ::(Patchy prim, PrimPatch prim) => FL prim wA wA -> [String] -> [String] -> IO (String, [String])+ get_name_log nilFL a tags+ = do (name, comment, _) <- getLog+ (case parseFlags O.patchname opts of+ Nothing -> Just (unwords a)+ Just s -> Just s)+ (hasPipe opts)+ (parseFlags O.logfile opts)+ (parseFlags O.askLongComment opts)+ Nothing nilFL+ when (length name < 2) $ hPutStr stderr $+ "Do you really want to tag '"+ ++name++"'? If not type: darcs obliterate --last=1\n"+ when (name `elem` tags) $+ putStrLn $ "WARNING: The tag " ++ + "\"" ++ name ++ "\"" +++ " already exists."+ return ("TAG " ++ name, comment)++getTags :: MaybeInternal p => PatchSet p wW wR -> IO [String]+getTags ps = catMaybes `fmap` patchSetfMap (return . piTag . info) ps++-- This may be useful for developers, but users don't care about+-- internals:+--+-- A tagged version automatically depends on all patches in the+-- repository. This allows you to later reproduce precisely that+-- version. The tag does this by depending on all patches in the+-- repository, except for those which are depended upon by other tags+-- already in the repository. In the common case of a sequential+-- series of tags, this means that the tag depends on all patches+-- since the last tag, plus that tag itself.++askAboutTagDepends+ :: forall p wX wY . (RepoPatch p, ApplyState p ~ Tree)+ => [DarcsFlag]+ -> FL (PatchInfoAnd p) wX wY+ -> IO (Sealed (FL (PatchInfoAnd p) wX))+askAboutTagDepends flags ps = do+ let opts = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = []+ , S.diffAlgorithm = diffAlgorithm flags+ , S.interactive = True+ , S.selectDeps = O.PromptDeps+ , S.summary = O.NoSummary+ , S.withContext = O.NoContext+ }+ (deps:>_) <- runSelection (selectChanges ps) $+ ((selectionContext FirstReversed "depend on" opts Nothing Nothing)+ { allowSkipAll = False })+ return $ Sealed deps++hasPipe :: [DarcsFlag] -> Bool+hasPipe = parseFlags O.pipe
+ src/Darcs/UI/Commands/Test.hs view
@@ -0,0 +1,363 @@+-- Copyright (C) 2002-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Test+ (+ test+ ) where++import Prelude hiding ( (^), init, catch )++import Control.Exception ( catch, IOException )+import Control.Monad( when )++import System.Process ( system )+import System.Exit ( ExitCode(..), exitWith )+import System.IO ( hFlush, stdout )++import Storage.Hashed.Tree( Tree )++import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts+ , nodefaults+ , putInfo+ , amInHashedRepository )+import Darcs.UI.Flags ( DarcsFlag( SetScriptsExecutable+ , Linear+ , Backoff+ , Bisect+ , LeaveTestDir+ )+ , useCache, verbosity )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Patch.PatchInfoAnd ( hopefully )+import Darcs.Repository (+ readRepo+ , withRepository+ , RepoJob(..)+ , withRecorded+ , setScriptsExecutablePatches+ , setScriptsExecutable+ )+import Darcs.Patch.Witnesses.Ordered+ ( RL(..)+ , (:<)(..)+ , (+<+)+ , reverseRL+ , splitAtRL+ , lengthRL+ , mapRL+ , mapFL+ , mapRL_RL+ )+import Darcs.Patch.Conflict ( Conflict )+import Darcs.Patch.FileHunk ( IsHunk )+import Darcs.Patch.ApplyMonad ( ApplyMonad )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Patchy ( Patchy+ , Invert+ , Apply+ , ShowPatch+ )+import Darcs.Patch ( RepoPatch+ , Named+ , description+ , apply+ , invert+ )+import Darcs.Patch.Set ( newset2RL )+import Darcs.Util.Printer ( putDocLn+ , text+ )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault )+import Darcs.Repository.Test ( getTest )+import Darcs.Repository.Lock+ ( withTempDir+ , withPermDir+ )+++testDescription :: String+testDescription = "Run regression test."++testHelp :: String+testHelp =+ unlines+ [ "Run test on the current recorded state of the repository. Given no"+ ,"arguments, it uses the default repository test (see `darcs setpref`)."+ ,"Given one argument, it treats it as a test command."+ ,"Given two arguments, the first is an initialization command and the"+ ,"second is the test (meaning the exit code of the first command is not"+ ,"taken into account to determine success of the test)."+ ,"If given the `--linear` or `--bisect` flags, it tries to find the most"+ ,"recent version in the repository which passes a test."+ ,""+ ,"`--linear` does linear search starting from head, and moving away"+ ,"from head. This strategy is best when the test runs very quickly"+ ,"or the patch you're seeking is near the head."+ ,""+ ,"`--bisect` does binary search. This strategy is best when the test"+ ,"runs very slowly or the patch you're seeking is likely to be in"+ ,"the repository's distant past."+ ,""+ ,"`--backoff` starts searching from head, skipping further and further"+ ,"into the past until the test succeeds. It then does a binary search"+ ,"on a subset of those skipped patches. This strategy works well unless"+ ,"the patch you're seeking is in the repository's distant past."+ ,""+ ,"Under the assumption that failure is monotonous, `--linear` and"+ ,"`--bisect` produce the same result. (Monotonous means that when moving"+ ,"away from head, the test result changes only once from \"fail\" to"+ ,"\"ok\".) If failure is not monotonous, any one of the patches that"+ ,"break the test is found at random."+ ]++testBasicOpts :: DarcsOption a+ (O.TestStrategy -> O.LeaveTestDir -> Maybe String -> a)+testBasicOpts = O.testStrategy ^ O.leaveTestDir ^ O.workingRepoDir++testAdvancedOpts :: DarcsOption a (O.SetScriptsExecutable -> a)+testAdvancedOpts = O.setScriptsExecutable++testOpts :: DarcsOption a+ (O.TestStrategy+ -> O.LeaveTestDir+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.SetScriptsExecutable+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+testOpts = testBasicOpts `withStdOpts` testAdvancedOpts++test :: DarcsCommand [DarcsFlag]+test = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "test"+ , commandHelp = testHelp+ , commandDescription = testDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[[INITIALIZATION]", "COMMAND]"]+ , commandCommand = testCommand+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc testAdvancedOpts+ , commandBasicOptions = odesc testBasicOpts+ , commandDefaults = defaultFlags testOpts+ , commandCheckOptions = ocheck testOpts+ , commandParseOptions = onormalise testOpts+ }++-- | Functions defining a strategy for executing a test+type Strategy = forall p wX wY+ . (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree)+ => [DarcsFlag]+ -> IO ExitCode -- ^ test command+ -> ExitCode+ -> RL (Named p) wX wY+ -> IO ()++testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+testCommand _ opts args =+ withRepository (useCache opts) $ RepoJob $ \repository -> do+ patches <- readRepo repository+ (init,testCmd) <- case args of+ [] ->+ do t <- getTest (verbosity opts)+ return (return ExitSuccess, t)+ [cmd] ->+ do putStrLn $ "Using test command:\n"++cmd+ return (return ExitSuccess, system cmd)+ [init,cmd] ->+ do putStrLn $ "Using initialization command:\n"++init+ putStrLn $ "Using test command:\n"++cmd+ return (system init, system cmd)+ _ -> fail "Test expects zero to two arguments."+ let wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir+ withRecorded repository (wd "testing") $ \_ -> do+ when (SetScriptsExecutable `elem` opts) setScriptsExecutable+ _ <- init+ putInfo opts $ text "Running test...\n"+ testResult <- testCmd+ let track = chooseStrategy opts+ track opts testCmd testResult (mapRL_RL hopefully . newset2RL $ patches)++chooseStrategy :: [DarcsFlag] -> Strategy+chooseStrategy opts+ | Bisect `elem` opts = trackBisect+ | Linear `elem` opts = trackLinear+ | Backoff `elem` opts = trackBackoff+ | otherwise = oneTest++-- | test only the last recorded state+oneTest :: Strategy+oneTest opts _ ExitSuccess _ = putInfo opts $ text "Test ran successfully.\n"+oneTest opts _ testResult _ = do+ putInfo opts $ text "Test failed!\n"+ exitWith testResult++-- | linear search (with --linear)+trackLinear :: Strategy+trackLinear _ _ ExitSuccess _ = putStrLn "Success!"+trackLinear opts testCmd (ExitFailure _) (p:<:ps) = do+ let ip = invert p+ safeApply ip+ when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches ip+ putStrLn "Trying without the patch:"+ putDocLn $ description ip+ hFlush stdout+ testResult <- testCmd+ trackLinear opts testCmd testResult ps+trackLinear _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!"++-- | exponential backoff search (with --backoff)+trackBackoff :: Strategy+trackBackoff _ _ ExitSuccess NilRL = putStrLn "Success!"+trackBackoff _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!"+trackBackoff _ _ ExitSuccess _ = putStrLn "Test does not fail on head."+trackBackoff opts testCmd (ExitFailure _) ps =+ trackNextBackoff opts testCmd 4 ps++trackNextBackoff :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree)+ => [DarcsFlag]+ -> IO ExitCode+ -> Int -- ^ number of patches to skip+ -> RL (Named p) wY wZ -- ^ patches not yet skipped+ -> IO ()+trackNextBackoff _ _ _ NilRL = putStrLn "Noone passed the test!"+trackNextBackoff opts testCmd n ahead+ | n >= lengthRL ahead = initialBisect opts testCmd ahead+trackNextBackoff opts testCmd n ahead = do+ putStrLn $ "Skipping " ++ show n ++ " patches..."+ hFlush stdout+ case splitAtRL n ahead of+ ( skipped' :< ahead' ) -> do+ unapplyRL skipped'+ when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches skipped'+ testResult <- testCmd+ case testResult of+ ExitFailure _ ->+ trackNextBackoff opts testCmd (2*n) ahead'+ ExitSuccess -> do+ applyRL skipped' -- offending patch is one of these+ initialBisect opts testCmd skipped' -- bisect to find it++-- | binary search (with --bisect)+trackBisect :: Strategy+trackBisect _ _ ExitSuccess NilRL = putStrLn "Success!"+trackBisect _ _ (ExitFailure _) NilRL = putStrLn "Noone passed the test!"+trackBisect _ _ ExitSuccess _ = putStrLn "Test does not fail on head."+trackBisect opts testCmd (ExitFailure _) ps =+ initialBisect opts testCmd ps++initialBisect :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree)+ => [DarcsFlag]+ -> IO ExitCode+ -> RL (Named p) wX wY+ -> IO ()+initialBisect opts testCmd ps =+ trackNextBisect opts currProg testCmd BisectRight (patchTreeFromRL ps)+ where+ maxProg = 1 + round ((logBase 2 $ fromIntegral $ lengthRL ps) :: Double)+ currProg = (1, maxProg) :: BisectState++-- | Bisect Patch Tree+data PatchTree p wX wY where+ Leaf :: p wX wY -> PatchTree p wX wY+ Fork :: PatchTree p wY wZ -> PatchTree p wX wY -> PatchTree p wX wZ++-- | Direction of Bisect trackdown+data BisectDir = BisectLeft | BisectRight deriving Show++-- | Progress of Bisect+type BisectState = (Int, Int)++-- | Create Bisect PatchTree from the RL+patchTreeFromRL :: (Patchy p) => RL p wX wY -> PatchTree p wX wY+patchTreeFromRL (l :<: NilRL) = Leaf l+patchTreeFromRL xs = case splitAtRL (lengthRL xs `div` 2) xs of+ (l :< r) -> Fork (patchTreeFromRL l) (patchTreeFromRL r)++-- | Convert PatchTree back to RL+patchTree2RL :: (Patchy p) => PatchTree p wX wY -> RL p wX wY+patchTree2RL (Leaf p) = p :<: NilRL+patchTree2RL (Fork l r) = patchTree2RL l +<+ patchTree2RL r++-- | Iterate the Patch Tree+trackNextBisect :: (RepoPatch p, ApplyMonad DefaultIO (ApplyState p), ApplyState p ~ Tree)+ => [DarcsFlag]+ -> BisectState+ -> IO ExitCode -- ^ test command+ -> BisectDir+ -> PatchTree (Named p) wX wY+ -> IO ()+trackNextBisect opts (dnow, dtotal) testCmd dir (Fork l r) = do+ putStr $ "Trying " ++ show dnow ++ "/" ++ show dtotal ++ " sequences...\n"+ hFlush stdout+ case dir of+ BisectRight -> jumpHalfOnRight opts l -- move in temporary repo+ BisectLeft -> jumpHalfOnLeft opts r -- within given direction+ testResult <- testCmd -- execute test on repo+ case testResult of+ ExitSuccess -> trackNextBisect opts (dnow+1, dtotal) testCmd+ BisectLeft l -- continue left (to the present)+ _ -> trackNextBisect opts (dnow+1, dtotal) testCmd+ BisectRight r -- continue right (to the past)+trackNextBisect _ _ _ _ (Leaf p) = do+ putStrLn "Last recent patch that fails the test (assuming monotony in the given range):"+ putDocLn (description p)++jumpHalfOnRight :: (IsHunk p, Conflict p,+ PatchListFormat p, ShowPatch p, PatchInspect p,+ Patchy p, ApplyMonad DefaultIO (ApplyState p))+ => [DarcsFlag] -> PatchTree p wX wY -> IO ()+jumpHalfOnRight opts l = do unapplyRL ps+ when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches ps+ where ps = patchTree2RL l++jumpHalfOnLeft :: (IsHunk p, Conflict p,+ PatchListFormat p, ShowPatch p, PatchInspect p,+ Patchy p, ApplyMonad DefaultIO (ApplyState p))+ => [DarcsFlag] -> PatchTree p wX wY -> IO ()+jumpHalfOnLeft opts r = do applyRL p+ when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches p++ where p = patchTree2RL r++applyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad DefaultIO (ApplyState p))+ => RL p wX wY -> IO ()+applyRL patches = sequence_ (mapFL safeApply (reverseRL patches))++unapplyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad DefaultIO (ApplyState p))+ => RL p wX wY -> IO ()+unapplyRL patches = sequence_ (mapRL (safeApply . invert) patches)++safeApply :: (Invert p, ShowPatch p, Apply p, ApplyMonad DefaultIO (ApplyState p))+ => p wX wY -> IO ()+safeApply p = runDefault (apply p) `catch` \(msg :: IOException) -> fail $ "Bad patch:\n" ++ show msg
+ src/Darcs/UI/Commands/TransferMode.hs view
@@ -0,0 +1,112 @@+-- Copyright (C) 2008 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++-- The pragma above is only for pattern guards.+module Darcs.UI.Commands.TransferMode ( transferMode ) where++import Prelude hiding ( catch )+import Control.Exception ( catch )+import System.IO ( stdout, hFlush )++import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Exception ( prettyException )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )+import Darcs.UI.Flags ( DarcsFlag )+import Darcs.UI.Options ( DarcsOption, oid, odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Progress ( setProgressMode )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Path ( AbsolutePath )++import qualified Data.ByteString as B (hPut, readFile, length, ByteString)++transferModeDescription :: String+transferModeDescription = "Internal command for efficient ssh transfers."++transferModeHelp :: String+transferModeHelp =+ "When pulling from or pushing to a remote repository over ssh, if both\n" +++ "the local and remote ends have Darcs 2, the `transfer-mode' command\n" +++ "will be invoked on the remote end. This allows Darcs to intelligently\n" +++ "transfer information over a single ssh connection.\n" +++ "\n" +++ "If either end runs Darcs 1, a separate ssh connection will be created\n" +++ "for each transfer. As well as being less efficient, this means users\n" +++ "who do not run ssh-agent will be prompted for the ssh password tens or\n" +++ "hundreds of times!\n"++transferModeBasicOpts :: DarcsOption a (Maybe String -> a)+transferModeBasicOpts = O.workingRepoDir++transferModeOpts :: DarcsOption a+ (Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+transferModeOpts = transferModeBasicOpts `withStdOpts` oid++transferMode :: DarcsCommand [DarcsFlag]+transferMode = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "transfer-mode"+ , commandHelp = transferModeHelp+ , commandDescription = transferModeDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandGetArgPossibilities = return []+ , commandCommand = transferModeCmd+ , commandPrereq = amInRepository+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = []+ , commandBasicOptions = odesc transferModeBasicOpts+ , commandDefaults = defaultFlags transferModeOpts+ , commandCheckOptions = ocheck transferModeOpts+ , commandParseOptions = onormalise transferModeOpts+ }++transferModeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+transferModeCmd _ _ _ = do setProgressMode False+ putStrLn "Hello user, I am darcs transfer mode"+ hFlush stdout+ withCurrentDirectory darcsdir transfer++transfer :: IO ()+transfer = do 'g':'e':'t':' ':fn <- getLine+ x <- readfile fn+ case x of+ Right c -> do putStrLn $ "got " ++ fn+ print $ B.length c+ B.hPut stdout c+ hFlush stdout+ Left e -> do putStrLn $ "error " ++ fn+ print e+ hFlush stdout+ transfer++readfile :: String -> IO (Either String B.ByteString)+readfile fn = (Right `fmap` B.readFile fn) `catch` (return . Left . prettyException)+
+ src/Darcs/UI/Commands/Unrecord.hs view
@@ -0,0 +1,445 @@+-- Copyright (C) 2002-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, OverloadedStrings #-}++module Darcs.UI.Commands.Unrecord+ ( unrecord+ , unpull+ , obliterate+ , getLastPatches+ , matchingHead+ ) where++import Prelude hiding ( (^), catch )++import Control.Exception ( catch, IOException )+import Control.Monad ( when )+import Data.Maybe( isJust, mapMaybe )+import Data.List ( intercalate )+import Storage.Hashed.Tree( Tree )+import System.Exit ( exitSuccess )++import Darcs.Patch ( RepoPatch, invert, commute, effect )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Bundle ( makeBundleN, contextPatches, minContext )+import Darcs.Patch.Depends ( findCommonWithThem, newsetUnion )+import Darcs.Patch.Match ( firstMatch, matchFirstPatchset, matchAPatchread, MatchFlag )+import Darcs.Patch.PatchInfoAnd ( hopefully, patchDesc )+import Darcs.Patch.Set ( PatchSet(..), Tagged(..), appendPSFL, Origin,+ SealedPatchSet )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )+import Darcs.Patch.Witnesses.Ordered ( RL(..), (:>)(..), (+<+), mapFL_FL,+ nullFL, reverseRL, mapRL, FL(..) )+import Darcs.Util.Path( useAbsoluteOrStd, AbsolutePath, toFilePath, doesPathExist )+import Darcs.Util.SignalHandler ( catchInterrupt )+import Darcs.Repository ( PatchInfoAnd, withRepoLock, RepoJob(..), Repository,+ tentativelyRemovePatches, finalizeRepositoryChanges,+ tentativelyAddToPending, applyToWorking, readRepo,+ invalidateIndex, unrecordedChanges,+ identifyRepositoryFor )+import Darcs.Repository.Flags( UseIndex(..), ScanKnown(..), UpdateWorking(..), DryRun(NoDryRun) )+import Darcs.Repository.Lock( writeDocBinFile )+import Darcs.Repository.Prefs ( getDefaultRepoPath )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias+ , putVerbose, printDryRunMessageAndExit+ , setEnvDarcsPatches, amInHashedRepository+ , putInfo )+import Darcs.UI.Commands.Util ( getUniqueDPatchName )+import Darcs.UI.Flags+ ( doReverse, compression, verbosity, getOutput+ , useCache, dryRun, umask, DarcsFlag ( NotInRemote ), minimize+ , diffAlgorithm, hasXmlOutput, hasSummary, isInteractive, selectDeps )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )+import Darcs.UI.Options.All ( notInRemoteFlagName )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.SelectChanges ( selectChanges, WhichChanges(..),+ selectionContext, runSelection )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.Util.English ( presentParticiple )+import Darcs.Util.Printer ( text, putDoc )+import Darcs.Util.Progress ( debugMessage )++unrecordDescription :: String+unrecordDescription =+ "Remove recorded patches without changing the working copy."++unrecordHelp :: String+unrecordHelp = unlines+ [ "Unrecord does the opposite of record: it deletes patches from"+ , "the repository, without changing the working copy."+ , "Deleting patches from the repository makes active changes again"+ , "which you may record or revert later."+ , "Beware that you should not use this command if there is a"+ , "possibility that another user may have already pulled the patch."+ ]++unrecordBasicOpts :: DarcsOption a+ ([MatchFlag] -> O.SelectDeps -> Maybe Bool -> Maybe String -> a)+unrecordBasicOpts+ = O.matchSeveralOrLast+ ^ O.selectDeps+ ^ O.interactive -- True+ ^ O.workingRepoDir++unrecordAdvancedOpts :: DarcsOption a (O.Compression -> O.UMask -> Bool -> a)+unrecordAdvancedOpts+ = O.compress+ ^ O.umask+ ^ O.changesReverse++unrecordOpts :: DarcsOption a+ ([MatchFlag]+ -> O.SelectDeps+ -> Maybe Bool+ -> Maybe String+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.Compression+ -> O.UMask+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+unrecordOpts = unrecordBasicOpts `withStdOpts` unrecordAdvancedOpts++unrecord :: DarcsCommand [DarcsFlag]+unrecord = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "unrecord"+ , commandHelp = unrecordHelp+ , commandDescription = unrecordDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = unrecordCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc unrecordAdvancedOpts+ , commandBasicOptions = odesc unrecordBasicOpts+ , commandDefaults = defaultFlags unrecordOpts+ , commandCheckOptions = ocheck unrecordOpts+ , commandParseOptions = onormalise unrecordOpts+ }++unrecordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+unrecordCmd _ opts _ =+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $+ RepoJob $ \repository -> do+ allpatches <- readRepo repository+ let matchFlags = parseFlags O.matchSeveralOrLast opts+ (_ :> patches) <- return $+ if firstMatch matchFlags+ then getLastPatches matchFlags allpatches+ else matchingHead matchFlags allpatches+ let direction = if doReverse opts then Last else LastReversed+ context = selectionContext direction "unrecord" (patchSelOpts opts) Nothing Nothing+ (_ :> to_unrecord) <- runSelection (selectChanges patches) context+ when (nullFL to_unrecord) $ do+ putStrLn "No patches selected!"+ exitSuccess+ putVerbose opts $+ text "About to write out (potentially) modified patches..."+ setEnvDarcsPatches to_unrecord+ invalidateIndex repository+ _ <- tentativelyRemovePatches repository (compression opts)+ YesUpdateWorking to_unrecord+ finalizeRepositoryChanges repository YesUpdateWorking (compression opts)+ putStrLn "Finished unrecording."++getLastPatches :: RepoPatch p => [MatchFlag] -> PatchSet p Origin wR+ -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR+getLastPatches matchFlags ps = case matchFirstPatchset matchFlags ps of+ Sealed p1s -> findCommonWithThem ps p1s++unpullDescription :: String+unpullDescription =+ "Opposite of pull; unsafe if patch is not in remote repository."++unpullHelp :: String+unpullHelp = unlines+ [ "Unpull completely removes recorded patches from your local repository."+ , "The changes will be undone in your working copy and the patches"+ , "will not be shown in your changes list anymore. Beware that if the"+ , "patches are not still present in another repository you will lose"+ , "precious code by unpulling!"+ , ""+ , "One way to save unpulled patches is to use the -O flag. A patch"+ , "bundle will be created locally, that you will be able to apply"+ , "later to your repository with `darcs apply`."+ ]++unpull :: DarcsCommand [DarcsFlag]+unpull = (commandAlias "unpull" Nothing obliterate)+ { commandHelp = unpullHelp+ , commandDescription = unpullDescription+ , commandCommand = unpullCmd+ }++unpullCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+unpullCmd = genericObliterateCmd "unpull"++obliterateDescription :: String+obliterateDescription =+ "Delete selected patches from the repository. (UNSAFE!)"++obliterateHelp :: String+obliterateHelp = unlines+ [ "Obliterate completely removes recorded patches from your local"+ , "repository. The changes will be undone in your working copy and the"+ , "patches will not be shown in your changes list anymore. Beware that"+ , "you can lose precious code by obliterating!"+ , ""+ , "One way to save obliterated patches is to use the -O flag. A patch"+ , "bundle will be created locally, that you will be able to apply"+ , "later to your repository with `darcs apply`."+ ]++obliterateBasicOpts :: DarcsOption a+ ([Maybe String]+ -> [MatchFlag]+ -> O.SelectDeps+ -> Maybe Bool+ -> Maybe String+ -> Maybe O.Summary+ -> Maybe O.Output+ -> Bool+ -> O.DiffAlgorithm+ -> O.DryRun+ -> O.XmlOutput+ -> a)+obliterateBasicOpts+ = O.notInRemote+ ^ O.matchSeveralOrLast+ ^ O.selectDeps+ ^ O.interactive+ ^ O.workingRepoDir+ ^ O.summary+ ^ O.output+ ^ O.minimize+ ^ O.diffAlgorithm+ ^ O.dryRunXml++obliterateAdvancedOpts :: DarcsOption a+ (O.Compression -> O.UseIndex -> O.UMask -> Bool -> a)+obliterateAdvancedOpts+ = O.compress+ ^ O.useIndex+ ^ O.umask+ ^ O.changesReverse++obliterateOpts :: DarcsOption a+ ([Maybe String]+ -> [MatchFlag]+ -> O.SelectDeps+ -> Maybe Bool+ -> Maybe String+ -> Maybe O.Summary+ -> Maybe O.Output+ -> Bool+ -> O.DiffAlgorithm+ -> DryRun+ -> O.XmlOutput+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.Compression+ -> UseIndex+ -> O.UMask+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+obliterateOpts = obliterateBasicOpts `withStdOpts` obliterateAdvancedOpts++obliterate :: DarcsCommand [DarcsFlag]+obliterate = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "obliterate"+ , commandHelp = obliterateHelp+ , commandDescription = obliterateDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = obliterateCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc obliterateAdvancedOpts+ , commandBasicOptions = odesc obliterateBasicOpts+ , commandDefaults = defaultFlags obliterateOpts+ , commandCheckOptions = ocheck obliterateOpts+ , commandParseOptions = onormalise obliterateOpts+ }++obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+obliterateCmd = genericObliterateCmd "obliterate"++data NotInRemoteLocation = NotInDefaultRepo+ | NotInRemotePath String++-- | genericObliterateCmd is the function that executes the "obliterate" and+-- "unpull" commands. The first argument is the name under which the command is+-- invoked (@unpull@ or @obliterate@).+genericObliterateCmd :: String+ -> (AbsolutePath, AbsolutePath)+ -> [DarcsFlag]+ -> [String]+ -> IO ()+genericObliterateCmd cmdname _ opts _ =+ let cacheOpt = useCache opts+ in withRepoLock (dryRun opts) cacheOpt YesUpdateWorking (umask opts) $+ RepoJob $ \repository -> do+ -- FIXME we may need to honour --ignore-times here, although this+ -- command does not take that option (yet)+ pend <- unrecordedChanges (UseIndex, ScanKnown, diffAlgorithm opts) repository Nothing+ allpatches <- readRepo repository+ let collectNotIns (NotInRemote nir) = case nir of+ Just p -> Just $ NotInRemotePath p+ Nothing -> Just NotInDefaultRepo+ collectNotIns _ = Nothing+ notIns = mapMaybe collectNotIns opts+ (auto_kept :> removal_candidates) <- case notIns of+ [] -> do+ let matchFlags = parseFlags O.matchSeveralOrLast opts+ return $ if firstMatch matchFlags+ then getLastPatches matchFlags allpatches+ else matchingHead matchFlags allpatches+ nirs -> do+ (Sealed thems) <-+ getNotInRemotePatches cacheOpt repository nirs+ return $ findCommonWithThem allpatches thems++ let direction = if doReverse opts then Last else LastReversed+ context = selectionContext direction cmdname (patchSelOpts opts) Nothing Nothing+ (kept :> removed) <-+ runSelection (selectChanges removal_candidates) context+ when (nullFL removed) $ do+ putStrLn "No patches selected!"+ exitSuccess+ case commute (effect removed :> pend) of+ Nothing -> fail $ "Can't " ++ cmdname+ ++ " patch without reverting some "+ ++ "unrecorded change."+ Just (_ :> p_after_pending) -> do+ printDryRunMessageAndExit "obliterate"+ (verbosity opts)+ (hasSummary O.NoSummary opts)+ (dryRun opts)+ (hasXmlOutput opts)+ (isInteractive opts)+ removed+ setEnvDarcsPatches removed+ when (isJust $ getOutput opts "") $+ savetoBundle opts (auto_kept `appendPSFL` kept) removed+ invalidateIndex repository+ _ <- tentativelyRemovePatches repository+ (compression opts) YesUpdateWorking removed+ tentativelyAddToPending repository+ YesUpdateWorking $ invert $ effect removed+ finalizeRepositoryChanges repository+ YesUpdateWorking (compression opts)+ debugMessage "Applying patches to working directory..."+ _ <- applyToWorking repository (verbosity opts)+ (invert p_after_pending)+ `catch` \(e :: IOException) -> fail $+ "Couldn't undo patch in working dir.\n"+ ++ show e+ putStrLn $ "Finished " ++ presentParticiple cmdname ++ "."++-- | Get the union of the set of patches in each specified location+getNotInRemotePatches :: (RepoPatch p, ApplyState p ~ Tree) => O.UseCache+ -> Repository p wX wU wT -> [NotInRemoteLocation]+ -> IO (SealedPatchSet p Origin)+getNotInRemotePatches cacheOpt repository nirs = do+ putStrLn $ "Determining patches not in" ++ pluralExtra ++ ":\n" ++ names+ nirsPaths <- mapM getNotInRemotePath nirs+ newsetUnion `fmap` mapM readNir nirsPaths+ where+ toName (NotInRemotePath s) = "'" ++ s ++ "'"+ toName NotInDefaultRepo = "Default push/pull repo"++ pluralExtra = if length names > 1 then " any of" else ""+ names = intercalate "\n" $ map ((leader ++) . toName) nirs+ leader = " - "++ readNir n = do+ r <- identifyRepositoryFor repository cacheOpt n+ rps <- readRepo r+ return $ seal rps++ getNotInRemotePath (NotInRemotePath p) = return p+ getNotInRemotePath NotInDefaultRepo = do+ defaultRepo <- getDefaultRepoPath+ let err = fail $ "No default push/pull repo configured, please pass a "+ ++ "repo name to --" ++ notInRemoteFlagName+ maybe err return defaultRepo++-- | matchingHead returns the repository up to some tag. The tag t is the last+-- tag such that there is a patch after t that is matched by the user's query.+matchingHead :: forall p wR. RepoPatch p => [MatchFlag] -> PatchSet p Origin wR+ -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR+matchingHead matchFlags set =+ case mh set of+ (start :> patches) -> start :> reverseRL patches+ where+ mh :: forall wX . PatchSet p Origin wX+ -> (PatchSet p :> RL (PatchInfoAnd p)) Origin wX+ mh s@(PatchSet x _)+ | or (mapRL (matchAPatchread matchFlags) x) = contextPatches s+ mh (PatchSet x (Tagged t _ ps :<: ts)) =+ case mh (PatchSet (t :<: ps) ts) of+ (start :> patches) -> start :> x +<+ patches+ mh ps = ps :> NilRL++savetoBundle :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag]+ -> PatchSet p Origin wZ -> FL (PatchInfoAnd p) wZ wT -> IO ()+savetoBundle opts kept removed@(x :>: _) = do+ let genFullBundle = makeBundleN Nothing kept (mapFL_FL hopefully removed)+ bundle <- if not (minimize opts)+ then genFullBundle+ else do putInfo opts "Minimizing context, to generate bundle with full context hit ctrl-C..."+ ( case minContext kept removed of+ Sealed (kept' :> removed') -> makeBundleN Nothing kept' (mapFL_FL hopefully removed') )+ `catchInterrupt` genFullBundle+ filename <- getUniqueDPatchName (patchDesc x)+ let Just outname = getOutput opts filename+ exists <- useAbsoluteOrStd (doesPathExist . toFilePath) (return False) outname+ when exists $ fail $ "Directory or file named '" ++ (show outname) ++ "' already exists."+ useAbsoluteOrStd writeDocBinFile putDoc outname bundle+savetoBundle _ _ NilFL = return ()++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = parseFlags O.matchSeveralOrLast flags+ , S.diffAlgorithm = diffAlgorithm flags+ , S.interactive = isInteractive flags+ , S.selectDeps = selectDeps flags+ , S.summary = hasSummary O.NoSummary flags+ , S.withContext = O.NoContext+ }
+ src/Darcs/UI/Commands/Unrevert.hs view
@@ -0,0 +1,203 @@+-- Copyright (C) 2003-2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, GADTs #-}+++module Darcs.UI.Commands.Unrevert ( unrevert, writeUnrevert ) where++import Prelude hiding ( (^), catch )++import Control.Exception ( catch, IOException )+import System.Exit ( exitSuccess )+import Storage.Hashed.Tree( Tree )++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Flags+ ( diffingOpts, verbosity, useCache, umask, compression, diffAlgorithm+ , isInteractive, isUnified )+import Darcs.Repository.Flags+ ( UseIndex(..), ScanKnown (..), Reorder(..), AllowConflicts(..), ExternalMerge(..)+ , WantGuiPause(..), UpdateWorking(..), DryRun(NoDryRun) )+import Darcs.UI.Flags ( DarcsFlag )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, RepoJob(..),+ unrevertUrl, considerMergeToWorking,+ tentativelyAddToPending, finalizeRepositoryChanges,+ readRepo,+ readRecorded,+ applyToWorking, unrecordedChanges )+import Darcs.Patch ( RepoPatch, PrimOf, commute, namepatch, fromPrims )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Set ( Origin )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (+>+) )+import Darcs.UI.SelectChanges+ ( selectChanges+ , WhichChanges(First)+ , runSelection+ , selectionContextPrim+ )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import qualified Data.ByteString as B+import Darcs.Repository.Lock ( writeDocBinFile, removeFileMayNotExist )+import Darcs.Patch.Depends ( mergeThem )+import Darcs.UI.External ( catchall )+import Darcs.Util.Prompt ( askUser )+import Darcs.Patch.Bundle ( scanBundle, makeBundleN )+import Darcs.Util.IsoDate ( getIsoDateTime )+import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Path ( AbsolutePath )+#include "impossible.h"++unrevertDescription :: String+unrevertDescription =+ "Undo the last revert (may fail if changes after the revert)."++unrevertHelp :: String+unrevertHelp =+ "Unrevert is a rescue command in case you accidentally reverted\n" +++ "something you wanted to keep (for example, typing `darcs rev -a`\n" +++ "instead of `darcs rec -a`).\n" +++ "\n" +++ "This command may fail if the repository has changed since the revert\n" +++ "took place. Darcs will ask for confirmation before executing an\n" +++ "interactive command that will DEFINITELY prevent unreversion.\n"++unrevertBasicOpts :: DarcsOption a+ (O.UseIndex+ -> Maybe Bool+ -> Maybe String+ -> O.WithContext+ -> O.DiffAlgorithm+ -> a)+unrevertBasicOpts+ = O.useIndex+ ^ O.interactive -- True+ ^ O.workingRepoDir+ ^ O.withContext+ ^ O.diffAlgorithm++unrevertAdvancedOpts :: DarcsOption a (O.UMask -> a)+unrevertAdvancedOpts = O.umask++unrevertOpts :: DarcsOption a+ (UseIndex+ -> Maybe Bool+ -> Maybe String+ -> O.WithContext+ -> O.DiffAlgorithm+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UMask+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+unrevertOpts = unrevertBasicOpts `withStdOpts` unrevertAdvancedOpts++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = []+ , S.diffAlgorithm = diffAlgorithm flags+ , S.interactive = isInteractive flags+ , S.selectDeps = O.PromptDeps -- option not supported, use default+ , S.summary = O.NoSummary -- option not supported, use default+ , S.withContext = isUnified flags+ }++unrevert :: DarcsCommand [DarcsFlag]+unrevert = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "unrevert"+ , commandHelp = unrevertHelp+ , commandDescription = unrevertDescription+ , commandExtraArgs = 0+ , commandExtraArgHelp = []+ , commandCommand = unrevertCmd+ , commandPrereq = amInHashedRepository+ , commandGetArgPossibilities = return []+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc unrevertAdvancedOpts+ , commandBasicOptions = odesc unrevertBasicOpts+ , commandDefaults = defaultFlags unrevertOpts+ , commandCheckOptions = ocheck unrevertOpts+ , commandParseOptions = onormalise unrevertOpts+ }++unrevertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+unrevertCmd _ opts [] =+ withRepoLock NoDryRun (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do+ us <- readRepo repository+ Sealed them <- unrevertPatchBundle repository+ recorded <- readRecorded repository+ unrecorded <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository Nothing+ Sealed h_them <- return $ mergeThem us them+ Sealed pw <- considerMergeToWorking repository "unrevert"+ YesAllowConflictsAndMark YesUpdateWorking+ NoExternalMerge NoWantGuiPause+ (compression opts) (verbosity opts) NoReorder+ ( UseIndex, ScanKnown, diffAlgorithm opts )+ NilFL h_them+ let context = selectionContextPrim First "unrevert" (patchSelOpts opts) Nothing Nothing (Just recorded)+ (p :> skipped) <- runSelection (selectChanges pw) context+ tentativelyAddToPending repository YesUpdateWorking p+ withSignalsBlocked $+ do finalizeRepositoryChanges repository YesUpdateWorking (compression opts)+ _ <- applyToWorking repository (verbosity opts) p `catch` \(e :: IOException) ->+ fail ("Error applying unrevert to working directory...\n"+ ++ show e)+ debugMessage "I'm about to writeUnrevert."+ writeUnrevert repository skipped recorded (unrecorded+>+p)+ debugMessage "Finished unreverting."+unrevertCmd _ _ _ = impossible++writeUnrevert :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> FL (PrimOf p) wX wY+ -> Tree IO -> FL (PrimOf p) wR wX -> IO ()+writeUnrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository+writeUnrevert repository ps recorded pend =+ case commute (pend :> ps) of+ Nothing -> do really <- askUser "You will not be able to unrevert this operation! Proceed? "+ case really of ('y':_) -> return ()+ _ -> exitSuccess+ writeUnrevert repository NilFL recorded pend+ Just (p' :> _) -> do+ rep <- readRepo repository+ date <- getIsoDateTime+ np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p')+ bundle <- makeBundleN (Just recorded) rep (np :>: NilFL)+ writeDocBinFile (unrevertUrl repository) bundle+ where fromRepoPrims :: RepoPatch p => Repository p wR wU wT -> FL (PrimOf p) wR wY -> FL p wR wY+ fromRepoPrims _ = fromPrims++unrevertPatchBundle :: RepoPatch p => Repository p wR wU wT -> IO (SealedPatchSet p Origin)+unrevertPatchBundle repository = do+ pf <- B.readFile (unrevertUrl repository)+ `catchall` fail "There's nothing to unrevert!"+ case scanBundle pf of+ Right ps -> return ps+ Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err+
+ src/Darcs/UI/Commands/Util.hs view
@@ -0,0 +1,115 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+module Darcs.UI.Commands.Util+ ( announceFiles+ , filterExistingFiles+ , testTentativeAndMaybeExit+ , getUniqueRepositoryName+ , getUniqueDPatchName+ ) where++import Control.Monad ( unless )++import System.Exit ( ExitCode(..), exitWith )++import Storage.Hashed.Monad ( virtualTreeIO, exists )+import Storage.Hashed.Tree ( Tree )+import Storage.Hashed( floatPath, readPlainTree )++import Darcs.Util.Path+ ( SubPath, toFilePath, getUniquePathName )+import Darcs.Patch ( RepoPatch )+import Darcs.Repository ( Repository, readRecorded, readUnrecorded,+ testTentative )+import Darcs.Repository.State ( applyTreeFilter, restrictBoring )+import Darcs.Repository.Flags ( LookForAdds (..) )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Bundle ( patchFilename )+import Darcs.UI.Options.All+ ( Verbosity, SetScriptsExecutable, TestChanges (..)+ , RunTest(..), LeaveTestDir(..) )+import Darcs.Util.Exception ( clarifyErrors )+import Darcs.Util.Prompt ( PromptConfig(..), promptChar )++announceFiles :: Maybe [SubPath] -> String -> IO ()+announceFiles Nothing _ = return ()+announceFiles (Just files) message = putStrLn $ message ++ " " +++ unwords (map show files) ++ ":\n"++testTentativeAndMaybeExit :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> Verbosity+ -> TestChanges+ -> SetScriptsExecutable+ -> Bool+ -> String+ -> String -> Maybe String -> IO ()+testTentativeAndMaybeExit repo verb test sse interactive failMessage confirmMsg withClarification = do+ let (rt,ltd) = case test of+ NoTestChanges -> (NoRunTest, YesLeaveTestDir)+ YesTestChanges x -> (YesRunTest, x)+ testResult <- testTentative repo rt ltd sse verb+ unless (testResult == ExitSuccess) $ do+ let doExit = maybe id (flip clarifyErrors) withClarification $+ exitWith testResult+ unless interactive doExit+ putStrLn $ "Looks like " ++ failMessage+ let prompt = "Shall I " ++ confirmMsg ++ " anyway?"+ yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])+ unless (yn == 'y') doExit++filterExistingFiles :: (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT+ -> LookForAdds+ -> [SubPath]+ -> IO [SubPath]+filterExistingFiles repo lfa files = do+ pristine <- readRecorded repo+ -- TODO this is slightly inefficient, since we should really somehow+ -- extract the unrecorded state as a side-effect of unrecordedChanges+ index <- readUnrecorded repo $ Just files+ nonboring <- restrictBoring index+ working <- applyTreeFilter nonboring `fmap` readPlainTree "."+ let paths = map toFilePath files+ check = virtualTreeIO $ mapM (exists . floatPath) paths+ (in_working, _) <- check working+ (in_pristine, _) <- check pristine+ mapM_ maybe_warn $ zip3 paths in_working in_pristine+ return [ path | (path, True) <- zip files (zipWith (||) in_working in_pristine) ]+ where maybe_warn (file, False, False) =+ putStrLn $ "WARNING: File '"++file++"' does not exist!"+ maybe_warn (file, True, False) | lfa == YesLookForAdds =+ putStrLn $ "WARNING: File '" ++ file ++ "' not in repository!"+ maybe_warn _ = return ()++getUniqueRepositoryName :: Bool -> FilePath -> IO FilePath+getUniqueRepositoryName talkative name = getUniquePathName talkative buildMsg buildName+ where+ buildName i = if i == -1 then name else name++"_"++show i+ buildMsg n = "Directory or file '"++ name +++ "' already exists, creating repository as '"+++ n ++"'"++getUniqueDPatchName :: FilePath -> IO FilePath+getUniqueDPatchName name = getUniquePathName True buildMsg buildName+ where+ buildName i = if i == -1 then patchFilename name else patchFilename $ name++"_"++show i+ buildMsg n = "Directory or file '"++ name +++ "' already exists, creating dpatch as '"+++ n ++"'"
+ src/Darcs/UI/Commands/Util/Tree.hs view
@@ -0,0 +1,74 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Util.Tree+ ( + -- * Tree lookup.+ treeHas+ , treeHasDir+ , treeHasFile+ , treeHasAnycase+ ) where++import Control.Monad ( forM )+import Control.Monad.State.Strict( gets )++import qualified Data.ByteString.Char8 as BSC+import Data.Char ( toLower )++import Storage.Hashed.Monad+ ( withDirectory, fileExists, directoryExists+ , virtualTreeMonad, currentDirectory+ , TreeMonad )+import qualified Storage.Hashed.Monad as HS ( exists, tree )+import Storage.Hashed.Tree ( Tree, listImmediate, findTree )+import Storage.Hashed ( floatPath )++import Darcs.Util.Path+ ( AnchoredPath(..), Name(..) )++treeHasAnycase :: (Functor m, Monad m)+ => Tree m+ -> FilePath+ -> m Bool+treeHasAnycase tree path =+ fst `fmap` virtualTreeMonad (existsAnycase $ floatPath path) tree+++existsAnycase :: (Functor m, Monad m)+ => AnchoredPath+ -> TreeMonad m Bool+existsAnycase (AnchoredPath []) = return True+existsAnycase (AnchoredPath (Name x:xs)) = do+ wd <- currentDirectory+ Just tree <- gets (flip findTree wd . HS.tree)+ let subs = [ AnchoredPath [Name n] | (Name n, _) <- listImmediate tree,+ BSC.map toLower n == BSC.map toLower x ]+ or `fmap` forM subs (\path -> do+ file <- fileExists path+ if file then return True+ else withDirectory path (existsAnycase $ AnchoredPath xs))+++treeHas :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool+treeHas tree path = fst `fmap` virtualTreeMonad (HS.exists $ floatPath path) tree++treeHasDir :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool+treeHasDir tree path = fst `fmap` virtualTreeMonad (directoryExists $ floatPath path) tree++treeHasFile :: (Functor m, Monad m) => Tree m -> FilePath -> m Bool+treeHasFile tree path = fst `fmap` virtualTreeMonad (fileExists $ floatPath path) tree
+ src/Darcs/UI/Commands/WhatsNew.hs view
@@ -0,0 +1,403 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+++module Darcs.UI.Commands.WhatsNew+ (+ whatsnew+ , status+ ) where++import Prelude hiding ( (^), catch )++import Control.Applicative ( (<$>) )+import Control.Monad ( void )+import Control.Monad.Reader ( runReaderT )+import Control.Monad.State ( evalStateT, liftIO )+import Storage.Hashed.Tree ( Tree )+import System.Exit ( ExitCode (..), exitSuccess, exitWith )++import Darcs.Patch+ ( PrimOf, PrimPatch, RepoPatch+ , applyToTree, plainSummaryPrims, primIsHunk+ )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Choices ( patchChoicesLps, lpPatch )+import Darcs.Patch.FileHunk ( IsHunk (..) )+import Darcs.Patch.Format ( PatchListFormat (..) )+import Darcs.Patch.Inspect ( PatchInspect (..) )+import Darcs.Patch.Patchy ( Patchy )+import Darcs.Patch.Permutations ( partitionRL )+import Darcs.Patch.Prim.Class ( PrimDetails (..) )+import Darcs.Patch.Show ( ShowPatch )+import Darcs.Patch.Split ( primSplitter )+import Darcs.Patch.TouchesFiles ( choosePreTouching )+import Darcs.Patch.Witnesses.Ordered+ ( (:>) (..), FL (..), RL (..)+ , lengthFL, reverseFL, reverseRL+ )+import Darcs.Patch.Witnesses.Sealed+ ( Sealed (..), Sealed2 (..)+ , unFreeLeft+ )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.WZipper ( FZipper (..) )+import Darcs.Repository+ ( RepoJob (..), Repository+ , listRegisteredFiles, readRecorded+ , unrecordedChangesWithPatches, withRepository+ )+import Darcs.Repository.Diff ( treeDiff )+import Darcs.Repository.Prefs ( filetypeFunction )+import Darcs.Repository.Util ( getMovesPs, getReplaces )+import Darcs.UI.Commands+ ( DarcsCommand(..), withStdOpts, amInRepository+ , commandAlias, nodefaults+ )+import Darcs.UI.Commands.Util ( announceFiles )+import Darcs.UI.Flags+ ( DarcsFlag (Summary, LookForAdds, LookForMoves), diffAlgorithm, diffingOpts+ , isUnified, useCache, fixSubPaths+ , verbosity, isInteractive, isUnified, lookForAdds, lookForMoves, lookForReplaces, hasSummary+ )+import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.PrintPatch+ ( contextualPrintPatch, printPatch+ , printPatchPager+ )+import Darcs.UI.SelectChanges+ ( InteractiveSelectionContext (..)+ , InteractiveSelectionM, KeyPress (..)+ , WhichChanges (..), backAll+ , backOne, currentFile+ , currentPatch, decide+ , decideWholeFile, helpFor+ , keysFor, prompt+ , selectionContextPrim, skipMundane+ , skipOne, printSummary+ )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath )+import Darcs.Util.Printer+ ( putDocLn, renderString, RenderMode(..)+ , text, vcat+ )+import Darcs.Util.Prompt ( PromptConfig (..), promptChar )+++whatsnewBasicOpts :: DarcsOption a+ (Maybe O.Summary+ -> O.WithContext+ -> O.LookFor+ -> O.DiffAlgorithm+ -> Maybe String+ -> Maybe Bool+ -> a)+whatsnewBasicOpts+ = O.summary+ ^ O.withContext+ ^ O.lookfor+ ^ O.diffAlgorithm+ ^ O.workingRepoDir+ ^ O.interactive -- False++whatsnewAdvancedOpts :: DarcsOption a (O.UseIndex -> Bool -> a)+whatsnewAdvancedOpts = O.useIndex ^ O.includeBoring++whatsnewOpts :: DarcsOption a+ (Maybe O.Summary+ -> O.WithContext+ -> O.LookFor+ -> O.DiffAlgorithm+ -> Maybe String+ -> Maybe Bool+ -> Maybe O.StdCmdAction+ -> Bool+ -> Bool+ -> O.Verbosity+ -> Bool+ -> O.UseIndex+ -> Bool+ -> O.UseCache+ -> Maybe String+ -> Bool+ -> Maybe String+ -> Bool+ -> a)+whatsnewOpts = whatsnewBasicOpts `withStdOpts` whatsnewAdvancedOpts++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+ { S.verbosity = verbosity flags+ , S.matchFlags = []+ , S.diffAlgorithm = diffAlgorithm flags+ , S.interactive = isInteractive flags+ , S.selectDeps = O.PromptDeps -- option not supported, use default+ , S.summary = hasSummary (defaultSummary flags) flags+ , S.withContext = isUnified flags+ }++defaultSummary :: [DarcsFlag] -> O.Summary+defaultSummary flags = if lookForAdds flags == O.YesLookForAdds then O.YesSummary else O.NoSummary++whatsnew :: DarcsCommand [DarcsFlag]+whatsnew = DarcsCommand+ { commandProgramName = "darcs"+ , commandName = "whatsnew"+ , commandHelp = whatsnewHelp+ , commandDescription = whatsnewDescription+ , commandExtraArgs = -1+ , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+ , commandCommand = whatsnewCmd+ , commandPrereq = amInRepository+ , commandGetArgPossibilities = listRegisteredFiles+ , commandArgdefaults = nodefaults+ , commandAdvancedOptions = odesc whatsnewAdvancedOpts+ , commandBasicOptions = odesc whatsnewBasicOpts+ , commandDefaults = defaultFlags whatsnewOpts+ , commandCheckOptions = ocheck whatsnewOpts+ , commandParseOptions = onormalise whatsnewOpts+ }++whatsnewDescription :: String+whatsnewDescription = "List unrecorded changes in the working tree."++whatsnewHelp :: String+whatsnewHelp =+ "The `darcs whatsnew` command lists unrecorded changes to the working\n" +++ "tree. If you specify a set of files and directories, only unrecorded\n" +++ "changes to those files and directories are listed.\n" +++ "\n" +++ "With the `--summary` option, the changes are condensed to one line per\n" +++ "file, with mnemonics to indicate the nature and extent of the change.\n" +++ "The `--look-for-adds` option causes candidates for `darcs add` to be\n" +++ "included in the summary output. Summary mnemonics are as follows:\n" +++ "\n" +++ "* `A f` and `A d/` respectively mean an added file or directory.\n" +++ "* `R f` and `R d/` respectively mean a removed file or directory.\n" +++ "* `M f -N +M rP` means a modified file, with `N` lines deleted, `M`\n" +++ " lines added, and `P` lexical replacements.\n" +++ "* `f -> g` means a moved file or directory.\n" +++ "* `a f` and `a d/` respectively mean a new, but unadded, file or\n" +++ " directory, when using `--look-for-adds`.\n" +++ "\n" +++ " An exclamation mark (!) as in `R! foo.c`, means the hunk is known to\n" +++ " conflict with a hunk in another patch. The phrase `duplicated`\n" +++ " means the hunk is known to be identical to a hunk in another patch.\n" +++ "\n" +++ "By default, `darcs whatsnew` uses Darcs' internal format for changes.\n" +++ "To see some context (unchanged lines) around each change, use the\n" +++ "`--unified` option. To view changes in conventional `diff` format, use\n" +++ "the `darcs diff` command; but note that `darcs whatsnew` is faster.\n" +++ "\n" +++ "This command exits unsuccessfully (returns a non-zero exit status) if\n" +++ "there are no unrecorded changes.\n"++whatsnewCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+whatsnewCmd fps opts args =+ withRepository (useCache opts) $ RepoJob $ \(repo :: Repository p wR wU wR) -> do+ files <- if null args+ then return Nothing+ else Just <$> fixSubPaths fps args+ let isLookForMoves = lookForMoves opts == O.YesLookForMoves && parseFlags O.summary opts /= Just O.NoSummary+ isLookForAdds = lookForAdds opts == O.YesLookForAdds && parseFlags O.summary opts /= Just O.NoSummary+ isLookForReplaces = lookForReplaces opts == O.YesLookForReplaces+ -- LookForAdds and LookForMoves implies Summary, unless it's explcitly disabled.+ optsModifier = if isLookForAdds+ then (Summary :) . filter (\o -> LookForAdds /= o &&+ LookForMoves /= o )+ else id+ opts' = optsModifier opts+ movesPs <- if isLookForMoves+ then getMovesPs repo files+ else return NilFL+ Sealed replacePs <- if isLookForReplaces+ then getReplaces (diffingOpts opts) repo files+ else return (Sealed NilFL)+ Sealed noLookChanges <- filteredUnrecordedChanges opts' repo files movesPs+ (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR)+ pristine <- readRecorded repo+ -- If we are looking for moves, return the corresponding FL of changes.+ -- If we are looking for adds, return the corresponding FL of changes.+ Sealed unaddedNewPathsPs <- if isLookForAdds+ then do+ -- Use opts not opts', here, since we *do* want to look for adds.+ Sealed lookChanges <- filteredUnrecordedChanges opts repo files movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR)+ noLookAddsTree <- applyAddPatchesToPristine noLookChanges pristine+ lookAddsTree <- applyAddPatchesToPristine lookChanges pristine+ ftf <- filetypeFunction+ -- Return the patches that create files/dirs that aren't yet added.+ unFreeLeft <$> treeDiff (diffAlgorithm opts) ftf noLookAddsTree lookAddsTree+ else return (Sealed NilFL)+ announceFiles files "What's new in"+ exitOnNoChanges (unaddedNewPathsPs, noLookChanges)+ if maybeIsInteractive opts+ then runInteractive (interactiveHunks pristine) opts' pristine noLookChanges+ else do+ printChanges opts' pristine noLookChanges+ printUnaddedPaths unaddedNewPathsPs+ where+ -- |Filter out hunk patches (leaving add patches) and return the tree+ -- resulting from applying the filtered patches to the pristine tree.+ applyAddPatchesToPristine ps pristine = do+ adds :> _ <- return $ partitionRL primIsHunk $ reverseFL ps+ applyToTree (reverseRL adds) pristine++ exitOnNoChanges :: (FL p wX wY, FL p wU wV) -> IO ()+ exitOnNoChanges (NilFL, NilFL) = do putStrLn "No changes!"+ exitWith $ ExitFailure 1+ exitOnNoChanges _ = return ()++ printUnaddedPaths :: PrimPatch p => FL p wX wY -> IO ()+ printUnaddedPaths NilFL = return ()+ printUnaddedPaths ps =+ putDocLn . lowercaseAs . renderString Encode . plainSummaryPrims $ ps++ -- Make any add markers lowercase, to distinguish new-but-unadded files+ -- from those that are unrecorded, but added.+ lowercaseAs x = vcat $ map (text . lowercaseA) $ lines x+ lowercaseA ('A' : x) = 'a' : x+ lowercaseA x = x++ -- |Appropriately print changes, according to the passed flags.+ printChanges :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p, PrimDetails p,+ ApplyState p ~ Tree) => [DarcsFlag] -> Tree IO -> FL p wX wY+ -> IO ()+ printChanges opts' pristine changes+ | Summary `elem` opts' = putDocLn $ plainSummaryPrims changes+ | isUnified opts' == O.YesContext = contextualPrintPatch pristine changes+ | otherwise = printPatch changes++ -- |return the unrecorded changes that affect an optional list of paths.+ filteredUnrecordedChanges :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree,+ ApplyState (PrimOf p) ~ Tree) => [DarcsFlag]+ -> Repository p wR wU wT -> Maybe [SubPath]+ -> FL (PrimOf p) wR wT -- look-for-moves patches+ -> FL (PrimOf p) wT wT -- look-for-replaces patches+ -> IO (Sealed (FL (PrimOf p) wT))+ filteredUnrecordedChanges opts' repo files movesPs replacesPs =+ let filePaths = map toFilePath <$> files in+ choosePreTouching filePaths <$> unrecordedChangesWithPatches (diffingOpts opts') repo files movesPs replacesPs++-- | Runs the 'InteractiveSelectionM' code+runInteractive :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p,+ PrimPatch p, PatchInspect p, PrimDetails p,+ ApplyState p ~ Tree)+ => InteractiveSelectionM p wX wY () -- Selection to run+ -> [DarcsFlag] -- Command-line options+ -> Tree IO -- Pristine+ -> FL p wX wY -- A list of patches+ -> IO ()+runInteractive i opts pristine ps' = do+ let (choices',lps') = patchChoicesLps ps'+ let ps = evalStateT i $+ ISC { total = lengthFL lps'+ , current = 0+ , lps = FZipper NilRL lps'+ , choices = choices'+ }+ void $ runReaderT ps $+ selectionContextPrim First "view" (patchSelOpts opts) (Just primSplitter)+ Nothing (Just pristine)++-- | The interactive part of @darcs whatsnew@+interactiveHunks :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p,+ PatchInspect p, PrimDetails p, ApplyState p ~ Tree)+ => Tree IO -> InteractiveSelectionM p wX wY ()+interactiveHunks pristine = do+ c <- currentPatch+ case c of+ Nothing -> liftIO $ putStrLn "No more changes!"+ Just (Sealed2 lp) -> do+ liftIO $ printPatch (lpPatch lp)+ repeatThis lp+ where+ repeatThis lp = do+ thePrompt <- prompt -- "Shall I view this change? (n/m)"+ yorn <- liftIO $ promptChar+ (PromptConfig thePrompt (keysFor basic_options) (keysFor adv_options)+ (Just 'n') "?h")+ case yorn of+ -- View hunk in context+ 'v' -> liftIO (contextualPrintPatch pristine (lpPatch lp))+ >> repeatThis lp+ -- View summary of the change+ 'x' -> liftIO (printSummary (lpPatch lp))+ >> repeatThis lp+ -- View hunk and move on+ 'y' -> liftIO (contextualPrintPatch pristine (lpPatch lp))+ >> decide True lp >> next_hunk+ -- Go to the next patch+ 'n' -> decide False lp >> next_hunk+ -- Skip the whole file+ 's' -> do+ currentFile >>= maybe+ (return ())+ (\f -> decideWholeFile f False)+ next_hunk+ -- View hunk in a pager+ 'p' -> liftIO (printPatchPager $ lpPatch lp)+ >> repeatThis lp+ -- Next hunk+ 'j' -> next_hunk+ -- Previous hunk+ 'k' -> prev_hunk+ -- Start from the first change+ 'g' -> start_over+ -- Quit whatsnew+ 'q' -> liftIO $ exitSuccess+ _ -> do liftIO . putStrLn $+ helpFor "whatsnew" basic_options adv_options+ repeatThis lp+ start_over = backAll >> interactiveHunks pristine+ next_hunk = skipOne >> skipMundane >> interactiveHunks pristine+ prev_hunk = backOne >> interactiveHunks pristine+ options_yn =+ [ KeyPress 'v' "view this hunk in a context"+ , KeyPress 'y'+ "view this hunk in a context and go to the next one"+ , KeyPress 'n' "go to the next hunk" ]+ optionsView =+ [ KeyPress 'p' "view this hunk in context wih pager "+ , KeyPress 'x' "view a summary of this patch"+ ]+ optionsNav =+ [ KeyPress 'q' "quit whatsnew"+ , KeyPress 's' "skip the rest of the changes to this file"+ , KeyPress 'j' "skip to the next hunk"+ , KeyPress 'k' "back up to previous hunk"+ , KeyPress 'g' "start over from the first hunk"+ ]+ basic_options = [ options_yn ]+ adv_options = [ optionsView, optionsNav ]++-- |status is an alias for whatsnew, with implicit Summary and LookForAdds+-- flags. We override the default description, to include the implicit flags.+status :: DarcsCommand [DarcsFlag]+status = statusAlias { commandCommand = statusCmd+ , commandDescription = statusDesc+ }+ where+ statusAlias = commandAlias "status" Nothing whatsnew+ statusCmd fps fs = commandCommand whatsnew fps (Summary : LookForAdds : fs)+ statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '."++maybeIsInteractive :: [DarcsFlag] -> Bool+maybeIsInteractive = maybe False id . parseFlags O.interactive
+ src/Darcs/UI/CommandsAux.hs view
@@ -0,0 +1,78 @@+-- Copyright (C) 2006 Tommy Pettersson <ptp@lysator.liu.se>+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+++module Darcs.UI.CommandsAux+ ( checkPaths+ , maliciousPatches+ , hasMaliciousPath+ ) where++import Control.Monad ( when )++import Darcs.UI.Flags ( DarcsFlag )+import Darcs.UI.Options ( parseFlags )+import Darcs.UI.Options.All ( restrictPaths )+import Darcs.Patch.Inspect ( PatchInspect, listTouchedFiles )+import Darcs.Patch.Witnesses.Ordered ( FL, mapFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2 )+import Darcs.Util.Path ( isMaliciousPath )++-- * File paths+{-+ Darcs will operate on files and directories with the invoking user's+ privileges. The paths for these files and directories are stored in+ patches, which darcs receives in various ways. Even though darcs will not+ create patches with "unexpected" file paths, there are no such guarantees+ for received patches. A spoofed patch could inflict changes on any file+ or directory which the invoking user is privileged to modify.++ There is no one single "apply" function that can check paths, so each+ command is responsible for not applying patches without first checking+ them with one of these function when appropriate.+-}++{- |+ A convenience function to call from all darcs command functions before+ applying any patches. It checks for malicious paths in patches, and+ prints an error message and fails if it finds one.+-}+checkPaths :: PatchInspect p => [DarcsFlag] -> FL p wX wY -> IO ()+checkPaths opts patches+ = when (parseFlags restrictPaths opts && or (mapFL hasMaliciousPath patches)) $+ fail $ unlines $ ["Malicious path in patch:"] +++ map (" " ++) (concat $ mapFL maliciousPaths patches) +++ ["", "If you are sure this is ok then you can run again with the --dont-restrict-paths option."]+ -- TODO: print patch(es)+ -- NOTE: should use safe Doc printer, this can be evil chars++-- | Filter out patches that contains some malicious file path+maliciousPatches :: PatchInspect p => [Sealed2 p] -> [Sealed2 p]+maliciousPatches = filter (unseal2 hasMaliciousPath)++hasMaliciousPath :: PatchInspect p => p wX wY -> Bool+hasMaliciousPath patch =+ case maliciousPaths patch of+ [] -> False+ _ -> True++maliciousPaths :: PatchInspect p => p wX wY -> [String]+maliciousPaths patch =+ let paths = listTouchedFiles patch in+ filter isMaliciousPath paths
+ src/Darcs/UI/Defaults.hs view
@@ -0,0 +1,232 @@+module Darcs.UI.Defaults ( applyDefaults ) where++import Data.Char ( isSpace )+import Data.Functor.Compose ( Compose(..) )+import Data.List ( nub )+import Data.Maybe ( catMaybes )+import qualified Data.Map as M+import System.Console.GetOpt+import System.IO ( stderr, hPutStrLn )+import System.Exit ( exitFailure )+import Text.Regex.Applicative+ ( (<$>), (<*>), (*>), (<|>)+ , match, pure, many, some+ , psym, anySym, string )++import Darcs.UI.Flags ( DarcsFlag )+import Darcs.UI.Options ( DarcsOptDescr )++import Darcs.UI.Commands+ ( DarcsCommand(..), commandAlloptions, extractAllCommands+ , WrappedCommand(..)+ )+import Darcs.UI.TheCommands ( commandControlList )+import Darcs.Repository.Prefs ( getGlobal, getPreflist )+import Darcs.Util.Path+ ( AbsolutePath+ , getCurrentDirectory )++-- | Apply defaults from all sources to a list of 'DarcsFlag's (e.g. from the+-- command line), given the command (and possibly super command) name, and a+-- list of all options for the command.+-- +-- Sources for defaults are+-- +-- * the builtin (hard-coded) defaults,+-- +-- * the defaults file in the user's configuration, and+-- +-- * the defaults file in the current repository.+-- +-- Note that the pseudo command @ALL@ is allowed in defaults files to specify+-- that an option should be the default for all commands to which it applies.+-- +-- The order of precedence for conflicting options (i.e. those belonging to+-- same group of mutually exclusive options) is from less specific to more+-- specific. In other words, options from the command line override all+-- defaults, per-repo defaults override per-user defaults, which in turn+-- override the built-in defaults. Inside the options from a defaults file,+-- options for the given command override options for the @ALL@ pseudo command.+-- +-- Conflicting options at the same level of precedence are not allowed. If+-- encountered, the program halts with an appropriate error message.+applyDefaults :: Maybe String+ -> DarcsCommand pf+ -> [DarcsFlag]+ -> IO [DarcsFlag]+applyDefaults msuper cmd flags = do+ cwd <- getCurrentDirectory -- so we can build default flags with path arguments+ let cmd_name = mkCmdName msuper (commandName cmd)+ builtin_defs = commandDefaults cmd+ check_opts = commandCheckOptions cmd+ opts = uncurry (++) $ commandAlloptions cmd+ get_flags source = handleEither . parseDefaults source cwd cmd_name opts check_opts+ handleEither (Left err) = hPutStrLn stderr err >> exitFailure+ handleEither (Right x) = return x+ cl_flags <- handleEither $ checkConflictingOptions "command line" check_opts flags+ user_defs <- getGlobal "defaults" >>= get_flags "user defaults"+ repo_defs <- getPreflist "defaults" >>= get_flags "repo defaults"+ return $ cl_flags ++ repo_defs ++ user_defs ++ builtin_defs++-- | Name of a normal command, or name of super and sub command.+data CmdName = NormalCmd String | SuperCmd String String++-- | Make a 'CmdName' from a possible super command name and a sub command name.+mkCmdName :: Maybe String -> String -> CmdName+mkCmdName Nothing cmd = NormalCmd cmd+mkCmdName (Just super) sub = SuperCmd super sub++-- | Turn a 'CmdName' into a 'String'. For a 'SuperCmd' concatenate with a space in between.+showCmdName :: CmdName -> String+showCmdName (SuperCmd super sub) = unwords [super,sub]+showCmdName (NormalCmd name) = name++checkConflictingOptions :: String -> ([DarcsFlag] -> [String]) -> [DarcsFlag] -> Either String [DarcsFlag]+checkConflictingOptions source check fs = case check fs of+ [] -> Right fs+ es -> Left $ unlines (source:es)++-- | Parse a list of lines from a defaults file, returning a list of 'DarcsFlag',+-- given the current working directory, the command name, and a list of 'DarcsOption'+-- for the command.+--+-- In the result, defaults for the given command come first, then come defaults+-- for @ALL@ commands.+--+-- We check that matching options actually exist.+--+-- * lines matching the command name: the option must exist in the command's+-- option map.+--+-- * lines matching @ALL@: there must be at least *some* darcs command with+-- that option.+--+-- It is debatable whether these checks are useful. On the one hand they can help+-- detect typos in defaults files. On the other hand they make it difficult to+-- use different versions of darcs in parallel: a default for an option that is+-- only available in a later version will make the earlier version produce an+-- error. Maybe reduce this to a warning?+parseDefaults :: String+ -> AbsolutePath+ -> CmdName+ -> [DarcsOptDescr DarcsFlag]+ -> ([DarcsFlag] -> [String])+ -> [String]+ -> Either String [DarcsFlag]+parseDefaults source cwd cmd opts check_opts def_lines = do -- Monad (Either String)+ cmd_flags <- flags_for (M.keys opt_map) cmd_defs >>=+ checkConflictingOptions (source++" for command '"++showCmdName cmd++"'") check_opts+ all_flags <- flags_for allOptionSwitches all_defs >>=+ checkConflictingOptions (source++" for ALL commands") check_opts+ return $ cmd_flags ++ all_flags+ where+ opt_map = optionMap opts+ cmd_defs = parseDefaultsLines cmd def_lines+ all_defs = parseDefaultsLines (NormalCmd "ALL") def_lines+ to_flag all_switches (switch,arg) =+ if switch `notElem` all_switches then+ Left $ "Bad default option in "++source++": command '"++showCmdName cmd+ ++"' has no option '"++switch++"'."+ else+ defaultToFlag cwd opt_map (switch,arg)+ -- the catMaybes filters out options that are not defined+ -- for this command+ flags_for all_switches = fmap catMaybes . mapM (to_flag all_switches)++-- | Result of parsing a defaults line: switch and argument(s).+type Default = (String, String)++-- | Extract 'Default's from lines of a defaults file that match the given 'CmdName'.+-- +-- The syntax is+--+-- @+-- supercmd subcmd [--]switch [args...]+-- @+--+-- for (super) commands with a sub command, and+--+-- @+-- cmd default [--]default [args...]+-- @+--+-- for normal commands (including the @ALL@ pseudo command).+parseDefaultsLines :: CmdName -> [String] -> [Default]+parseDefaultsLines cmd = catMaybes . map matchLine+ where+ matchLine = match $ (,) <$> (match_cmd cmd *> spaces *> opt_dashes *> word) <*> rest+ match_cmd (NormalCmd name) = string name+ match_cmd (SuperCmd super sub) = string super *> spaces *> string sub+ opt_dashes = string "--" <|> pure ""+ word = some $ psym (not.isSpace)+ spaces = some $ psym isSpace+ rest = spaces *> many anySym <|> pure ""++{- $note+This definition is a bit simpler, and doesn't need Text.Regex.Applicative,+but it has two disadvantages over the one above:++ * Flag arguments are split and joined again with words/unwords, which means+ that whitespace inside an argument is not preserved literally.++ * It is less easily extendable with new syntax.++> parseDefaultsLines :: CmdName -> [String] -> [(String, String)]+> parseDefaultsLines name entries = case name of+> SuperCmd super sub -> [ mk_def d as | (s:c:d:as) <- map words entries, s == super, c == sub ]+> NormalCmd cmd -> [ mk_def d as | (c:d:as) <- map words entries, c == cmd ]+> where+> mk_def d as = (drop_dashes d, unwords as)+> drop_dashes ('-':'-':switch) = switch+> drop_dashes switch = switch+-}++-- | Search an option list for a switch. If found, apply the flag constructor+-- from the option to the arg, if any. The first parameter is the current working+-- directory, which, depending on the option type, may be needed to create a flag+-- from an argument.+-- +-- Fails if (default has argument /= corresponding option has argument).+defaultToFlag :: AbsolutePath+ -> OptionMap+ -> Default+ -> Either String (Maybe DarcsFlag)+defaultToFlag cwd opts (switch, arg) = case M.lookup switch opts of+ -- This case is not impossible! A default flag defined for ALL commands+ -- is not necessarily defined for the concrete command in question.+ Nothing -> Right Nothing+ Just opt -> fmap Just $ flag_from $ getArgDescr $ getCompose opt+ where+ getArgDescr (Option _ _ a _) = a+ flag_from (NoArg mkFlag) =+ if null arg then+ Right $ mkFlag cwd+ else+ Left $ "Bad default option: '"++switch++"' takes no argument, but '"++arg++"' argument given."+ flag_from (OptArg mkFlag _) =+ Right $ mkFlag (if null arg then Nothing else Just arg) cwd+ flag_from (ReqArg mkFlag _) =+ if null arg then+ Left $ "Bad default option: '"++switch++"' requires an argument, but no "++"argument given."+ else+ Right $ mkFlag arg cwd++-- | Get all the longSwitches from a list of options.+optionSwitches :: [DarcsOptDescr DarcsFlag] -> [String]+optionSwitches = concatMap sel where+ sel (Compose (Option _ switches _ _)) = switches++-- | A finite map from long switches to 'DarcsAtomicOption's.+type OptionMap = M.Map String (DarcsOptDescr DarcsFlag)++-- | Build an 'OptionMap' from a list of 'DarcsOption's.+optionMap :: [DarcsOptDescr DarcsFlag] -> OptionMap+optionMap = M.fromList . concatMap sel where+ add_option opt switch = (switch, opt)+ sel o@(Compose (Option _ switches _ _)) = map (add_option o) switches++-- | List of option switches of all commands (except help but that has no options).+allOptionSwitches :: [String]+allOptionSwitches = nub $ optionSwitches $+ concatMap (\(WrappedCommand c) -> uncurry (++) . commandAlloptions $ c) $+ extractAllCommands commandControlList
+ src/Darcs/UI/Email.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE CPP #-}+module Darcs.UI.Email+ ( makeEmail+ , readEmail+ , formatHeader+ ) where++import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper )+import Data.List ( isInfixOf )+import Darcs.Util.Printer+ ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS+ , RenderMode(..)+ )++import Darcs.Util.ByteString ( packStringToUTF8, dropSpace, linesPS, betweenLinesPS )+import qualified Data.ByteString as B (ByteString, length, null, tail+ ,drop, head, concat, singleton+ ,pack, append, empty, unpack+ )+import qualified Data.ByteString.Char8 as BC (index, head, pack)+import Data.ByteString.Internal as B (c2w, createAndTrim)+import System.IO.Unsafe ( unsafePerformIO )+import Foreign.Ptr ( Ptr, plusPtr )+import Foreign.Storable ( poke )+import Data.Word ( Word8 )+import Data.Maybe ( fromMaybe )++-- lineMax is maximum number of characters in an e-mail line excluding the CRLF+-- at the end. qlineMax is the number of characters in a q-encoded or+-- quoted-printable-encoded line.+lineMax, qlineMax :: Int+lineMax = 78+qlineMax = 75++-- | Formats an e-mail header by encoding any non-ascii characters using UTF-8+-- and Q-encoding, and folding lines at appropriate points. It doesn't do+-- more than that, so the header name and header value should be+-- well-formatted give or take line length and encoding. So no non-ASCII+-- characters within quoted-string, quoted-pair, or atom; no semantically+-- meaningful signs in names; no non-ASCII characters in the header name;+-- etcetera.+formatHeader :: String -> String -> B.ByteString+formatHeader headerName headerValue =+ B.append nameColon encodedValue+ where nameColon = B.pack (map B.c2w (headerName ++ ":")) -- space for folding+ encodedValue = foldAndEncode (' ':headerValue)+ (B.length nameColon) False False++-- run through a string and encode non-ascii words and fold where appropriate.+-- the integer argument is the current position in the current line.+-- the string in the first argument must begin with whitespace, or be empty.+foldAndEncode :: String -> Int -> Bool -> Bool -> B.ByteString+foldAndEncode [] _ _ _ = B.empty+foldAndEncode s p lastWordEncoded inMidWord =+ let newline = B.singleton 10+ space = B.singleton 32+ s2bs = B.pack . map B.c2w+ -- the twelve there is the max number of ASCII chars to encode a single+ -- character: 4 * 3, 4 UTF-8 bytes times 3 ASCII chars per byte+ safeEncChunkLength = (qlineMax - B.length encodedWordStart+ - B.length encodedWordEnd) `div` 12+ (curSpace, afterCurSpace) = span (== ' ') s+ (curWord, afterCurWord) = break (== ' ') afterCurSpace+ qEncWord | lastWordEncoded = qEncode (curSpace ++ curWord)+ | otherwise = qEncode curWord+ mustEncode = inMidWord+ || any (\c -> not (isPrint c) || ord c > 127) curWord+ || length curWord > lineMax - 1+ || isInfixOf "=?" curWord+ mustFold+ | mustEncode && lastWordEncoded+ = p + 1 + B.length qEncWord > lineMax+ | mustEncode+ = p + length curSpace + B.length qEncWord > lineMax+ | otherwise+ = p + length curSpace + length curWord > lineMax+ mustSplit = (B.length qEncWord > qlineMax && mustEncode)+ || length curWord > lineMax - 1+ spaceToInsert | mustEncode && lastWordEncoded = space+ | otherwise = s2bs curSpace+ wordToInsert+ | mustEncode && mustSplit = qEncode (take safeEncChunkLength curWord)+ | mustEncode = qEncWord+ | otherwise = s2bs curWord+ doneChunk | mustFold = B.concat [newline, spaceToInsert, wordToInsert]+ | otherwise = B.concat [spaceToInsert, wordToInsert]+ (rest, nextP)+ | mustSplit+ = (drop safeEncChunkLength curWord ++ afterCurWord, qlineMax + 1)+ | mustEncode && mustFold+ = (afterCurWord, B.length spaceToInsert + B.length wordToInsert)+ | otherwise+ = (afterCurWord, p + B.length doneChunk)+ in B.append doneChunk (foldAndEncode rest nextP mustEncode mustSplit)++-- | Turns a piece of string into a q-encoded block+-- Applies q-encoding, for use in e-mail header values, as defined in RFC 2047.+-- It just takes a string and builds an encoded-word from it, it does not check+-- length or necessity.+qEncode :: String -> B.ByteString+qEncode s = B.concat [encodedWordStart,+ encodedString,+ encodedWordEnd]+ where encodedString = B.concat (map qEncodeChar s)++encodedWordStart, encodedWordEnd :: B.ByteString+encodedWordStart = B.pack (map B.c2w "=?UTF-8?Q?")+encodedWordEnd = B.pack (map B.c2w "?=")++-- turns a character into its q-encoded bytestring value. For most printable+-- ASCII characters, that's just the singleton bytestring with that char.+qEncodeChar :: Char -> B.ByteString+qEncodeChar c+ | c == ' ' = c2bs '_'+ | isPrint c+ && c `notElem` "?=_"+ && ord c < 128 = c2bs c+ | otherwise = B.concat+ (map qbyte+ (B.unpack+ (packStringToUTF8 [c])))+ where c2bs = B.singleton . B.c2w+ -- qbyte turns a byte into its q-encoded "=hh" representation+ qbyte b = B.pack (map B.c2w ['='+ ,word8ToUDigit (b `div` 16)+ ,word8ToUDigit (b `mod` 16)+ ])+ word8ToUDigit :: Word8 -> Char+ word8ToUDigit = toUpper . intToDigit . fromIntegral++-- TODO is this doing mime encoding??+qpencode :: B.ByteString -> B.ByteString+qpencode s = unsafePerformIO+ -- Really only (3 + 2/75) * length or something in the worst case+ $ B.createAndTrim (4 * B.length s) (\buf -> encode s qlineMax buf 0)++encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int+encode ps _ _ bufi | B.null ps = return bufi+encode ps n buf bufi = case B.head ps of+ c | c == newline ->+ do poke (buf `plusPtr` bufi) newline+ encode ps' qlineMax buf (bufi+1)+ | n == 0 && B.length ps > 1 ->+ do poke (buf `plusPtr` bufi) equals+ poke (buf `plusPtr` (bufi+1)) newline+ encode ps qlineMax buf (bufi + 2)+ | c == tab || c == space ->+ if B.null ps' || B.head ps' == newline+ then do poke (buf `plusPtr` bufi) c+ poke (buf `plusPtr` (bufi+1)) equals+ poke (buf `plusPtr` (bufi+2)) newline+ encode ps' qlineMax buf (bufi + 3)+ else do poke (buf `plusPtr` bufi) c+ encode ps' (n - 1) buf (bufi + 1)+ | c >= bang && c /= equals && c /= period && c <= tilde ->+ do poke (buf `plusPtr` bufi) c+ encode ps' (n - 1) buf (bufi + 1)+ | n < 3 ->+ encode ps 0 buf bufi+ | otherwise ->+ do let (x, y) = c `divMod` 16+ h1 = intToUDigit x+ h2 = intToUDigit y+ poke (buf `plusPtr` bufi) equals+ poke (buf `plusPtr` (bufi+1)) h1+ poke (buf `plusPtr` (bufi+2)) h2+ encode ps' (n - 3) buf (bufi + 3)+ where ps' = B.tail ps+ newline = B.c2w '\n'+ tab = B.c2w '\t'+ space = B.c2w ' '+ bang = B.c2w '!'+ tilde = B.c2w '~'+ equals = B.c2w '='+ period = B.c2w '.'+ intToUDigit i+ | i >= 0 && i <= 9 = B.c2w '0' + i+ | i >= 10 && i <= 15 = B.c2w 'A' + i - 10+ | otherwise = error $ "intToUDigit: '"++show i++"'not a digit"++qpdecode :: B.ByteString -> B.ByteString+qpdecode s = unsafePerformIO+ -- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n"+ $ B.createAndTrim (B.length s + 1) (\buf -> decode (linesPS s) buf 0)++decode :: [B.ByteString] -> Ptr Word8 -> Int -> IO Int+decode [] _ bufi = return bufi+decode (ps:pss) buf bufi+ | B.null (dropSpace ps)+ = do poke (buf `plusPtr` bufi) newline+ decode pss buf (bufi+1)+ | is_equals && B.length ps >= 3 && isHexDigit c1 && isHexDigit c2+ = do poke (buf `plusPtr` bufi)+ (toWord8 $ digitToInt c1 * 16 + digitToInt c2)+ decode (B.drop 3 ps:pss) buf (bufi+1)+ | is_equals && B.null (dropSpace (B.tail ps)) = decode pss buf bufi+ | otherwise = do poke (buf `plusPtr` bufi) (B.head ps)+ decode (B.tail ps:pss) buf (bufi+1)+ where is_equals = BC.head ps == '='+ c1 = BC.index ps 1+ c2 = BC.index ps 2+ newline = B.c2w '\n'+ toWord8 :: Int -> Word8+ toWord8 = fromIntegral++makeEmail :: String -> [(String, String)] -> Maybe Doc -> Maybe String -> Doc -> Maybe String -> Doc+makeEmail repodir headers mcontents mcharset bundle mfilename =+ text "DarcsURL:" <+> text repodir+ $$ foldl (\m (h,v) -> m $$ (text (h ++ ":") <+> text v)) empty headers+ $$ text "MIME-Version: 1.0"+ $$ text "Content-Type: multipart/mixed; boundary=\"=_\""+ $$ text ""+ $$ text "--=_"+ $$ (case mcontents of+ Just contents ->+ text ("Content-Type: text/plain; charset=\"" +++ fromMaybe "x-unknown" mcharset ++ "\"")+ $$ text "Content-Transfer-Encoding: quoted-printable"+ $$ text ""+ $$ packedString (qpencode (renderPS Standard contents))+ $$ text ""+ $$ text "--=_"+ Nothing -> empty)+ $$ text "Content-Type: text/x-darcs-patch; name=\"patch-preview.txt\""+ $$ text "Content-Disposition: inline"+ $$ text "Content-Transfer-Encoding: quoted-printable"+ $$ text "Content-Description: Patch preview"+ $$ text ""+ $$ (case betweenLinesPS (BC.pack "New patches:") (BC.pack "Context:") (renderPS Standard bundle) of+ Just s -> packedString $ qpencode s+ -- this should not happen, but in case it does, keep everything+ Nothing -> packedString $ qpencode $ renderPS Standard bundle)+ $$ text "--=_"+ $$ text "Content-Type: application/x-darcs-patch" <>+ (case mfilename of+ Just filename -> text "; name=\"" <> text filename <> text "\""+ Nothing -> empty)+ $$ text "Content-Transfer-Encoding: quoted-printable"+ $$ text "Content-Disposition: attachment"+ $$ text "Content-Description: A darcs patch for your repository!"+ $$ text ""+ $$ packedString (qpencode (renderPS Standard bundle))+ $$ text "--=_--"+ $$ text ""+ $$ text "."+ $$ text ""+ $$ text ""++readEmail :: B.ByteString -> B.ByteString+readEmail s =+ case betweenLinesPS+ (BC.pack "Content-Description: A darcs patch for your repository!")+ (BC.pack "--=_--") s of+ Nothing -> s -- if it wasn't an email in the first place, just pass along.+ Just s' -> qpdecode s'+
+ src/Darcs/UI/External.hs view
@@ -0,0 +1,615 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Darcs.UI.External+ ( sendEmail+ , generateEmail+ , sendEmailDoc+ , resendEmail+ , signString+ , verifyPS+ , execDocPipe+ , execPipeIgnoreError+ , pipeDoc+ , pipeDocSSH+ , maybeURLCmd+ , viewDoc+ , viewDocWith+ , haveSendmail+ , sendmailPath+ , diffProgram+ , darcsProgram+ , editText+ , editFile+ , catchall+ -- * Locales+ , setDarcsEncodings+ , getSystemEncoding+ , isUTF8Locale+ ) where++import Prelude hiding ( catch )++import Data.Maybe ( isJust, isNothing, maybeToList )+import Control.Monad ( unless, when, filterM, liftM2, void )+import GHC.MVar ( MVar )+import System.Exit ( ExitCode(..) )+import System.Environment+ ( getEnv+#if __GLASGOW_HASKELL__ >= 706+ , getExecutablePath+#else+ , getProgName+#endif+ )+import System.IO ( hPutStr, hPutStrLn, hClose,+ hIsTerminalDevice, stdout, stderr, Handle )+import System.Directory ( doesFileExist,+ findExecutable )+import System.FilePath.Posix ( (</>) )+import System.Process ( createProcess, proc, CreateProcess(..), runInteractiveProcess, waitForProcess, StdStream(..) )+import System.Process.Internals ( ProcessHandle )++import GHC.IO.Encoding ( setFileSystemEncoding, setForeignEncoding, char8 )++import Foreign.C.String ( CString, peekCString )++import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )+import Control.Exception+ ( try, finally, catch, IOException )+import System.IO.Error ( ioeGetErrorType )+import GHC.IO.Exception ( IOErrorType(ResourceVanished) )+import Data.Char ( toUpper, toLower )+import Text.Regex+#if defined (HAVE_MAPI)+import Foreign.C ( withCString )+#endif+#ifdef HAVE_MAPI+import Foreign.Ptr ( nullPtr )+import Darcs.Repository.Lock ( canonFilename, writeDocBinFile )+#endif++import Darcs.Util.SignalHandler ( catchNonSignal )+import Darcs.UI.Options.All ( Sign(..), Verify(..), Compression(..) )+import Darcs.Util.Path+ ( AbsolutePath+ , toFilePath+ , FilePathLike+ )+import Darcs.Util.Progress ( withoutProgress, debugMessage )++import Darcs.Util.ByteString (linesPS, unlinesPS)+import qualified Data.ByteString as B (ByteString, empty, null, readFile+ ,hGetContents, writeFile, hPut, length+ ,take, concat, drop, isPrefixOf, singleton, append)+import qualified Data.ByteString.Char8 as BC (unpack, pack)++import Darcs.Repository.Lock+ ( withTemp+ , withNamedTemp+ , withOpenTemp+ )+import Darcs.Repository.Ssh ( getSSH, SSHCmd(..) )+import Darcs.Util.CommandLine ( parseCmd, addUrlencoded )+import Darcs.Util.Exec ( execInteractive, exec, Redirect(..), withoutNonBlock )+import Darcs.Util.URL ( SshFilePath, sshUhost )+import Darcs.Util.Printer ( Doc, Printers, hPutDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS,+ simplePrinters,+ hPutDocCompr,+ text, empty, packedString, vcat, renderString, RenderMode(..) )+import qualified Darcs.Util.Ratified as Ratified+import Darcs.UI.Email ( formatHeader )++sendmailPath :: IO String+sendmailPath = do+ l <- filterM doesFileExist $ liftM2 (</>)+ [ "/usr/sbin", "/sbin", "/usr/lib" ]+ [ "sendmail" ]+ ex <- findExecutable "sendmail"+ when (isNothing ex && null l) $ fail "Cannot find the \"sendmail\" program."+ return $ head $ maybeToList ex ++ l++diffProgram :: IO String+diffProgram = do+ l <- filterM (fmap isJust . findExecutable) [ "gdiff", "gnudiff", "diff" ]+ when (null l) $ fail "Cannot find the \"diff\" program."+ return $ head l++-- |Get the name of the darcs executable (as supplied by @getExecutablePath@)+darcsProgram :: IO String+#if __GLASGOW_HASKELL__ >= 706+darcsProgram = getExecutablePath+#else+darcsProgram = getProgName+#endif++maybeURLCmd :: String -> String -> IO (Maybe String)+maybeURLCmd what url =+ do let prot = map toUpper $ takeWhile (/= ':') url+ fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot))+ `catch` \(_ :: IOException) -> return Nothing++pipeDoc :: RenderMode -> String -> [String] -> Doc -> IO ExitCode+pipeDoc = pipeDocInternal (PipeToOther simplePrinters)++data WhereToPipe = PipeToSsh Compression -- ^ if pipe to ssh, can choose to compress or not+ | PipeToOther Printers -- ^ otherwise, can specify printers++pipeDocInternal :: WhereToPipe -> RenderMode -> String -> [String] -> Doc -> IO ExitCode+pipeDocInternal whereToPipe target c args inp = withoutNonBlock $ withoutProgress $+ do debugMessage $ unwords (c:args)+ (Just i,_,_,pid) <- createProcess (proc c args){ std_in = CreatePipe+ {- , delegate_ctlc = True -- requires process 1.2.2.0 -} }+ debugMessage "Start transferring data"+ case whereToPipe of+ PipeToSsh GzipCompression -> hPutDocCompr target i inp+ PipeToSsh NoCompression -> hPutDoc target i inp+ PipeToOther printers -> hPutDocWith printers target i inp+ hClose i+ rval <- waitForProcess pid+ debugMessage "Finished transferring data"+ when (rval == ExitFailure 127) $+ putStrLn $ "Command not found:\n "++ show (c:args)+ return rval++pipeDocSSH :: Compression -> RenderMode -> SshFilePath -> [String] -> Doc -> IO ExitCode+pipeDocSSH compress target remoteAddr args input = do+ (ssh, ssh_args) <- getSSH SSH+ pipeDocInternal (PipeToSsh compress) target ssh (ssh_args++ (sshUhost remoteAddr:args)) input++sendEmail :: String -> String -> String -> String -> String -> String -> IO ()+sendEmail f t s cc scmd body =+ sendEmailDoc f t s cc scmd Nothing (text body)+++generateEmail+ :: Handle -- ^ handle to write email to+ -> String -- ^ From+ -> String -- ^ To+ -> String -- ^ Subject+ -> String -- ^ CC+ -> Doc -- ^ body+ -> IO ()+generateEmail h f t s cc body = do+ putHeader "To" t+ putHeader "From" f+ putHeader "Subject" s+ unless (null cc) $ putHeader "Cc" cc+ putHeader "X-Mail-Originator" "Darcs Version Control System"+ hPutDocLn Standard h body+ where putHeader field value+ = B.hPut h (B.append (formatHeader field value) newline)+ newline = B.singleton 10++haveSendmail :: IO Bool+haveSendmail = (sendmailPath >> return True) `catch` (\(_ :: IOException) -> return False)++-- | Send an email, optionally containing a patch bundle+-- (more precisely, its description and the bundle itself)+sendEmailDoc+ :: String -- ^ from+ -> String -- ^ to+ -> String -- ^ subject+ -> String -- ^ cc+ -> String -- ^ send command+ -> Maybe (Doc, Doc) -- ^ (content,bundle)+ -> Doc -- ^ body+ -> IO ()+sendEmailDoc _ "" _ "" _ _ _ = return ()+sendEmailDoc f "" s cc scmd mbundle body =+ sendEmailDoc f cc s "" scmd mbundle body+sendEmailDoc f t s cc scmd mbundle body = do+ use_sendmail <- haveSendmail+ if use_sendmail || scmd /= "" then+ withOpenTemp $ \(h,fn) -> do+ generateEmail h f t s cc body+ hClose h+ withOpenTemp $ \(hat,at) -> do+ ftable' <- case mbundle of+ Just (content,bundle) -> do+ hPutDocLn Standard hat bundle+ return [ ('b', renderString Standard content) , ('a', at) ]+ Nothing ->+ return [ ('b', renderString Standard body) ]+ hClose hat+ let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable'+ r <- execSendmail ftable scmd fn+ when (r /= ExitSuccess) $ fail ("failed to send mail to: "+ ++ t ++ cc_list cc+ ++ "\nPerhaps sendmail is not configured.")+#ifdef HAVE_MAPI+ else do+ r <- withCString t $ \tp ->+ withCString f $ \fp ->+ withCString cc $ \ccp ->+ withCString s $ \sp ->+ withOpenTemp $ \(h,fn) -> do+ hPutDoc Standard h body+ hClose h+ writeDocBinFile "mailed_patch" body+ cfn <- canonFilename fn+ withCString cfn $ \pcfn ->+ c_send_email fp tp ccp sp nullPtr pcfn+ when (r /= 0) $ fail ("failed to send mail to: " ++ t)+#else+ else fail "no mail facility (sendmail or mapi) located at configure time!"+#endif+ where addressOnly a =+ case dropWhile (/= '<') a of+ ('<':a2) -> takeWhile (/= '>') a2+ _ -> a++ cc_list [] = []+ cc_list c = " and cc'ed " ++ c++resendEmail :: String -> String -> B.ByteString -> IO ()+resendEmail "" _ _ = return ()+resendEmail t scmd body = do+ use_sendmail <- haveSendmail+ if use_sendmail || scmd /= ""+ then+ withOpenTemp $ \(h,fn) -> do+ hPutStrLn h $ "To: "++ t+ hPutStrLn h $ find_from (linesPS body)+ hPutStrLn h $ find_subject (linesPS body)+ hPutDocLn Standard h $ fixit $ linesPS body+ hClose h+ let ftable = [('t',t)]+ r <- execSendmail ftable scmd fn+ when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t)+ else+#ifdef HAVE_MAPI+ fail "Don't know how to resend email with MAPI"+#else+ fail "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!"+#endif+ where br = BC.pack "\r"+ darcsurl = BC.pack "DarcsURL:"+ content = BC.pack "Content-"+ from_start = BC.pack "From:"+ subject_start = BC.pack "Subject:"+ fixit (l:ls)+ | B.null l = packedString B.empty $$ vcat (map packedString ls)+ | l == br = packedString B.empty $$ vcat (map packedString ls)+ | B.take 9 l == darcsurl || B.take 8 l == content+ = packedString l $$ fixit ls+ | otherwise = fixit ls+ fixit [] = empty+ find_from (l:ls) | B.take 5 l == from_start = BC.unpack l+ | otherwise = find_from ls+ find_from [] = "From: unknown"+ find_subject (l:ls) | B.take 8 l == subject_start = BC.unpack l+ | otherwise = find_subject ls+ find_subject [] = "Subject: (no subject)"++execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode+execSendmail ftable scmd fn =+ if scmd == "" then do+ cmd <- sendmailPath+ exec cmd ["-i", "-t"] (File fn, Null, AsIs)+ else case parseCmd (addUrlencoded ftable) scmd of+ Right (arg0:opts, wantstdin) ->+ do let stdin = if wantstdin then File fn else Null+ exec arg0 opts (stdin, Null, AsIs)+ Left e -> fail $ "failed to send mail, invalid sendmail-command: "++show e+ _ -> fail "failed to send mail, invalid sendmail-command"++#ifdef HAVE_MAPI+foreign import ccall "win32/send_email.h send_email" c_send_email+ :: CString -> {- sender -}+ CString -> {- recipient -}+ CString -> {- cc -}+ CString -> {- subject -}+ CString -> {- body -}+ CString -> {- path -}+ IO Int+#endif++execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString+execPSPipe c args ps = fmap (renderPS Standard)+ $ execDocPipe Standard c args+ $ packedString ps++execAndGetOutput :: RenderMode -> FilePath -> [String] -> Doc+ -> IO (ProcessHandle, MVar (), B.ByteString)+execAndGetOutput target c args instr = do+ (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing+ _ <- forkIO $ hPutDoc target i instr >> hClose i+ mvare <- newEmptyMVar+ _ <- forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed+ hPutStr stderr)+ `finally` putMVar mvare ())+ out <- B.hGetContents o+ return (pid, mvare, out)++execDocPipe :: RenderMode -> String -> [String] -> Doc -> IO Doc+execDocPipe target c args instr = withoutProgress $ do+ (pid, mvare, out) <- execAndGetOutput target c args instr+ rval <- waitForProcess pid+ takeMVar mvare+ case rval of+ ExitFailure ec ->fail $ "External program '"++c+++ "' failed with exit code "++ show ec+ ExitSuccess -> return $ packedString out++-- The following is needed for diff, which returns non-zero whenever+-- the files differ.+execPipeIgnoreError :: RenderMode -> String -> [String] -> Doc -> IO Doc+execPipeIgnoreError target c args instr = withoutProgress $ do+ (pid, mvare, out) <- execAndGetOutput target c args instr+ _ <- waitForProcess pid+ takeMVar mvare+ return $ if B.null out then empty else packedString out++signString :: Sign -> Doc -> IO Doc+signString NoSign d = return d+signString Sign d = signPGP [] d+signString (SignAs keyid) d = signPGP ["--local-user", keyid] d+signString (SignSSL idf) d = signSSL idf d++signPGP :: [String] -> Doc -> IO Doc+signPGP args = execDocPipe Standard "gpg" ("--clearsign":args)++signSSL :: String -> Doc -> IO Doc+signSSL idfile t =+ withTemp $ \cert -> do+ opensslPS ["req", "-new", "-key", idfile,+ "-outform", "PEM", "-days", "365"]+ (BC.pack "\n\n\n\n\n\n\n\n\n\n\n")+ >>= opensslPS ["x509", "-req", "-extensions",+ "v3_ca", "-signkey", idfile,+ "-outform", "PEM", "-days", "365"]+ >>= opensslPS ["x509", "-outform", "PEM"]+ >>= B.writeFile cert+ opensslDoc ["smime", "-sign", "-signer", cert,+ "-inkey", idfile, "-noattr", "-text"] t+ where opensslDoc = execDocPipe Standard "openssl"+ opensslPS = execPSPipe "openssl"+++verifyPS :: Verify -> B.ByteString -> IO (Maybe B.ByteString)+verifyPS NoVerify ps = return $ Just ps+verifyPS (VerifyKeyring pks) ps = verifyGPG pks ps+verifyPS (VerifySSL auks) ps = verifySSL auks ps++verifyGPG :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)+verifyGPG goodkeys s =+ withOpenTemp $ \(th,tn) -> do+ B.hPut th s+ hClose th+ rval <- exec "gpg" ["--batch","--no-default-keyring",+ "--keyring",fix_path $ toFilePath goodkeys, "--verify"]+ (File tn, Null, Null)+ case rval of+ ExitSuccess -> return $ Just gpg_fixed_s+ _ -> return Nothing+ where gpg_fixed_s = let+ not_begin_signature x =+ x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"+ &&+ x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----\r"+ in unlinesPS $ map fix_line $ tail $ dropWhile not_begin_signature $ linesPS s+ fix_line x | B.length x < 3 = x+ | BC.pack "- -" `B.isPrefixOf` x = B.drop 2 x+ | otherwise = x+#if defined(WIN32)+ fix_sep c | c=='/' = '\\' | otherwise = c+ fix_path p = map fix_sep p+#else+ fix_path p = p+#endif++verifySSL :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)+verifySSL goodkeys s = do+ certdata <- opensslPS ["smime", "-pk7out"] s+ >>= opensslPS ["pkcs7", "-print_certs"]+ cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata+ let key_used = B.concat $ tail $+ takeWhile (/= BC.pack"-----END PUBLIC KEY-----")+ $ linesPS cruddy_pk+ in do allowed_keys <- linesPS `fmap` B.readFile (toFilePath goodkeys)+ if key_used `notElem` allowed_keys+ then return Nothing -- Not an allowed key!+ else withTemp $ \cert ->+ withTemp $ \on ->+ withOpenTemp $ \(th,tn) -> do+ B.hPut th s+ hClose th+ B.writeFile cert certdata+ rval <- exec "openssl" ["smime", "-verify", "-CAfile",+ cert, "-certfile", cert]+ (File tn, File on, Null)+ case rval of+ ExitSuccess -> Just `fmap` B.readFile on+ _ -> return Nothing+ where opensslPS = execPSPipe "openssl"++viewDoc :: Doc -> IO ()+viewDoc = viewDocWith simplePrinters Encode++viewDocWith :: Printers -> RenderMode -> Doc -> IO ()+viewDocWith pr mode msg = do+ isTerminal <- hIsTerminalDevice stdout+ void $ if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString mode msg)+ then do mbViewerPlusArgs <- getViewer+ case mbViewerPlusArgs of+ Just viewerPlusArgs -> do+ let (viewer : args) = words viewerPlusArgs+ pipeDocToPager viewer args pr mode msg+ Nothing -> return $ ExitFailure 127 -- No such command+ -- TEMPORARY passing the -K option should be removed as soon as+ -- we can use the delegate_ctrl_c feature in process+ `ortryrunning` pipeDocToPager "less" ["-RK"] pr mode msg+ `ortryrunning` pipeDocToPager "more" [] pr mode msg+#ifdef WIN32+ `ortryrunning` pipeDocToPager "more.com" [] pr mode msg+#endif+ `ortryrunning` pipeDocToPager "" [] pr mode msg+ else pipeDocToPager "" [] pr mode msg+ where lengthGreaterThan n _ | n <= 0 = True+ lengthGreaterThan _ [] = False+ lengthGreaterThan n (_:xs) = lengthGreaterThan (n-1) xs++getViewer :: IO (Maybe String)+getViewer = Just `fmap` (getEnv "DARCS_PAGER" `catchall` getEnv "PAGER")+ `catchall`+ return Nothing++pipeDocToPager :: String -> [String] -> Printers -> RenderMode -> Doc -> IO ExitCode++pipeDocToPager "" _ pr mode inp = do+ hPutDocLnWith pr mode stdout inp+ return ExitSuccess++pipeDocToPager c args pr mode inp = pipeDocInternal (PipeToOther pr) mode c args inp++-- | Given two shell commands as arguments, execute the former. The+-- latter is then executed if the former failed because the executable+-- wasn't found (code 127), wasn't executable (code 126) or some other+-- exception occurred (save from a resource vanished/broken pipe error).+-- Other failures (such as the user holding ^C)+-- do not cause the second command to be tried.+ortryrunning :: IO ExitCode+ -> IO ExitCode+ -> IO ExitCode+a `ortryrunning` b = do+ ret <- try a+ case ret of+ (Right (ExitFailure 126)) -> b -- command not executable+ (Right (ExitFailure 127)) -> b -- command not found+#ifdef WIN32+ (Right (ExitFailure 9009)) -> b -- command not found by cmd.exe on Windows+#endif+ (Right x) -> return x -- legitimate success/failure+ (Left (e :: IOException)) -> case ioeGetErrorType e of+ -- case where pager is quit before darcs has fed it entirely:+ ResourceVanished -> return ExitSuccess+ -- other exception:+ _ -> b+++editText :: String -> B.ByteString -> IO B.ByteString+editText desc txt = withNamedTemp desc $ \f -> do+ B.writeFile f txt+ _ <- runEditor f+ B.readFile f++-- | @editFile f@ lets the user edit a file which could but does not need to+-- already exist. This function returns the exit code from the text editor and a+-- flag indicating if the user made any changes.+editFile :: FilePathLike p+ => p+ -> IO (ExitCode, Bool)+editFile ff = do+ old_content <- file_content+ ec <- runEditor f+ new_content <- file_content+ return (ec, new_content /= old_content)+ where+ f = toFilePath ff+ file_content = do+ exists <- doesFileExist f+ if exists then do content <- B.readFile f+ return $ Just content+ else return Nothing+++runEditor :: FilePath+ -> IO ExitCode+runEditor f = do+ ed <- getEditor+ execInteractive ed f+ `ortryrunning` execInteractive "vi" f+ `ortryrunning` execInteractive "emacs" f+ `ortryrunning` execInteractive "emacs -nw" f+#ifdef WIN32+ `ortryrunning` execInteractive "edit" f+#endif+++getEditor :: IO String+getEditor = getEnv "DARCS_EDITOR" `catchall`+ getEnv "DARCSEDITOR" `catchall`+ getEnv "VISUAL" `catchall`+ getEnv "EDITOR" `catchall` return "nano"++catchall :: IO a+ -> IO a+ -> IO a+a `catchall` b = a `catchNonSignal` (\_ -> b)+++-- | In some environments, darcs requires that certain global GHC library variables that+-- control the encoding used in internal translations are set to specific values.+--+-- @setDarcsEncoding@ enforces those settings, and should be called before the+-- first time any darcs operation is run, and again if anything else might have+-- set those encodings to different values.+--+-- Note that it isn't thread-safe and has a global effect on your program.+--+-- The current behaviour of this function is as follows, though this may+-- change in future:+--+-- Encodings are only set on GHC 7.4 and up, on any non-Windows platform.+--+-- Two encodings are set, both to @GHC.IO.Encoding.char8@:+-- @GHC.IO.Encoding.setFileSystemEncoding@ and @GHC.IO.Encoding.setForeignEncoding@.+--+-- Prevent HLint from warning us about a redundant do if the macro isn't+-- defined:+setDarcsEncodings :: IO ()+setDarcsEncodings = do++-- This is needed for appropriate behaviour from getArgs and from general+-- filesystem calls (e.g. getDirectoryContents, readFile, ...)+ setFileSystemEncoding char8++-- This ensures that foreign calls made by hashed-storage to stat+-- filenames returned from getDirectoryContents are translated appropriately+ setForeignEncoding char8++ return ()++-- The following functions are copied from the encoding package (BSD3+-- licence, by Henning Günther).++-- | @getSystemEncoding@ fetches the current encoding from locale+foreign import ccall "system_encoding.h get_system_encoding"+ get_system_encoding :: IO CString+++getSystemEncoding :: IO String+getSystemEncoding = do+ enc <- get_system_encoding+ peekCString enc+++-- | @isUTF8@ checks if an encoding is UTF-8 (or ascii, since it is a+-- subset of UTF-8).+isUTF8Locale :: String -> Bool+isUTF8Locale codeName = case normalizeEncoding codeName of+ -- ASCII+ "ascii" -> True+ "646" -> True+ "ansi_x3_4_1968" -> True+ "ansi_x3.4_1986" -> True+ "cp367" -> True+ "csascii" -> True+ "ibm367" -> True+ "iso646_us" -> True+ "iso_646.irv_1991" -> True+ "iso_ir_6" -> True+ "us" -> True+ "us_ascii" -> True+ -- UTF-8+ "utf_8" -> True+ "u8" -> True+ "utf" -> True+ "utf8" -> True+ "utf8_ucs2" -> True+ "utf8_ucs4" -> True+ -- Everything else+ _ -> False+ where+ normalizeEncoding s = map toLower $ subRegex sep s "_"+ sep = mkRegex "[^0-9A-Za-z]+"
+ src/Darcs/UI/Flags.hs view
@@ -0,0 +1,536 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.Flags+ ( -- TODO we want to stop exporting the constructors of DarcsFlag+ -- from here. First need to change all the relevant code over to the+ -- using helpers from this module instead.+ F.DarcsFlag( .. )+ , compression+ , remoteDarcs+ , reorder+ , minimize+ , editDescription+ , diffingOpts+ , diffOpts+ , externalMerge+ , wantGuiPause+ , isInteractive+ , maxCount+ , willRemoveLogFile+ , isUnified+ , doHappyForwarding+ , includeBoring+ , doAllowCaseOnly+ , doAllowWindowsReserved+ , doReverse+ , usePacks+ , showChangesOnlyToFiles+ , removeFromAmended+ , toMatchFlags+ , verbosity+ , useCache+ , umask+ , dryRun+ , lookForAdds+ , lookForMoves+ , lookForReplaces+ , diffAlgorithm+ , runTest+ , testChanges+ , setScriptsExecutable+ , withWorkingDir+ , leaveTestDir+ , remoteRepos+ , setDefault+ , cloneKind+ , workRepo+ , allowConflicts+ , runPatchIndex+ , useIndex+ , hasSummary+ , hasXmlOutput+ , selectDeps+ , hasAuthor+ , hasLogfile+ , patchFormat++ , fixRemoteRepos+ , fixUrl+ , fixSubPaths+ , maybeFixSubPaths+ , getRepourl+ , getAuthor+ , promptAuthor+ , getEasyAuthor+ , getSendmailCmd+ , fileHelpAuthor+ , environmentHelpEmail+ , getSubject+ , getCharset+ , getInReplyTo+ , getCc+ , environmentHelpSendmail+ , siblings+ , getOutput+ , getDate+ , getReply+ , applyAs+ ) where++import Prelude hiding ( (^) )++import Data.List ( nub, intercalate )+import Data.Maybe+ ( isJust+ , maybeToList+ , isNothing+ , catMaybes+ )+import Control.Monad ( unless )+import Control.Applicative( (<$>) )+import System.Directory ( doesDirectoryExist, createDirectory )+import System.FilePath.Posix ( (</>) )++import qualified Darcs.Patch.Match as MF ( MatchFlag(..) )+import Darcs.UI.External+ ( catchall )+import qualified Darcs.UI.Options.Flags as F ( DarcsFlag( .. ) )+import Darcs.UI.Options.Core+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Environment ( maybeGetEnv )+import Darcs.Util.Exception ( firstJustIO )+import Darcs.Util.File ( withCurrentDirectory )+import Darcs.Util.Prompt+ ( askUser+ , askUserListItem+ )+import Darcs.Repository.Lock ( writeLocaleFile )+import Darcs.Repository.Prefs+ ( getPreflist+ , getGlobal+ , globalPrefsDirDoc+ , globalPrefsDir+ )+import Darcs.Util.ByteString ( decodeString )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.IsoDate ( getIsoDateTime, cleanLocalDate )+import Darcs.Util.Path+ ( AbsolutePath+ , AbsolutePathOrStd+ , SubPath+ , toFilePath+ , makeSubPathOf+ , ioAbsolute+ , makeAbsoluteOrStd+ )+import Darcs.Util.Printer ( putDocLn, text, ($$) )+import Darcs.Util.URL ( isValidLocalPath )++type Config = [F.DarcsFlag]++compression :: Config -> O.Compression+compression = parseFlags O.compress++remoteDarcs :: Config -> O.RemoteDarcs+remoteDarcs = O.remoteDarcs . parseFlags O.network++reorder :: Config -> O.Reorder+reorder = parseFlags O.reorder++minimize :: Config -> Bool+minimize = parseFlags O.minimize++editDescription :: Config -> Bool+editDescription = parseFlags O.editDescription++-- | Non-trivial interaction between options.+diffOpts :: O.UseIndex -> O.LookForAdds -> Bool -> O.DiffAlgorithm -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)+diffOpts use_index look_for_adds include_boring diff_alg =+ (use_index, scanKnown look_for_adds include_boring, diff_alg)+ where+ scanKnown O.NoLookForAdds _ = O.ScanKnown+ scanKnown O.YesLookForAdds False = O.ScanAll+ scanKnown O.YesLookForAdds True = O.ScanBoring++diffingOpts :: Config -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)+diffingOpts flags = diffOpts (useIndex flags) (lookForAdds flags) False (diffAlgorithm flags)++externalMerge :: Config -> O.ExternalMerge+externalMerge = parseFlags O.useExternalMerge++-- | This will become dis-entangled as soon as we inline these functions.+wantGuiPause :: Config -> O.WantGuiPause+wantGuiPause fs = if (hasDiffCmd fs || hasExternalMerge fs) && hasPause fs then O.YesWantGuiPause else O.NoWantGuiPause+ where+ hasDiffCmd = isJust . O._diffCmd . parseFlags O.extDiff+ hasExternalMerge = (/= O.NoExternalMerge) . parseFlags O.useExternalMerge+ hasPause = (== O.YesWantGuiPause) . parseFlags O.pauseForGui++-- | Non-trivial interaction between options. Explicit @-i@ or @-a@ dominates,+-- else @--count@, @--xml@, or @--dry-run@ imply @-a@, else default to interactive.+isInteractive :: Config -> Bool+isInteractive = oparse (O.dryRunXml ^ O.changesFormat ^ O.interactive) decide+ where+ decide :: O.DryRun -> O.XmlOutput -> Maybe O.ChangesFormat -> Maybe Bool -> Bool+ decide _ _ _ (Just True) = True+ decide _ _ _ (Just False) = False+ decide _ _ (Just O.CountPatches) Nothing = False+ decide _ O.YesXml _ Nothing = False+ decide O.YesDryRun _ _ Nothing = False+ decide _ _ _ Nothing = True++maxCount :: Config -> Maybe Int+maxCount = parseFlags O.matchMaxcount++willRemoveLogFile :: Config -> Bool+willRemoveLogFile = O._rmlogfile . parseFlags O.logfile++isUnified :: Config -> O.WithContext+isUnified = parseFlags O.withContext++doHappyForwarding :: Config -> Bool+doHappyForwarding = parseFlags O.happyForwarding++includeBoring :: Config -> Bool+includeBoring = parseFlags O.includeBoring++doAllowCaseOnly :: Config -> Bool+doAllowCaseOnly = parseFlags O.allowCaseDifferingFilenames++doAllowWindowsReserved :: Config -> Bool+doAllowWindowsReserved = parseFlags O.allowWindowsReservedFilenames++doReverse :: Config -> Bool+doReverse = parseFlags O.changesReverse++usePacks :: Config -> Bool+usePacks = parseFlags O.usePacks++showChangesOnlyToFiles :: Config -> Bool+showChangesOnlyToFiles = parseFlags O.onlyToFiles++removeFromAmended :: Config -> Bool+removeFromAmended = parseFlags O.amendUnrecord++toMatchFlags :: Config -> [MF.MatchFlag]+toMatchFlags = parseFlags O.matchAny++verbosity :: Config -> O.Verbosity+verbosity = parseFlags O.verbosity++useCache :: Config -> O.UseCache+useCache = parseFlags O.useCache++umask :: Config -> O.UMask+umask = parseFlags O.umask++dryRun :: Config -> O.DryRun+dryRun = parseFlags O.dryRun++runPatchIndex :: Config -> O.WithPatchIndex+runPatchIndex = parseFlags O.patchIndex++lookForAdds :: Config -> O.LookForAdds+lookForAdds = O.adds . parseFlags O.lookfor++lookForReplaces :: Config -> O.LookForReplaces+lookForReplaces = O.replaces . parseFlags O.lookfor++diffAlgorithm :: Config -> O.DiffAlgorithm+diffAlgorithm = parseFlags O.diffAlgorithm++lookForMoves :: Config -> O.LookForMoves+lookForMoves = O.moves . parseFlags O.lookfor++runTest :: Config -> O.RunTest+runTest = parseFlags O.test++testChanges :: Config -> O.TestChanges+testChanges = parseFlags O.testChanges++setScriptsExecutable :: Config -> O.SetScriptsExecutable+setScriptsExecutable = parseFlags O.setScriptsExecutable++withWorkingDir :: Config -> O.WithWorkingDir+withWorkingDir = parseFlags O.useWorkingDir++leaveTestDir :: Config -> O.LeaveTestDir+leaveTestDir = parseFlags O.leaveTestDir++remoteRepos :: Config -> O.RemoteRepos+remoteRepos = parseFlags O.remoteRepos++setDefault :: Bool -> Config -> O.SetDefault+setDefault defYes = maybe def noDef . parseFlags O.setDefault where+ def = if defYes then O.YesSetDefault False else O.NoSetDefault False+ noDef yes = if yes then O.YesSetDefault True else O.NoSetDefault True++cloneKind :: Config -> O.CloneKind+cloneKind = parseFlags O.partial++workRepo :: Config -> O.WorkRepo+workRepo = parseFlags O.workRepo++allowConflicts :: Config -> O.AllowConflicts+allowConflicts = maybe O.NoAllowConflicts id . parseFlags (O.conflicts O.NoAllowConflicts)++-- | Ugly. The alternative is to put the remoteRepos accessor into the IO monad,+-- which is hardly better.+fixRemoteRepos :: AbsolutePath -> Config -> IO Config+fixRemoteRepos d = mapM fixRemoteRepo where+ fixRemoteRepo (F.RemoteRepo p) = F.RemoteRepo `fmap` fixUrl d p+ fixRemoteRepo f = return f++-- | 'fixUrl' takes a String that may be a file path or a URL.+-- It returns either the URL, or an absolute version of the path.+fixUrl :: AbsolutePath -> String -> IO String+fixUrl d f = if isValidLocalPath f+ then toFilePath `fmap` withCurrentDirectory d (ioAbsolute f)+ else return f++-- | @maybeFixSubPaths files@ tries to turn the file paths in its argument into+-- @SubPath@s.+--+-- When converting a relative path to an absolute one, this function first tries+-- to interpret the relative path with respect to the current working directory.+-- If that fails, it tries to interpret it with respect to the repository+-- directory. Only when that fails does it put a @Nothing@ in the result at the+-- position of the path that cannot be converted.+--+-- It is intended for validating file arguments to darcs commands.+maybeFixSubPaths :: (AbsolutePath, AbsolutePath) -> [FilePath] -> IO [Maybe SubPath]+maybeFixSubPaths (r, o) fs = withCurrentDirectory o $ do+ fixedFs <- mapM fixit fs+ let bads = snd . unzip . filter (isNothing . fst) $ zip fixedFs fs+ unless (null bads) . putStrLn $ "Ignoring non-repository paths: " +++ intercalate ", " bads+ return fixedFs+ where+ fixit p = do ap <- ioAbsolute p+ case makeSubPathOf r ap of+ Just sp -> return $ Just sp+ Nothing -> withCurrentDirectory r $ do+ absolutePathByRepodir <- ioAbsolute p+ return $ makeSubPathOf r absolutePathByRepodir++-- | @fixSubPaths files@ returns the @SubPath@s for the paths in @files@ that+-- are inside the repository, preserving their order. Paths in @files@ that are+-- outside the repository directory are not in the result.+--+-- When converting a relative path to an absolute one, this function first tries+-- to interpret the relative path with respect to the current working directory.+-- If that fails, it tries to interpret it with respect to the repository+-- directory. Only when that fails does it omit the path from the result.+--+-- It is intended for validating file arguments to darcs commands.+fixSubPaths :: (AbsolutePath, AbsolutePath) -> [FilePath] -> IO [SubPath]+fixSubPaths fps fs = nub . catMaybes <$> maybeFixSubPaths fps+ (filter (not . null) fs)++-- | 'getRepourl' takes a list of flags and returns the url of the+-- repository specified by @Repodir \"directory\"@ in that list of flags, if any.+-- This flag is present if darcs was invoked with @--repodir=DIRECTORY@+getRepourl :: Config -> Maybe String+getRepourl fs = case parseFlags O.possiblyRemoteRepo fs of+ Nothing -> Nothing+ Just d -> if not (isValidLocalPath d) then Just d else Nothing++fileHelpAuthor :: [String]+fileHelpAuthor = [+ "Each patch is attributed to its author, usually by email address (for",+ "example, `Fred Bloggs <fred@example.net>`). Darcs looks in several",+ "places for this author string: the `--author` option, the files",+ "`_darcs/prefs/author` (in the repository) and `" ++ globalPrefsDirDoc ++ "author` (in your",+ "home directory), and the environment variables `$DARCS_EMAIL` and",+ "`$EMAIL`. If none of those exist, Darcs will prompt you for an author",+ "string and write it to `" ++ globalPrefsDirDoc ++ "author`. Note that if you have more",+ "than one email address, you can put them all in `" ++ globalPrefsDirDoc ++ "author`,",+ "one author per line. Darcs will still prompt you for an author, but it",+ "allows you to select from the list, or to type in an alternative."+ ]++environmentHelpEmail :: ([String], [String])+environmentHelpEmail = (["DARCS_EMAIL","EMAIL"], fileHelpAuthor)++-- | 'getAuthor' takes a list of flags and returns the author of the+-- change specified by @Author \"Leo Tolstoy\"@ in that list of flags, if any.+-- Otherwise, if @Pipe@ is present, asks the user who is the author and+-- returns the answer. If neither are present, try to guess the author,+-- from repository or global preference files or environment variables,+-- and if it's not possible, ask the user.+getAuthor :: Maybe String -> Bool -> IO String+getAuthor (Just author) _ = return author+getAuthor Nothing pipe = if pipe then askUser "Who is the author? " else promptAuthor True False++-- | 'promptAuthor' try to guess the author, from repository or+-- global preference files or environment variables, and+-- if it's not possible or alwaysAsk parameter is true, ask the user.+-- If store parameter is true, the new author is added into+-- @_darcs/prefs@.+promptAuthor :: Bool -- Store the new author+ -> Bool -- Author selection even if already stored+ -> IO String+promptAuthor store alwaysAsk = do+ as <- getEasyAuthor+ case as of+ [a] -> if alwaysAsk then+ askForAuthor (fancyPrompt as) (fancyPrompt as)+ else return a+ [] -> askForAuthor shortPrompt longPrompt+ _ -> askForAuthor (fancyPrompt as) (fancyPrompt as)+ where+ shortPrompt = askUser "What is your email address? "+ longPrompt = askUser "What is your email address (e.g. Fred Bloggs <fred@example.net>)? "+ fancyPrompt xs =+ do putDocLn $ text "" $$+ text "You have saved the following email addresses to your global settings:"+ str <- askUserListItem "Please select an email address for this repository: " (xs ++ ["Other"])+ if str == "Other"+ then longPrompt+ else return str+ askForAuthor askfn1 askfn2 = do+ aminrepo <- doesDirectoryExist (darcsdir++"/prefs")+ if aminrepo && store then do+ putDocLn $+ text "Each patch is attributed to its author, usually by email address (for" $$+ text "example, `Fred Bloggs <fred@example.net>'). Darcs could not determine" $$+ text "your email address, so you will be prompted for it." $$+ text "" $$+ text ("Your address will be stored in " ++ globalPrefsDirDoc ++ "author") $$+ text "It will be used for all patches you record in ALL repositories." $$+ text ("If you move that file to " ++ darcsdir </> "prefs" </> "author, it will") $$+ text "be used for patches recorded in this repository only."+ add <- askfn1+ maybeprefsdir <- globalPrefsDir+ prefsdir <- case maybeprefsdir of+ Nothing -> do+ putStrLn "WARNING: Global preference directory could not be found."+ return $ darcsdir </> "prefs"+ Just dir -> do exists <- doesDirectoryExist dir+ unless exists $ createDirectory dir+ return dir+ writeLocaleFile (prefsdir </> "author") $+ unlines ["# " ++ line | line <- fileHelpAuthor] ++ "\n" ++ add+ return add+ else askfn2++-- | 'getEasyAuthor' tries to get the author name first from the repository preferences,+-- then from global preferences, then from environment variables. Returns @[]@+-- if it could not get it. Note that it may only return multiple possibilities when+-- reading from global preferences+getEasyAuthor :: IO [String]+getEasyAuthor =+ firstNotNullIO [ (take 1 . nonblank) `fmap` getPreflist "author"+ , nonblank `fmap` getGlobal "author"+ , maybeToList `fmap` maybeGetEnv "DARCS_EMAIL"+ , maybeToList `fmap` maybeGetEnv "EMAIL"+ ] >>= mapM decodeString+ where+ nonblank = filter (not . null)+ -- this could perhaps be simplified with Control.Monad+ -- but note that we do NOT want to concatenate the results+ firstNotNullIO [] = return []+ firstNotNullIO (e:es) = do+ v <- e `catchall` return []+ if null v then firstNotNullIO es else return v++getDate :: Bool -> IO String+getDate hasPipe = if hasPipe then cleanLocalDate =<< askUser "What is the date? "+ else getIsoDateTime++environmentHelpSendmail :: ([String], [String])+environmentHelpSendmail = (["SENDMAIL"], [+ "On Unix, the `darcs send` command relies on sendmail(8). The",+ "`--sendmail-command` or $SENDMAIL environment variable can be used to",+ "provide an explicit path to this program; otherwise the standard",+ "locations /usr/sbin/sendmail and /usr/lib/sendmail will be tried."])+-- FIXME: mention the following also:+-- * sendmail(8) is not sendmail-specific;+-- * nowadays, desktops often have no MTA or an unconfigured MTA --+-- which is awful, because it accepts mail but doesn't relay it;+-- * in this case, can be a sendmail(8)-emulating wrapper on top of an+-- MUA that sends mail directly to a smarthost; and+-- * on a multi-user system without an MTA and on which you haven't+-- got root, can be msmtp.++-- |'getSendmailCmd' takes a list of flags and returns the sendmail command+-- to be used by @darcs send@. Looks for a command specified by+-- @SendmailCmd \"command\"@ in that list of flags, if any.+-- This flag is present if darcs was invoked with @--sendmail-command=COMMAND@+-- Alternatively the user can set @$S@@ENDMAIL@ which will be used as a fallback if present.+getSendmailCmd :: Config -> IO String+getSendmailCmd fs = case parseFlags O.sendmailCmd fs of+ Just cmd -> return cmd+ Nothing -> fmap (maybe "" id) $ firstJustIO [ maybeGetEnv "SENDMAIL" ]++-- | Accessor for output option+getOutput :: Config -> FilePath -> Maybe AbsolutePathOrStd+getOutput fs fp = fmap go (parseFlags O.output fs) where+ go (O.Output ap) = ap+ go (O.OutputAutoName ap) = makeAbsoluteOrStd ap fp++getCharset :: Config -> Maybe String+getCharset = parseFlags O.charset++-- |'getSubject' takes a list of flags and returns the subject of the mail+-- to be sent by @darcs send@. Looks for a subject specified by+-- @Subject \"subject\"@ in that list of flags, if any.+-- This flag is present if darcs was invoked with @--subject=SUBJECT@+getSubject :: Config -> Maybe String+getSubject = O._subject . parseFlags O.headerFields++-- |'getCc' takes a list of flags and returns the addresses to send a copy of+-- the patch bundle to when using @darcs send@.+-- looks for a cc address specified by @Cc \"address\"@ in that list of flags.+-- Returns the addresses as a comma separated string.+getCc :: Config -> String+getCc = intercalate " , " . O._cc . parseFlags O.headerFields++getInReplyTo :: Config -> Maybe String+getInReplyTo = O._inReplyTo . parseFlags O.headerFields++getReply :: Config -> Maybe String+getReply = parseFlags O.reply++-- | 'flagsToSiblings' collects the contents of all @Sibling@ flags in a list of flags.+siblings :: Config -> [AbsolutePath]+siblings = parseFlags O.siblings++useIndex :: Config -> O.UseIndex+useIndex = parseFlags O.useIndex++hasSummary :: O.Summary -> Config -> O.Summary+hasSummary def = maybe def id . parseFlags O.summary++hasXmlOutput :: Config -> O.XmlOutput+hasXmlOutput = parseFlags O.xmloutput++selectDeps :: Config -> O.SelectDeps+selectDeps = parseFlags O.selectDeps++hasLogfile :: Config -> Maybe AbsolutePath+hasLogfile = O._logfile . parseFlags O.logfile++hasAuthor :: Config -> Maybe String+hasAuthor = parseFlags O.author++patchFormat :: Config -> O.PatchFormat+patchFormat = parseFlags O.patchFormat++applyAs :: Config -> Maybe String+applyAs = parseFlags O.applyAs
+ src/Darcs/UI/Message/Send.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE OverloadedStrings #-}+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, TypeOperators #-}++-- | Help text and UI messages for @darcs send@+module Darcs.UI.Message.Send where++import Darcs.Util.Path ( FilePathLike(..), toFilePath )+import Darcs.UI.Commands ( formatPath )+import Darcs.Repository.Flags ( DryRun(..) )+import Darcs.Util.Text ( sentence )+import Darcs.Util.Printer++cmdDescription :: String+cmdDescription =+ "Prepare a bundle of patches to be applied to some target repository."++cmdHelp :: String+cmdHelp = unlines+ [ "Send is used to prepare a bundle of patches that can be applied to a target"+ , "repository. Send accepts the URL of the repository as an argument. When"+ , "called without an argument, send will use the most recent repository that"+ , "was either pushed to, pulled from or sent to. By default, the patch bundle"+ , "is saved to a file, although you may directly send it by mail."+ , ""+ , "The `--output`, `--output-auto-name`, and `--to` flags determine"+ , "what darcs does with the patch bundle after creating it. If you provide an"+ , "`--output` argument, the patch bundle is saved to that file. If you"+ , "specify `--output-auto-name`, the patch bundle is saved to a file with an"+ , "automatically generated name. If you give one or more `--to` arguments,"+ , "the bundle of patches is sent to those locations. The locations may either"+ , "be email addresses or urls that the patch should be submitted to via HTTP."+ , ""+ , "If you provide the `--mail` flag, darcs will look at the contents"+ , "of the `_darcs/prefs/email` file in the target repository (if it exists),"+ , "and send the patch by email to that address. In this case, you may use"+ , "the `--cc` option to specify additional recipients without overriding the"+ , "default repository email address."+ , ""+ , "If `_darcs/prefs/post` exists in the target repository, darcs will"+ , "upload to the URL contained in that file, which may either be a"+ , "`mailto:` URL, or an `http://` URL. In the latter case, the"+ , "patch is posted to that URL."+ , ""+ , "If there is no email address associated with the repository, darcs will"+ , "prompt you for an email address."+ , ""+ , "Use the `--subject` flag to set the subject of the e-mail to be sent."+ , "If you don't provide a subject on the command line, darcs will make one up"+ , "based on names of the patches in the patch bundle."+ , ""+ , "Use the `--in-reply-to` flag to set the In-Reply-To and References headers"+ , "of the e-mail to be sent. By default no additional headers are included so"+ , "e-mail will not be treated as reply by mail readers."+ , ""+ , "If you want to include a description or explanation along with the bundle"+ , "of patches, you need to specify the `--edit-description` flag, which"+ , "will cause darcs to open up an editor with which you can compose a message"+ , "to go along with your patches."+ , ""+ , "If you want to use a command different from the default one for sending"+ , "email, you need to specify a command line with the `--sendmail-command`"+ , "option. The command line can contain some format specifiers which are"+ , "replaced by the actual values. Accepted format specifiers are `%s` for"+ , "subject, `%t` for to, `%c` for cc, `%b` for the body of the mail, `%f` for"+ , "from, `%a` for the patch bundle and the same specifiers in uppercase for the"+ , "URL-encoded values."+ , "Additionally you can add `%<` to the end of the command line if the command"+ , "expects the complete email message on standard input. E.g. the command lines"+ , "for evolution and msmtp look like this:"+ , ""+ , " evolution \"mailto:%T?subject=%S&attach=%A&cc=%C&body=%B\""+ , " msmtp -t %<"+ , ""+ , "Do not confuse the `--author` options with the return address"+ , "that `darcs send` will set for your patch bundle."+ , ""+ , "For example, if you have two email addresses A and B:"+ , ""+ , "* If you use `--author A` but your machine is configured to send mail from"+ , " address B by default, then the return address on your message will be B."+ , "* If you use `--from A` and your mail client supports setting the"+ , " From: address arbitrarily (some non-Unix-like mail clients, especially,"+ , " may not support this), then the return address will be A; if it does"+ , " not support this, then the return address will be B."+ , "* If you supply neither `--from` nor `--author` then the return"+ , " address will be B."+ , ""+ , "In addition, unless you specify the sendmail command with"+ , "`--sendmail-command`, darcs sends email using the default email"+ , "command on your computer. This default command is determined by the"+ , "`configure` script. Thus, on some non-Unix-like OSes,"+ , "`--from` is likely to not work at all."+ ]++cannotSendToSelf :: String+cannotSendToSelf = "Can't send to current repository! Did you mean send --context?"++creatingPatch :: String -> Doc+creatingPatch repodir = "Creating patch to" <+> text (formatPath repodir) <> "..."++noWorkingSendmail :: Doc+noWorkingSendmail = "No working sendmail instance on your machine!"++nothingSendable :: Doc+nothingSendable = "No recorded local changes to send!"++selectionIs :: [Doc] -> Doc+selectionIs descs = text "We have the following patches to send:" $$ vcat descs++selectionIsNull :: Doc+selectionIsNull = text "You don't want to send any patches, and that's fine with me!"++emailBackedUp :: String -> Doc+emailBackedUp mf = sentence $ "Email body left in" <+> text mf++promptCharSetWarning :: String -> String+promptCharSetWarning msg = "Warning: " ++ msg ++ " Send anyway?"++charsetAborted :: Doc+charsetAborted = "Aborted. You can specify charset with the --charset option."++charsetCouldNotGuess :: String+charsetCouldNotGuess = "darcs could not guess the charset of your mail."++currentEncodingIs :: String -> String+currentEncodingIs e = "Current locale encoding: " ++ e++charsetUtf8MailDiffLocale :: String+charsetUtf8MailDiffLocale = "your mail is valid UTF-8 but your locale differs."++aborted :: Doc+aborted = "Aborted."++success :: String -> String -> Doc+success to cc = sentence $+ "Successfully sent patch bundle to:" <+> text to <+> copies cc+ where+ copies "" = ""+ copies x = "and cc'ed" <+> text x++postingPatch :: String -> Doc+postingPatch url = "Posting patch to" <+> text url++wroteBundle :: FilePathLike a => a -> Doc+wroteBundle a = sentence $ "Wrote patch to" <+> text (toFilePath a)++savedButNotSent :: String -> Doc+savedButNotSent to =+ text ("The usual recipent for this bundle is: " ++ to)+ $$ text "To send it automatically, mark sure sendmail is working, and add 'send mail' to _darcs/prefs/defaults or ~/.darcs/defaults"++willSendTo :: DryRun -> [String] -> Doc+willSendTo dr addresses =+ "Patch bundle" <+> will <+> " be sent to:" <+> text (unwords addresses)+ where+ will = case dr of { YesDryRun -> "would"; NoDryRun -> "will" }++promptTarget :: String+promptTarget = "What is the target email address? "++aboutToEdit :: FilePath -> String+aboutToEdit file = "About to edit file " ++ file++promptNoDescriptionChange :: String+promptNoDescriptionChange = "File content did not change. Continue anyway?"
+ src/Darcs/UI/Options.hs view
@@ -0,0 +1,28 @@+module Darcs.UI.Options+ ( module Darcs.UI.Options.Core+ , module Darcs.UI.Options.Markdown+ , DarcsOption+ , PrimDarcsOption+ , DarcsOptDescr+ , optDescr+ ) where++import Data.Functor.Compose+import System.Console.GetOpt++import Darcs.UI.Options.All+import Darcs.UI.Options.Core+import Darcs.UI.Options.Markdown+import Darcs.UI.Options.Util ( DarcsOptDescr, PrimDarcsOption )+import Darcs.Util.Path ( AbsolutePath )++-- * Type instantiations++-- | The @instance Functor OptDescr@ was introduced only in base-4.7.0.0, which is+-- why we implement it here manually.+optDescr :: AbsolutePath -> DarcsOptDescr f -> OptDescr f+optDescr path = omap ($path) . getCompose where+ omap f (Option s l a h) = Option s l (amap f a) h+ amap f (NoArg a) = NoArg (f a)+ amap f (ReqArg mkF n) = ReqArg (fmap f mkF) n+ amap f (OptArg mkF n) = OptArg (fmap f mkF) n
+ src/Darcs/UI/Options/All.hs view
@@ -0,0 +1,1235 @@+{-# LANGUAGE RecordWildCards #-}+{- | All the concrete options.++Notes:++ * The term \"option\" refers to a flag or combination of flags that+ together form a part of a command's configuration. Ideally, options+ should be orthogonal to each other, so we can freely combine them.++ * A primitive (indivisible) option has an associate value type.++ * An option named \"xyzActions\" represents a set of flags that act as+ mutually exclusive sub-commands. They typically have a dedicated value+ type named \"XyzAction\".++ * This module is probably best imported qualified. This is in contrast to+ the current practice of using subtly differing names to avoid name+ clashes for closely related items. For instance, the data constructors+ for an option's value type and the corresponding data constructors in+ 'F.DarcsFlag' may coincide. This is also why we import "Darcs.UI.Flags"+ qualified here.++ * When the new options system is finally in place, no code other than the+ one for constructing options should directly refer to 'F.DarcsFlag'+ constructors.++-}+module Darcs.UI.Options.All+ ( DarcsOption++ -- root+ , RootAction (..)+ , rootActions++ -- all commands+ , StdCmdAction (..)+ , stdCmdActions+ , debug+ , Verbosity (..) -- re-export+ , verbosity+ , timings+ , anyVerbosity+ , preHook+ , postHook+ , hooks+ , UseCache (..) -- re-export+ , useCache++ -- interactivity+ , XmlOutput (..)+ , xmloutput+ , DryRun (..) -- re-export+ , dryRun+ , dryRunXml+ , interactive+ , pipe+ , WantGuiPause (..) -- re-export+ , pauseForGui+ , askdeps++ -- patch selection+ , module Darcs.UI.Options.Matching -- re-export+ , SelectDeps (..)+ , selectDeps+ , changesReverse+ , matchMaxcount++ -- local or remote repo(s)+ , WorkRepo (..) -- re-export+ , workRepo+ , workingRepoDir+ , RemoteRepos (..) -- re-export+ , remoteRepos+ , possiblyRemoteRepo+ , reponame+ , notInRemote+ , notInRemoteFlagName+ , RepoCombinator (..)+ , repoCombinator+ , allowUnrelatedRepos+ , justThisRepo+ , WithWorkingDir (..) -- re-export+ , useWorkingDir+ , SetDefault (..) -- re-export+ , setDefault++ -- patch meta-data+ , patchname+ , author+ , AskLongComment (..)+ , askLongComment+ , keepDate+ , Logfile (..)+ , logfile++ -- looking for changes+ , LookFor (..)+ , LookForAdds (..) -- re-export+ , LookForMoves (..) -- re-export+ , LookForReplaces (..) -- re-export+ , lookfor++ -- files to consider+ , UseIndex (..) -- re-export+ , ScanKnown (..) -- re-export+ , diffing+ , includeBoring+ , allowProblematicFilenames+ , allowCaseDifferingFilenames+ , allowWindowsReservedFilenames+ , onlyToFiles+ , useIndex+ , recursive++ -- differences+ , DiffAlgorithm (..) -- re-export+ , diffAlgorithm+ , WithContext (..)+ , withContext+ , unidiff+ , ExternalDiff (..)+ , extDiff++ -- tests+ , TestChanges (..)+ , testChanges+ , RunTest (..) -- re-export+ , test+ , LeaveTestDir (..) -- re-export+ , leaveTestDir++ -- mail related+ , HeaderFields (..)+ , headerFields+ , sendToContext+ , sendmail+ , sendmailCmd+ , charset+ , editDescription+ , ccApply+ , reply+ , happyForwarding++ -- patch bundles+ , applyAs+ , Sign (..)+ , sign+ , Verify (..)+ , verify++ -- merging patches+ , AllowConflicts (..) -- re-export+ , conflicts+ , ExternalMerge (..) -- re-export+ , useExternalMerge++ -- optimizations+ , Compression (..) -- re-export+ , compress+ , usePacks+ , WithPatchIndex (..) -- re-export+ , patchIndex+ , patchIndexYes+ , Reorder (..) -- re-export+ , reorder+ , minimize+ , storeInMemory++ -- miscellaneous+ , Output (..)+ , output+ , Summary (..)+ , summary+ , RemoteDarcs (..) -- re-export+ , NetworkOptions (..)+ , network+ , UMask (..) -- re-export+ , umask+ , SetScriptsExecutable (..) -- re-export+ , setScriptsExecutable+ , restrictPaths++ -- command specific++ -- amend+ , amendUnrecord+ , selectAuthor++ -- annotate+ , humanReadable+ , machineReadable++ -- clone+ , CloneKind (..)+ , partial++ -- dist+ , distname+ , distzip++ -- convert import/export, init+ , marks+ , readMarks+ , writeMarks+ , PatchFormat (..)+ , patchFormat+ , hashed++ -- log+ , ChangesFormat (..)+ , changesFormat++ -- replace+ , tokens+ , forceReplace++ -- test+ , TestStrategy (..)+ , testStrategy++ -- show files/index+ , files+ , directories+ , pending+ , nullFlag++ -- gzcrcs+ , GzcrcsAction (..)+ , gzcrcsActions++ -- optimize+ , siblings+ , reorderPatches+ , optimizePatchIndex+ ) where++import Prelude hiding ( (^) )+import Data.Char ( isDigit )+import Data.List ( intercalate )+import Data.Maybe ( listToMaybe )++import Darcs.Repository.Flags+ ( Compression (..)+ , RemoteDarcs (..)+ , Reorder (..)+ , Verbosity (..)+ , UseCache (..)+ , UMask (..)+ , DryRun (..)+ , LookForAdds (..)+ , LookForMoves (..)+ , LookForReplaces (..)+ , DiffAlgorithm (..)+ , RunTest (..)+ , SetScriptsExecutable (..)+ , LeaveTestDir (..)+ , RemoteRepos (..)+ , SetDefault (..)+ , UseIndex (..)+ , ScanKnown (..)+ , CloneKind (..)+ , ExternalMerge (..)+ , WorkRepo (..)+ , AllowConflicts (..)+ , WantGuiPause (..)+ , WithPatchIndex (..)+ , WithWorkingDir (..)+ )++import qualified Darcs.UI.Options.Flags as F ( DarcsFlag(..) )+import Darcs.UI.Options.Core+import Darcs.UI.Options.Iso+import Darcs.UI.Options.Util+import Darcs.UI.Options.Matching++-- * Type instantiations++-- | 'DarcsOption' instantiates the first two type parameters of 'OptSpec' to+-- what we need in darcs. The first parameter is instantiated to+-- The flag type is instantiate to 'Flag'.+type DarcsOption = OptSpec DarcsOptDescr Flag++type RawDarcsOption = forall v. v -> RawOptSpec Flag v++-- * Root command++-- | Options for darcs iself that act like sub-commands.+data RootAction = RootHelp | Version | ExactVersion | ListCommands deriving (Eq, Show)++rootActions :: PrimDarcsOption (Maybe RootAction)+rootActions = withDefault Nothing+ [ RawNoArg ['h'] ["help", "overview"] F.Help (Just RootHelp)+ "show a brief description of all darcs commands and top-level options"+ , RawNoArg ['v'] ["version"] F.Version (Just Version) "show the darcs version"+ , RawNoArg [] ["exact-version"] F.ExactVersion (Just ExactVersion)+ "show the exact darcs version"+ -- the switch --commands is here for compatibility only+ , RawNoArg [] ["commands","list-options"] F.ListCommands (Just ListCommands)+ "show plain list of available options and commands, for auto-completion"+ ]++-- * Common to all commands++-- ** Standard command actions++data StdCmdAction = Help | ListOptions | Disable deriving (Eq, Show)++stdCmdActions :: PrimDarcsOption (Maybe StdCmdAction)+stdCmdActions = withDefault Nothing+ [ RawNoArg [] ["help"] F.Help (Just Help)+ "show a brief description of the command and its options"+ , RawNoArg [] ["list-options"] F.ListOptions (Just ListOptions)+ "show plain list of available options and commands, for auto-completion"+ , RawNoArg [] ["disable"] F.Disable (Just Disable) "disable this command" ]++-- ** Verbosity related++debug :: PrimDarcsOption Bool+debug = singleNoArg [] ["debug"] F.Debug "give only debug output"++debugHttp :: PrimDarcsOption Bool+debugHttp = singleNoArg [] ["debug-http"] F.DebugHTTP "debug output from libcurl"++verbosity :: PrimDarcsOption Verbosity+verbosity = withDefault NormalVerbosity+ [ RawNoArg ['q'] ["quiet"] F.Quiet Quiet "suppress informational output"+ , RawNoArg [] ["standard-verbosity"] F.NormalVerbosity NormalVerbosity+ "neither verbose nor quiet output"+ , RawNoArg ['v'] ["verbose"] F.Verbose Verbose "give verbose output" ]++timings :: PrimDarcsOption Bool+timings = singleNoArg [] ["timings"] F.Timings "provide debugging timings information"++anyVerbosity :: DarcsOption a (Bool -> Bool -> Verbosity -> Bool -> a)+anyVerbosity = debug ^ debugHttp ^ verbosity ^ timings where++-- ** Hooks++hooks :: DarcsOption a (Maybe String -> Bool -> Maybe String -> Bool -> a)+hooks = preHook ^ postHook++preHook :: DarcsOption a (Maybe String -> Bool -> a)+preHook = prehookCmd ^ hookPrompt "prehook" F.AskPrehook F.RunPrehook++postHook :: DarcsOption a (Maybe String -> Bool -> a)+postHook = posthookCmd ^ hookPrompt "posthook" F.AskPosthook F.RunPosthook++prehookCmd :: PrimDarcsOption (Maybe String)+prehookCmd = withDefault Nothing+ [ RawStrArg [] ["prehook"] F.PrehookCmd unF Just unV+ "COMMAND" "specify command to run before this darcs command"+ , RawNoArg [] ["no-prehook"] F.NoPrehook Nothing+ "don't run prehook command" ]+ where unF f = [ s | F.PrehookCmd s <- [f] ]+ unV v = [ s | Just s <- [v] ]++posthookCmd :: PrimDarcsOption (Maybe String)+posthookCmd = withDefault Nothing+ [ RawStrArg [] ["posthook"] F.PosthookCmd unF Just unV "COMMAND"+ "specify command to run after this darcs command"+ , RawNoArg [] ["no-posthook"] F.NoPosthook Nothing+ "don't run posthook command" ]+ where unF f = [ s | F.PosthookCmd s <- [f] ]+ unV v = [ s | Just s <- [v] ]++hookPrompt :: String -> Flag -> Flag -> PrimDarcsOption Bool+hookPrompt name fask frun = withDefault False+ [ RawNoArg [] ["prompt-"++name] fask True+ ("prompt before running "++name)+ , RawNoArg [] ["run-"++name] frun False+ ("run "++name++" command without prompting") ]++-- ** Misc++useCache :: PrimDarcsOption UseCache+useCache = (imap . cps) (Iso fw bw) $ singleNoArg [] ["no-cache"] F.NoCache "don't use patch caches"+ where+ fw True = NoUseCache+ fw False = YesUseCache+ bw NoUseCache = True+ bw YesUseCache = False++-- * Interactivity related++{- TODO: these options interact (no pun intended) in complex ways that are+very hard to figure out for users as well as maintainers. I think the only+solution here is a more radical (and probably incompatible) re-design+involving all interactivity related options. That is beyond the goals of+this sub-project (which is already large enough).+-}++data XmlOutput = NoXml | YesXml deriving (Eq, Show)++xmloutput :: PrimDarcsOption XmlOutput+xmloutput = withDefault NoXml [__xmloutput YesXml]++__xmloutput :: RawDarcsOption+__xmloutput val = RawNoArg [] ["xml-output"] F.XMLOutput val "generate XML formatted output"++-- | NOTE: I'd rather work to have no uses of dryRunNoxml, so that any time+-- --dry-run is a possibility, automated users can examine the results more+-- easily with --xml.+--+-- See also issue2397.+dryRun :: PrimDarcsOption DryRun+dryRun = (imap . cps) (Iso fw bw) $ singleNoArg [] ["dry-run"] F.DryRun "don't actually take the action"+ where+ fw True = YesDryRun+ fw False = NoDryRun+ bw YesDryRun = True+ bw NoDryRun = False++dryRunXml :: DarcsOption a (DryRun -> XmlOutput -> a)+dryRunXml = dryRun ^ xmloutput++__dryrun :: RawDarcsOption+__dryrun val = RawNoArg [] ["dry-run"] F.DryRun val "don't actually take the action"++pipe :: PrimDarcsOption Bool+pipe = singleNoArg [] ["pipe"] F.Pipe "ask user interactively for the patch metadata"++interactive :: PrimDarcsOption (Maybe Bool)+interactive = withDefault Nothing+ [ RawNoArg ['a'] ["all","no-interactive"] F.All (Just False) "answer yes to all patches"+ , RawNoArg ['i'] ["interactive"] F.Interactive (Just True) "prompt user interactively" ]++pauseForGui :: PrimDarcsOption WantGuiPause+pauseForGui = withDefault YesWantGuiPause+ [ RawNoArg [] ["pause-for-gui"] F.PauseForGui YesWantGuiPause+ "pause for an external diff or merge command to finish"+ , RawNoArg [] ["no-pause-for-gui"] F.NoPauseForGui NoWantGuiPause+ "return immediately after external diff or merge command finishes" ]++askdeps :: PrimDarcsOption Bool+askdeps = withDefault False+ [ RawNoArg [] ["ask-deps"] F.AskDeps True "manually select dependencies"+ , RawNoArg [] ["no-ask-deps"] F.NoAskDeps False "automatically select dependencies" ]++-- * Patch selection related++data SelectDeps = NoDeps | AutoDeps | PromptDeps deriving (Eq, Show)++selectDeps :: PrimDarcsOption SelectDeps+selectDeps = withDefault PromptDeps+ [ RawNoArg [] ["no-deps"] F.DontGrabDeps NoDeps+ "don't automatically fulfill dependencies"+ , RawNoArg [] ["auto-deps","dont-prompt-for-dependencies"] F.DontPromptForDependencies AutoDeps+ "don't ask about patches that are depended on by matched patches (with --match or --patch)"+ , RawNoArg [] ["prompt-deps","prompt-for-dependencies"] F.PromptForDependencies PromptDeps+ "prompt about patches that are depended on by matched patches" ]++changesReverse :: PrimDarcsOption Bool+changesReverse = withDefault False+ [ RawNoArg [] ["reverse"] F.Reverse True "show/consider changes in reverse order"+ , RawNoArg [] ["no-reverse"] F.Forward False "show/consider changes in the usual order" ]++-- | TODO: Returning @-1@ if the argument cannot be parsed as an integer is+-- not something I expected to find in a Haskell program. Instead, the flag+-- should take either a plain 'String' argument (leaving it to a later stage+-- to parse the 'String' to an 'Int'), or else a @'Maybe' 'Int'@, taking+-- the possibility of a failed parse into account.+matchMaxcount :: PrimDarcsOption (Maybe Int)+matchMaxcount = OptSpec {..} where+ ounparse k (Just n) = k [ F.MaxCount n ]+ ounparse k Nothing = k []+ oparse k fs = k $ listToMaybe [ s | F.MaxCount s <- fs ]+ ocheck fs = case [ "--max-count="++show n | F.MaxCount n <- fs ] of+ cfs@(_:_:_) -> ["conflicting flags: " ++ intercalate ", " cfs]+ _ -> []+ odesc = [ strArg [] ["max-count"] (F.MaxCount . toInt) "NUMBER"+ "return only NUMBER results" ]+ toInt s = if not (null s) && all isDigit s then read s else (-1)++-- * Local or remote repo++workRepo :: PrimDarcsOption WorkRepo+workRepo = imap (Iso fw bw) $ workingRepoDir ^ possiblyRemoteRepo where+ fw k (WorkRepoDir s) = k (Just s) Nothing+ fw k (WorkRepoPossibleURL s) = k Nothing (Just s)+ fw k WorkRepoCurrentDir = k Nothing Nothing+ bw k (Just s) _ = k (WorkRepoDir s)+ bw k Nothing (Just s) = k (WorkRepoPossibleURL s)+ bw k Nothing Nothing = k WorkRepoCurrentDir++workingRepoDir :: PrimDarcsOption (Maybe String)+workingRepoDir = singleStrArg [] ["repodir"] F.WorkRepoDir arg "DIRECTORY"+ "specify the repository directory in which to run"+ where arg (F.WorkRepoDir s) = Just s+ arg _ = Nothing++-- | @--repodir@ is there for compatibility, should be removed eventually+--+-- IMHO the whole option can disappear; it overlaps with using an extra (non-option)+-- argument, which is how e.g. @darcs get@ is usually invoked.+reponame :: PrimDarcsOption (Maybe String)+reponame = singleStrArg [] ["repo-name","repodir"] F.NewRepo arg "DIRECTORY" "path of output directory"+ where arg (F.NewRepo s) = Just s; arg _ = Nothing++possiblyRemoteRepo :: PrimDarcsOption (Maybe String)+possiblyRemoteRepo = singleStrArg [] ["repo"] F.WorkRepoUrl arg "URL"+ "specify the repository URL"+ where arg (F.WorkRepoUrl s) = Just s+ arg _ = Nothing++remoteRepos :: PrimDarcsOption RemoteRepos+remoteRepos = (imap . cps) (Iso fw bw) $ multiStrArg [] ["remote-repo"] F.RemoteRepo mkV "URL"+ "specify the remote repository URL to work with"+ where mkV fs = [ s | F.RemoteRepo s <- fs ]+ fw ss = RemoteRepos ss+ bw (RemoteRepos ss) = ss++notInRemoteFlagName :: String+notInRemoteFlagName = "not-in-remote"++notInRemote :: PrimDarcsOption [Maybe String]+notInRemote =+ multiOptStrArg [] [notInRemoteFlagName] F.NotInRemote args "URL/PATH" $+ "select all patches not in the default push/pull repository or at "+ ++ "location URL/PATH"+ where+ args fs = [s | F.NotInRemote s <- fs]++data RepoCombinator = Intersection | Union | Complement deriving (Eq, Show)++repoCombinator :: PrimDarcsOption RepoCombinator+repoCombinator = withDefault Union+ [ RawNoArg [] ["intersection"] F.Intersection Intersection+ "take intersection of all repositories"+ , RawNoArg [] ["union"] F.Union Union+ "take union of all repositories"+ , RawNoArg [] ["complement"] F.Complement Complement+ "take complement of repositories (in order listed)" ]++allowUnrelatedRepos :: PrimDarcsOption Bool+allowUnrelatedRepos = singleNoArg [] ["ignore-unrelated-repos"] F.AllowUnrelatedRepos+ "do not check if repositories are unrelated"++justThisRepo :: PrimDarcsOption Bool+justThisRepo = singleNoArg [] ["just-this-repo"] F.JustThisRepo+ "Limit the check or repair to the current repo"++-- | convert, clone, init+useWorkingDir :: PrimDarcsOption WithWorkingDir+useWorkingDir = withDefault WithWorkingDir+ [ RawNoArg [] ["with-working-dir"] F.UseWorkingDir WithWorkingDir+ "Create a working directory (normal repository)"+ , RawNoArg [] ["no-working-dir"] F.UseNoWorkingDir NoWorkingDir+ "Do not create a working directory (bare repository)" ]++setDefault :: PrimDarcsOption (Maybe Bool)+setDefault = withDefault Nothing+ [ RawNoArg [] ["set-default"] F.SetDefault (Just True) "set default repository"+ , RawNoArg [] ["no-set-default"] F.NoSetDefault (Just False) "don't set default repository" ]++-- * Specifying patch meta-data++patchname :: PrimDarcsOption (Maybe String)+patchname = singleStrArg ['m'] ["name"] F.PatchName arg "PATCHNAME"+ "name of patch"+ where arg (F.PatchName s) = Just s+ arg _ = Nothing++author :: PrimDarcsOption (Maybe String)+author = singleStrArg ['A'] ["author"] F.Author arg+ "EMAIL" "specify author id"+ where arg (F.Author s) = Just s+ arg _ = Nothing++data AskLongComment = NoEditLongComment | YesEditLongComment | PromptLongComment+ deriving (Eq, Show)++-- TODO: fix non-default behavior+askLongComment :: PrimDarcsOption (Maybe AskLongComment)+askLongComment = withDefault Nothing+ [ RawNoArg [] ["edit-long-comment"] F.EditLongComment (Just YesEditLongComment)+ "edit the long comment by default"+ , RawNoArg [] ["skip-long-comment"] F.NoEditLongComment (Just NoEditLongComment)+ "don't give a long comment"+ , RawNoArg [] ["prompt-long-comment"] F.PromptLongComment (Just PromptLongComment)+ "prompt for whether to edit the long comment" ]++keepDate :: PrimDarcsOption Bool+keepDate = withDefault False+ [ RawNoArg [] ["keep-date"] F.KeepDate True+ "keep the date of the original patch"+ , RawNoArg [] ["no-keep-date"] F.NoKeepDate False+ "use the current date for the amended patch" ]++-- record, send+data Logfile = Logfile+ { _logfile :: Maybe AbsolutePath+ , _rmlogfile :: Bool+ }++logfile :: PrimDarcsOption Logfile+logfile = imap (Iso fw bw) (__logfile ^ __rmlogfile) where+ fw k (Logfile x y) = k x y+ bw k x y = k (Logfile x y)++__logfile :: PrimDarcsOption (Maybe AbsolutePath)+__logfile = singleAbsPathArg [] ["logfile"] F.LogFile arg "FILE"+ "give patch name and comment in file"+ where arg (F.LogFile s) = Just s+ arg _ = Nothing++__rmlogfile :: PrimDarcsOption Bool+__rmlogfile = withDefault False+ [ RawNoArg [] ["delete-logfile"] F.RmLogFile True+ "delete the logfile when done"+ , RawNoArg [] ["no-delete-logfile"] F.DontRmLogFile False+ "keep the logfile when done" ]++-- * Looking for changes++data LookFor = LookFor+ { adds :: LookForAdds+ , replaces :: LookForReplaces+ , moves :: LookForMoves+ }++lookfor :: PrimDarcsOption LookFor+lookfor = imap (Iso fw bw) (lookforadds ^ lookforreplaces ^ lookformoves) where+ fw k (LookFor a r m) = k a r m+ bw k a r m = k (LookFor a r m)++lookforadds :: PrimDarcsOption LookForAdds+lookforadds = withDefault NoLookForAdds+ [ RawNoArg ['l'] ["look-for-adds"] F.LookForAdds YesLookForAdds+ "look for (non-boring) files that could be added"+ , RawNoArg [] ["dont-look-for-adds","no-look-for-adds"] F.NoLookForAdds NoLookForAdds+ "don't look for any files that could be added" ]++lookforreplaces :: PrimDarcsOption LookForReplaces+lookforreplaces = withDefault NoLookForReplaces+ [ RawNoArg [] ["look-for-replaces"] F.LookForReplaces YesLookForReplaces+ "look for replaces that could be marked"+ , RawNoArg [] ["dont-look-for-replaces","no-look-for-replaces"]+ F.NoLookForReplaces NoLookForReplaces+ "don't look for any replaces" ]++lookformoves :: PrimDarcsOption LookForMoves+lookformoves = withDefault NoLookForMoves+ [ RawNoArg [] ["look-for-moves"] F.LookForMoves YesLookForMoves+ "look for files that may be moved/renamed"+ , RawNoArg [] ["dont-look-for-moves","no-look-for-moves"]+ F.NoLookForMoves NoLookForMoves+ "don't look for any files that could be moved/renamed" ]++-- * Files to consider++diffing :: PrimDarcsOption (UseIndex, ScanKnown, DiffAlgorithm)+diffing = imap (Iso curry3 uncurry3) $ useIndex ^ scanKnown ^ diffAlgorithm+ where+ uncurry3 k x y z = k (x,y,z)+ curry3 k (x,y,z) = k x y z++useIndex :: PrimDarcsOption UseIndex+useIndex = (imap . cps) (Iso fw bw) ignoreTimes where+ fw False = UseIndex+ fw True = IgnoreIndex+ bw UseIndex = False+ bw IgnoreIndex = True++scanKnown :: PrimDarcsOption ScanKnown+scanKnown = imap (Iso fw bw) $ lookforadds ^ includeBoring where+ fw k ScanKnown = k NoLookForAdds False+ fw k ScanAll = k YesLookForAdds False+ fw k ScanBoring = k YesLookForAdds True+ bw k NoLookForAdds _ = k ScanKnown+ bw k YesLookForAdds False = k ScanAll+ bw k YesLookForAdds True = k ScanBoring++includeBoring :: PrimDarcsOption Bool+includeBoring = withDefault False+ [ RawNoArg [] ["boring"] F.Boring True "don't skip boring files"+ , RawNoArg [] ["no-boring"] F.SkipBoring False "skip boring files" ]++allowProblematicFilenames :: DarcsOption a (Bool -> Bool -> a)+allowProblematicFilenames = allowCaseDifferingFilenames ^ allowWindowsReservedFilenames++allowCaseDifferingFilenames :: PrimDarcsOption Bool+allowCaseDifferingFilenames = withDefault False+ [ RawNoArg [] ["case-ok"] F.AllowCaseOnly True+ "don't refuse to add files differing only in case"+ , RawNoArg [] ["no-case-ok"] F.DontAllowCaseOnly False+ "refuse to add files whose name differ only in case" ]++allowWindowsReservedFilenames :: PrimDarcsOption Bool+allowWindowsReservedFilenames = withDefault False+ [ RawNoArg [] ["reserved-ok"] F.AllowWindowsReserved True+ "don't refuse to add files with Windows-reserved names"+ , RawNoArg [] ["no-reserved-ok"] F.DontAllowWindowsReserved False+ "refuse to add files with Windows-reserved names" ]++-- | TODO: see issue2395+onlyToFiles :: PrimDarcsOption Bool+onlyToFiles = withDefault False+ [ RawNoArg [] ["only-to-files"] F.OnlyChangesToFiles True+ "show only changes to specified files"+ , RawNoArg [] ["no-only-to-files"] F.ChangesToAllFiles False+ "show changes to all files" ]++ignoreTimes :: PrimDarcsOption Bool+ignoreTimes = withDefault False+ [ RawNoArg [] ["ignore-times"] F.IgnoreTimes True+ "don't trust the file modification times"+ , RawNoArg [] ["no-ignore-times"] F.DontIgnoreTimes False+ "trust modification times to find modified files" ]++recursive :: PrimDarcsOption Bool+recursive = withDefault False+ [ RawNoArg ['r'] ["recursive"] F.Recursive True "recurse into subdirectories"+ , RawNoArg [] ["not-recursive","no-recursive"] F.NoRecursive False ("don't recurse into subdirectories") ]++-- * Differences++diffAlgorithm :: PrimDarcsOption DiffAlgorithm+diffAlgorithm = withDefault PatienceDiff+ [ RawNoArg [] ["myers"] F.UseMyersDiff MyersDiff+ "use myers diff algorithm"+ , RawNoArg [] ["patience"] F.UsePatienceDiff PatienceDiff+ "use patience diff algorithm" ]++data WithContext = NoContext | YesContext deriving (Eq, Show)++withContext :: PrimDarcsOption WithContext+withContext = (imap . cps) (Iso fw bw) $ withDefault False+ [ RawNoArg ['u'] ["unified"] F.Unified True+ "output changes in a darcs-specific format similar to diff -u"+ , RawNoArg [] ["no-unified"] F.NonUnified False+ "output changes in darcs' usual format" ]+ where fw False = NoContext+ fw True = YesContext+ bw NoContext = False+ bw YesContext = True++unidiff :: PrimDarcsOption Bool+unidiff = withDefault True+ [ RawNoArg ['u'] ["unified"] F.Unified True "pass -u option to diff"+ , RawNoArg [] ["no-unified"] F.NonUnified False "output patch in diff's dumb format" ]++data ExternalDiff = ExternalDiff { _diffCmd :: Maybe String, _diffOpts :: [String] } deriving (Eq, Show)++extDiff :: PrimDarcsOption ExternalDiff+extDiff = imap (Iso fw bw) $ extDiffCmd ^ extDiffOpts where+ fw k (ExternalDiff cmd opts) = k cmd opts+ bw k cmd opts = k (ExternalDiff cmd opts)++extDiffCmd :: PrimDarcsOption (Maybe String)+extDiffCmd = singleStrArg [] ["diff-command"] F.DiffCmd arg "COMMAND"+ "specify diff command (ignores --diff-opts)"+ where arg (F.DiffCmd s) = Just s+ arg _ = Nothing++extDiffOpts :: PrimDarcsOption [String]+extDiffOpts = multiStrArg [] ["diff-opts"] F.DiffFlags mkV "OPTIONS"+ "options to pass to diff"+ where mkV fs = [ s | F.DiffFlags s <- fs ]++-- * Runnign tests++data TestChanges = NoTestChanges | YesTestChanges LeaveTestDir deriving (Eq)++testChanges :: PrimDarcsOption TestChanges+testChanges = imap (Iso fw bw) $ test ^ leaveTestDir where+ fw k NoTestChanges = k NoRunTest {- undefined -} YesLeaveTestDir+ fw k (YesTestChanges ltd) = k YesRunTest ltd+ bw k NoRunTest _ = k NoTestChanges+ bw k YesRunTest ltd = k (YesTestChanges ltd)++test :: PrimDarcsOption RunTest+test = withDefault NoRunTest+ [ RawNoArg [] ["test"] F.Test YesRunTest "run the test script"+ , RawNoArg [] ["no-test"] F.NoTest NoRunTest "don't run the test script" ]++leaveTestDir :: PrimDarcsOption LeaveTestDir+leaveTestDir = withDefault YesLeaveTestDir+ [ RawNoArg [] ["leave-test-directory"]+ F.LeaveTestDir YesLeaveTestDir "don't remove the test directory"+ , RawNoArg [] ["remove-test-directory"]+ F.NoLeaveTestDir NoLeaveTestDir "remove the test directory" ]++-- * Mail related++data HeaderFields = HeaderFields+ { _to, _cc :: [String]+ , _from, _subject, _inReplyTo :: Maybe String+ }++headerFields :: PrimDarcsOption HeaderFields+headerFields = imap (Iso fw bw) $ to ^ cc ^ from ^ subject ^ inReplyTo where+ fw k (HeaderFields t f c s i) = k t f c s i+ bw k t f c s i = k (HeaderFields t f c s i)++from :: PrimDarcsOption (Maybe String)+from = singleStrArg [] ["from"] F.Author arg+ "EMAIL" "specify email address"+ where arg (F.Author s) = Just s+ arg _ = Nothing++to :: PrimDarcsOption [String]+to = multiStrArg [] ["to"] F.Target mkV "EMAIL" "specify destination email"+ where mkV fs = [ s | F.Target s <- fs ]++cc :: PrimDarcsOption [String]+cc = multiStrArg [] ["cc"] F.Cc mkV "EMAIL" "mail results to additional EMAIL(s)"+ where mkV fs = [ s | F.Cc s <- fs ]++subject :: PrimDarcsOption (Maybe String)+subject = singleStrArg [] ["subject"] F.Subject arg+ "SUBJECT" "specify mail subject"+ where arg (F.Subject s) = Just s+ arg _ = Nothing++inReplyTo :: PrimDarcsOption (Maybe String)+inReplyTo = singleStrArg [] ["in-reply-to"] F.InReplyTo arg+ "EMAIL" "specify in-reply-to header"+ where arg (F.InReplyTo s) = Just s+ arg _ = Nothing++sendToContext :: PrimDarcsOption (Maybe AbsolutePath)+sendToContext = singleAbsPathArg [] ["context"] F.Context arg "FILENAME"+ "send to context stored in FILENAME"+ where arg (F.Context s) = Just s+ arg _ = Nothing++-- TODO: do something about the nonsensical case (False, Just s)+--+-- Some of the tests actually do this (pass --sendmail-command without+-- passing --mail) and it's unclear if it's deliberate or just a historical+-- accident after the issue2204 changes. We should untangle that and+-- perhaps turn this into a single option with an optional argument.+-- The other question to resolve is the interaction with the 'output'+-- options to darcs send.+sendmailIso :: Iso (Bool -> Maybe String -> a) ((Bool, Maybe String) -> a)+sendmailIso = Iso uncurry curry++sendmail :: PrimDarcsOption (Bool, Maybe String)+sendmail = imap sendmailIso $ mail ^ sendmailCmd++mail :: PrimDarcsOption Bool+mail = singleNoArg [] ["mail"] F.Mail "send patch using sendmail"++sendmailCmd :: PrimDarcsOption (Maybe String)+sendmailCmd = singleStrArg [] ["sendmail-command"] F.SendmailCmd arg "COMMAND"+ "specify sendmail command"+ where arg (F.SendmailCmd s) = Just s+ arg _ = Nothing++minimize :: PrimDarcsOption Bool+minimize = withDefault True+ [ RawNoArg [] ["minimize"] F.Minimize True "minimize context of patch bundle"+ , RawNoArg [] ["no-minimize"] F.NoMinimize False ("don't minimize context of patch bundle") ]++charset :: PrimDarcsOption (Maybe String)+charset = singleStrArg [] ["charset"] F.Charset arg+ "CHARSET" "specify mail charset"+ where arg (F.Charset s) = Just s+ arg _ = Nothing++editDescription :: PrimDarcsOption Bool+editDescription = withDefault True+ [ RawNoArg [] ["edit-description"] F.EditDescription True+ "edit the patch bundle description"+ , RawNoArg [] ["dont-edit-description","no-edit-description"] F.NoEditDescription False+ "don't edit the patch bundle description" ]++-- TODO: turn these two into a combined option++ccApply :: PrimDarcsOption (Maybe String)+ccApply = singleStrArg [] ["cc"] F.Cc arg+ "EMAIL" "mail results to additional EMAIL(s). Requires --reply"+ where arg (F.Cc s) = Just s+ arg _ = Nothing++reply :: PrimDarcsOption (Maybe String)+reply = singleStrArg [] ["reply"] F.Reply arg "FROM"+ "reply to email-based patch using FROM address"+ where arg (F.Reply s) = Just s+ arg _ = Nothing++happyForwarding :: PrimDarcsOption Bool+happyForwarding = withDefault False+ [ RawNoArg [] ["happy-forwarding"] F.HappyForwarding True+ "forward unsigned messages without extra header"+ , RawNoArg [] ["no-happy-forwarding"] F.NoHappyForwarding False+ "don't forward unsigned messages without extra header" ]++-- * Patch bundle related++applyAs :: PrimDarcsOption (Maybe String)+applyAs = withDefault Nothing+ [ RawStrArg [] ["apply-as"] F.ApplyAs unF Just unV "USERNAME"+ "apply patch as another user using sudo"+ , RawNoArg [] ["no-apply-as"] F.NonApply Nothing+ "don't use sudo to apply as another user" ]+ where+ unF f = [ s | F.ApplyAs s <- [f] ]+ unV x = [ s | Just s <- [x] ]++data Sign = NoSign | Sign | SignAs String | SignSSL String deriving (Eq, Show)++sign :: PrimDarcsOption Sign+sign = withDefault NoSign+ [ RawNoArg [] ["sign"] F.Sign Sign "sign the patch with your gpg key"+ , RawStrArg [] ["sign-as"] F.SignAs unFSignAs SignAs unSignAs "KEYID"+ "sign the patch with a given keyid"+ , RawStrArg [] ["sign-ssl"] F.SignSSL unFSignSSL SignSSL unSignSSL "IDFILE"+ "sign the patch using openssl with a given private key"+ , RawNoArg [] ["dont-sign","no-sign"] F.NoSign NoSign "don't sign the patch" ]+ where unFSignAs f = [ s | F.SignAs s <- [f] ]+ unSignAs v = [ s | SignAs s <- [v] ]+ unFSignSSL f = [ s | F.SignSSL s <- [f] ]+ unSignSSL v = [ s | SignSSL s <- [v] ]++data Verify = NoVerify | VerifyKeyring AbsolutePath | VerifySSL AbsolutePath deriving (Eq, Show)++verify :: PrimDarcsOption Verify+verify = withDefault NoVerify+ [ RawAbsPathArg [] ["verify"] F.Verify unFKeyring VerifyKeyring unVKeyring "PUBRING"+ "verify that the patch was signed by a key in PUBRING"+ , RawAbsPathArg [] ["verify-ssl"] F.VerifySSL unFSSL VerifySSL unVSSL "KEYS"+ "verify using openSSL with authorized keys from file KEYS"+ , RawNoArg [] ["no-verify"] F.NonVerify NoVerify+ "don't verify patch signature" ]+ where+ unFKeyring f = [ s | F.Verify s <- [f] ]+ unVKeyring x = [ s | VerifyKeyring s <- [x] ]+ unFSSL f = [ s | F.VerifySSL s <- [f] ]+ unVSSL x = [ s | VerifySSL s <- [x] ]++-- * Merging patches++-- applyConflictOptions = conflicts NoAllowConflicts+-- pullConflictOptions = conflicts YesAllowConflictsAndMark++conflicts :: AllowConflicts -> PrimDarcsOption (Maybe AllowConflicts)+conflicts def = withDefault (Just def)+ [ RawNoArg [] ["mark-conflicts"]+ F.MarkConflicts (Just YesAllowConflictsAndMark) "mark conflicts"+ , RawNoArg [] ["allow-conflicts"]+ F.AllowConflicts (Just YesAllowConflicts) "allow conflicts, but don't mark them"+-- , RawNoArg [] ["no-resolve-conflicts"]+-- NoAllowConflicts "equivalent to --dont-allow-conflicts, for backwards compatibility"+ , RawNoArg [] ["dont-allow-conflicts","no-allow-conflicts","no-resolve-conflicts"]+ F.NoAllowConflicts (Just NoAllowConflicts) "fail if there are patches that would create conflicts"+ , RawNoArg [] ["skip-conflicts"]+ F.SkipConflicts Nothing "filter out any patches that would create conflicts" ]++-- Technically not an isomorphism, see 'sendmailIso'.+useExternalMerge :: PrimDarcsOption ExternalMerge+useExternalMerge = imap (Iso fw bw) $ singleStrArg [] ["external-merge"] F.ExternalMerge arg+ "COMMAND" "use external tool to merge conflicts"+ where+ arg (F.ExternalMerge s) = Just s+ arg _ = Nothing+ bw k (Just s) = k (YesExternalMerge s)+ bw k Nothing = k NoExternalMerge+ fw k (YesExternalMerge s) = k (Just s)+ fw k NoExternalMerge = k Nothing++-- * Optimizations++compress :: PrimDarcsOption Compression+compress = withDefault GzipCompression+ [ RawNoArg [] ["compress"] F.Compress GzipCompression "compress patch data"+ , RawNoArg [] ["dont-compress","no-compress"] F.NoCompress NoCompression "don't compress patch data" ]++usePacks :: PrimDarcsOption Bool+usePacks = withDefault True+ [ RawNoArg [] ["packs"] F.Packs True "use repository packs"+ , RawNoArg [] ["no-packs"] F.NoPacks False "don't use repository packs" ]++-- for init, clone and convert: patch index disabled by default+patchIndex :: PrimDarcsOption WithPatchIndex+patchIndex = withDefault NoPatchIndex [__patchIndex YesPatchIndex, __noPatchIndex NoPatchIndex]++-- for log and annotate: patch index enabled by default+patchIndexYes :: PrimDarcsOption WithPatchIndex+patchIndexYes = withDefault YesPatchIndex [__patchIndex YesPatchIndex, __noPatchIndex NoPatchIndex]++__patchIndex, __noPatchIndex :: RawDarcsOption+__patchIndex val = RawNoArg [] ["with-patch-index"] F.PatchIndexFlag val "build patch index"+__noPatchIndex val = RawNoArg [] ["no-patch-index"] F.NoPatchIndexFlag val "don't build patch index"++-- diff, dist+storeInMemory :: PrimDarcsOption Bool+storeInMemory = withDefault False+ [ RawNoArg [] ["store-in-memory"] F.StoreInMemory True+ "do patch application in memory rather than on disk"+ , RawNoArg [] ["no-store-in-memory"] F.ApplyOnDisk False+ "do patch application on disk" ]++-- * Output++data Output = Output AbsolutePathOrStd+ | OutputAutoName AbsolutePath+ deriving (Eq, Show)++output :: PrimDarcsOption (Maybe Output)+output = withDefault Nothing+ [ RawAbsPathOrStdArg ['o'] ["output"]+ F.Output unOutputF (Just . Output) unOutput+ "FILE" "specify output filename"+ , RawOptAbsPathArg ['O'] ["output-auto-name"]+ F.OutputAutoName unOutputAutoNameF (Just . OutputAutoName) unOutputAutoName+ "." "DIRECTORY"+ "output to automatically named file in DIRECTORY, default: current directory"+ ]+ where+ unOutputF f = [ p | F.Output p <- [f] ]+ unOutput (Just (Output p)) = [p]+ unOutput _ = []+ unOutputAutoNameF f = [ p | F.OutputAutoName p <- [f] ]+ unOutputAutoName (Just (OutputAutoName p)) = [p]+ unOutputAutoName _ = []++-- * Miscellaneous++data Summary = NoSummary | YesSummary deriving (Eq, Show)++summary :: PrimDarcsOption (Maybe Summary)+summary = withDefault Nothing+ [ RawNoArg ['s'] ["summary"] F.Summary (Just YesSummary) "summarize changes"+ , RawNoArg [] ["no-summary"] F.NoSummary (Just NoSummary) "don't summarize changes" ]++-- | TODO: reconsider this grouping of options+data NetworkOptions = NetworkOptions+ { noHttpPipelining :: Bool+ , remoteDarcs :: RemoteDarcs }++networkIso :: Iso (Bool -> Maybe String -> a) (NetworkOptions -> a)+networkIso = Iso fw bw where+ fw k (NetworkOptions x (RemoteDarcs y)) = k x (Just y)+ fw k (NetworkOptions x DefaultRemoteDarcs) = k x Nothing+ bw k x (Just y) = k (NetworkOptions x (RemoteDarcs y))+ bw k x Nothing = k (NetworkOptions x DefaultRemoteDarcs)++network :: PrimDarcsOption NetworkOptions+network = imap networkIso+ $ singleNoArg [] ["no-http-pipelining"] F.NoHTTPPipelining "disable HTTP pipelining"+ ^ singleStrArg [] ["remote-darcs"] F.RemoteDarcsOpt arg "COMMAND"+ "name of the darcs executable on the remote server"+ where arg (F.RemoteDarcsOpt s) = Just s+ arg _ = Nothing++umask :: PrimDarcsOption UMask+umask = (imap . cps) (Iso fw bw) $ singleStrArg [] ["umask"] F.UMask arg "UMASK"+ "specify umask to use when writing"+ where+ arg (F.UMask s) = Just s+ arg _ = Nothing+ fw (Just s) = YesUMask s+ fw Nothing = NoUMask+ bw (YesUMask s) = Just s+ bw NoUMask = Nothing++setScriptsExecutable :: PrimDarcsOption SetScriptsExecutable+setScriptsExecutable = withDefault NoSetScriptsExecutable+ [ RawNoArg [] ["set-scripts-executable"] F.SetScriptsExecutable YesSetScriptsExecutable+ "make scripts executable"+ , RawNoArg [] ["dont-set-scripts-executable","no-set-scripts-executable"]+ F.DontSetScriptsExecutable NoSetScriptsExecutable "don't make scripts executable" ]++restrictPaths :: PrimDarcsOption Bool+restrictPaths = withDefault True+ [ RawNoArg [] ["restrict-paths"] F.RestrictPaths True+ "don't allow darcs to touch external files or repo metadata"+ , RawNoArg [] ["dont-restrict-paths","no-restrict-paths"]+ F.DontRestrictPaths False+ "allow darcs to modify any file or directory (unsafe)" ]++-- * Specific to a single command++-- ** amend++amendUnrecord :: PrimDarcsOption Bool+amendUnrecord = withDefault False+ [ RawNoArg [] ["unrecord"] F.AmendUnrecord True "remove changes from the patch"+ , RawNoArg [] ["record"] F.NoAmendUnrecord False "add more changes to the patch" ]++selectAuthor :: PrimDarcsOption Bool+selectAuthor = singleNoArg [] ["select-author"] F.SelectAuthor+ "select author id from a menu"++-- ** annotate++-- | TODO: These should be mutually exclusive, but are they? The code is almost inscrutable.+humanReadable :: PrimDarcsOption Bool+humanReadable = withDefault False [__humanReadable True]++__humanReadable :: RawDarcsOption+__humanReadable val = RawNoArg [] ["human-readable"] F.HumanReadable val "give human-readable output"++-- | See above.+machineReadable :: PrimDarcsOption Bool+machineReadable = singleNoArg [] ["machine-readable"] F.MachineReadable "give machine-readable output"++-- ** clone++partial :: PrimDarcsOption CloneKind+partial = withDefault NormalClone+ [ RawNoArg [] ["lazy"] F.Lazy LazyClone "get patch files only as needed"+ , RawNoArg [] ["complete"] F.Complete CompleteClone "get a complete copy of the repository" ]++-- ** convert import/export++marks :: DarcsOption a (Maybe String -> Maybe String -> a)+marks = readMarks ^ writeMarks++readMarks :: PrimDarcsOption (Maybe String)+readMarks = singleStrArg [] ["read-marks"] F.ReadMarks arg+ "FILE" "continue conversion, previously checkpointed by --write-marks"+ where arg (F.ReadMarks s) = Just s+ arg _ = Nothing++writeMarks :: PrimDarcsOption (Maybe String)+writeMarks = singleStrArg [] ["write-marks"] F.WriteMarks arg+ "FILE" "checkpoint conversion to continue it later"+ where arg (F.WriteMarks s) = Just s+ arg _ = Nothing++-- | Deprecated flag, still present to output an error message.+hashed :: PrimDarcsOption ()+hashed = deprecated+ [ "All repositories are now \"hashed\", so this option was removed."+ , "Use --darcs-1 to get the effect that --hashed had previously." ] $+ [ RawNoArg [] ["hashed"] F.Hashed () "deprecated, use --darcs-1 instead" ]++data PatchFormat = PatchFormat1 | PatchFormat2 deriving (Eq, Show)++patchFormat :: PrimDarcsOption PatchFormat+patchFormat = withDefault PatchFormat2+ [ RawNoArg [] ["darcs-2"] F.UseFormat2 PatchFormat2+ "Standard darcs patch format"+ , RawNoArg [] ["darcs-1"] F.UseFormat1 PatchFormat1+ "Older patch format (for compatibility)"]++-- ** dist++distname :: PrimDarcsOption (Maybe String)+distname = singleStrArg ['d'] ["dist-name"] F.DistName arg "DISTNAME" "name of version"+ where arg (F.DistName s) = Just s+ arg _ = Nothing++distzip :: PrimDarcsOption Bool+distzip = singleNoArg [] ["zip"] F.DistZip "generate zip archive instead of gzip'ed tar"++-- ** log++data ChangesFormat = HumanReadable | GenContext | GenXml | NumberPatches | CountPatches deriving (Eq, Show)++changesFormat :: PrimDarcsOption (Maybe ChangesFormat)+changesFormat = withDefault Nothing+ [ RawNoArg [] ["context"] F.GenContext (Just GenContext) "give output suitable for get --context"+ , __xmloutput (Just GenXml)+ , __humanReadable (Just HumanReadable)+ , RawNoArg [] ["number"] F.NumberPatches (Just NumberPatches) "number the changes"+ , RawNoArg [] ["count"] F.Count (Just CountPatches) "output count of changes" ]++-- ** replace++tokens :: PrimDarcsOption (Maybe String)+tokens = singleStrArg [] ["token-chars"] F.Toks arg "\"[CHARS]\""+ "define token to contain these characters"+ where arg (F.Toks s) = Just s; arg _ = Nothing++forceReplace :: PrimDarcsOption Bool+forceReplace = withDefault False+ [ RawNoArg ['f'] ["force"] F.ForceReplace True+ "proceed with replace even if 'new' token already exists"+ , RawNoArg [] ["no-force"] F.NonForce False+ "don't force the replace if it looks scary" ]++-- ** test++data TestStrategy = Once | Linear | Backoff | Bisect deriving (Eq, Show)++testStrategy :: PrimDarcsOption TestStrategy+testStrategy = withDefault Once+ [ RawNoArg [] ["once"] F.Once Once "run test on current version only"+ , RawNoArg [] ["linear"] F.Linear Linear "locate the most recent version lacking an error"+ , RawNoArg [] ["backoff"] F.Backoff Backoff "exponential backoff search"+ , RawNoArg [] ["bisect"] F.Bisect Bisect "binary instead of linear search" ]++-- ** show files/index++files :: PrimDarcsOption Bool+files = withDefault True+ [ RawNoArg [] ["files"] F.Files True "include files in output"+ , RawNoArg [] ["no-files"] F.NoFiles False "don't include files in output" ]++directories :: PrimDarcsOption Bool+directories = withDefault True+ [ RawNoArg [] ["directories"] F.Directories True "include directories in output"+ , RawNoArg [] ["no-directories"] F.NoDirectories False "don't include directories in output" ]++pending :: PrimDarcsOption Bool+pending = withDefault True+ [ RawNoArg [] ["pending"] F.Pending True "reflect pending patches in output"+ , RawNoArg [] ["no-pending"] F.NoPending False "only included recorded patches in output" ]++-- "null" is already taken+nullFlag :: PrimDarcsOption Bool+nullFlag = singleNoArg ['0'] ["null"] F.NullFlag "separate file names by NUL characters"++-- ** gzcrcs++data GzcrcsAction = GzcrcsCheck | GzcrcsRepair deriving (Eq, Show)++gzcrcsActions :: PrimDarcsOption (Maybe GzcrcsAction)+gzcrcsActions = withDefault Nothing+ [ RawNoArg [] ["check"] F.Check (Just GzcrcsCheck) "Specify checking mode"+ , RawNoArg [] ["repair"] F.Repair (Just GzcrcsRepair) "Specify repair mode" ]++-- ** optimize++siblings :: PrimDarcsOption [AbsolutePath]+siblings = multiAbsPathArg [] ["sibling"] F.Sibling mkV "URL" "specify a sibling directory"+ where mkV fs = [ s | F.Sibling s <- fs ]++reorderPatches :: PrimDarcsOption Bool+reorderPatches = singleNoArg [] ["reorder-patches"] F.Reorder "reorder the patches in the repository"++reorder :: PrimDarcsOption Reorder+reorder = withDefault NoReorder+ [ RawNoArg [] ["reorder-patches"] F.Reorder Reorder+ "reorder the patches in the repository"+ , RawNoArg [] ["no-reorder-patches"] F.NoReorder NoReorder+ "don't reorder the patches in the repository" ]++optimizePatchIndex :: PrimDarcsOption (Maybe WithPatchIndex)+optimizePatchIndex = withDefault Nothing+ [ __patchIndex (Just YesPatchIndex)+ , __noPatchIndex (Just NoPatchIndex) ]
+ src/Darcs/UI/Options/Core.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE RecordWildCards #-}+{-| Option specifications using continuations with a changing answer type.++Based on++@<www.is.ocha.ac.jp/~asai/papers/tr08-2.pdf>@++with additional inspiration provided by++@<http://okmij.org/ftp/typed-formatting/FPrintScan.html#DSL-FIn>@++which shows how the same format specifiers can be used for both @sprintf@ and+@sscanf@.++The 'OptSpec' type corresponds to the format specifiers for the sprintf and+sscanf functions, which I called 'ounparse' and 'oparse' here; they no+longer work on 'String's but instead on any list (the intention is, of+course, that this is a list of flags).++As explained in the original paper by Kenichi Asai, we cannot use+'Control.Monad.Trans.Cont.Cont', even with the recent additions of the+@shift@ and @reset@ combinators, since 'Control.Monad.Trans.Cont.Cont'+requires that the answer type remains the same over the whole computation,+while the trick used here requires that the answer type can change.++Besides parsing and unparsing, the 'OptSpec' type contains two more members:+'odesc' is the list of 'OptDescr' that 'System.Console.GetOpt.getOpt' needs+as input for parsing the command line and for generating the usage help,+while 'ocheck' takes a list of flags and returns a list of error messages,+which can be used to check for conflicting options.++-}+module Darcs.UI.Options.Core where++import Prelude hiding ( (^) )+import Data.Monoid ( Monoid(..) )++import Darcs.UI.Options.Iso++-- * Option specifications++{-| A type for option specifications.++It consists of four components: a parser, an unparser, a checker, and a list+of descriptions.++The parser converts a flag list to some result value. This can never fail:+we demand that primitive parsers are written so that there is always a+default value (use 'Maybe' with default 'Nothing' as a last resort).++The unparser does the opposite of the parser: a value is converted back+to a flag list.++The checker returns a list of error messages (which should be empty if there+are no problems found). This can be used to e.g. check whether there are+conflicting flags in the list.++Separating the checker and parser is unusual. The reason for this is that we+want to support flags coming from multiple sources, such as the command line+or a defaults file. Prioritising these sources is done by concatenating the+flag lists in the order of precedence, so that earlier flags win over later+ones. That means that when parsing the (final) flag list, conflicting flags+are resolved by picking the first flag that matches an option. The checker,+on the other hand, can be called for each source separately.++The last component is a list of descriptors for each single switch/flag that+the option is made of.++The 'OptSpec' type is heavily parameterized. The type arguments are:++[@f@] The flag type, such as 'Darcs.UI.Flags.DarcsFlag'.++[@d@] A type that describes an single flag, such as+ 'System.Console.GetOpt.OptDescr' or 'Darcs.UI.Options.DarcsOptDescr'. It+ should be a 'Data.Functor.Functor'.++Abstracting over these types is not technically necessary: for the intended+application in Darcs, we could as well fix them as+@d='Darcs.UI.Options.DarcsOptDescr'@, and @f='Darcs.UI.Flags.DarcsFlag'@,+saving two type parameters. However, doing that here would only obscure+what's going on, making the code harder to understand, not easier. Besides,+the resulting more general type signatures give us additional guarantees,+known as \"free theorems\" (free as in beer, not in speak).++In contrast, the type parameters++[@a@, @b@] are necessary to make chaining of options a la typed printf/scanf+ possible. In a nutshell, @a@ is the result type of a function that+ consumes the result of parsing or unparsing an option, while @b@ is the+ complete type of such a function.++The 'ounparse' and 'oparse' members use continuation passing style, which is+the reason for their apparently \"inverted\" type signature. To understand+them, it helps to look at the type of \"primitive\" (not yet combined)+options (see 'PrimOptSpec' below). For a primitive option, @b@ gets+instantiated to @v -> a@, where @v@ is the type of values associated with+the option. The whole option spec then has type++> o :: 'OptSpec' d f a (v -> a)++so that the 'oparse' and 'ounparse' members are instantiated to++> ounparse :: forall a. ([f] -> a) -> (x -> a)+> oparse :: forall a. (x -> a) -> ([f] -> a)++which can be easily seen to be equivalent to++> ounparse :: x -> [f]+> oparse :: [f] -> x++Chaining such options results in a combined option of type++> o1 ^ o2 ^ ... :: OptSpec d f a (v1 -> v2 -> ... -> a)++that is, @b@ gets instantiated to++> v1 -> v2 -> ... -> a++To use such an option (primitive or combined), you pass in the consumer. A+typical consumer of option values is a command implementation. Given++> cmd :: v1 -> v2 -> ... -> [String] -> IO ()++we can parse the flags and pass the results to @cmd@:++> oparse (o1 ^ o2 ^ ...) cmd flags++-}+data OptSpec d f a b = OptSpec+ { ounparse :: ([f] -> a) -> b+ -- ^ Convert option value (back) to flag list, in CPS.+ , oparse :: b -> ([f] -> a)+ -- ^ Convert flag list to option value, in CPS. Note: as a pure+ -- function, it is not supposed to fail.+ , ocheck :: [f] -> [String]+ -- ^ Check for erros in a flag list, returns error messages.+ , odesc :: [d f]+ -- ^ Descriptions, one for each flag that makes up the option.+ }++-- ** Primitive combinators++{- $category++The type @'OptSpec' d f@, together with the operation '^' and the unit+'oid' forms a category. We could express this with an++@+ instance 'Control.Category.Category' ('OptSpec' d f) where+ 'Control.Category.id' = 'oid'+ ('Control.Category..') = ('^')+@++I decided against doing that because I like the 'id' and '.' from the+"Prelude".++Proving the category laws is easy because the operation and unit are+implemented independently for each component. This means @'OptSpec' d f@+is simply the product of four categories, reducing the problem to proving+the laws for each component separately.++['odesc'] This is just list concatenation, which is a monoid, and every+ monoid is a category (by adding two phantom type arguments).++['ocheck'] Same here, noting that @([f] ->)@ is a monoid homomorphism+ (as expressed by the @instance 'Monoid' b => 'Monoid' (a -> b)@ in+ "Data.Monoid").++['oparse'] This can be seen by flipping the arguments (which is a functor+ i.e. preserves category laws), so the type becomes @[f] -> b -> a@, and+ noting as before that @([f] ->)@ is a monoid homomorphism and thus a+ functor (by adding two phantom type arguments), reducing the operation to+ simple function composition. If this rather abstract argument doesn't+ convince you, do the calculations as an exercise.++['ounparse'] for this I don't have an easy abstract argument at hand,+ so I'll do the calculation:++@+ o1 ^ (o2 ^ o3)+ = definition outer (^)+ \k -> o1 (\f1 -> (o2 ^ o3) (\f23 -> k (f1 ++ f23)))+ = definition inner (^)+ \k -> o1 (\f1 -> (\k' -> o2 (\f2 -> o3 (\f3 -> k' (f2 ++ f3)))) (\f23 -> k (f1 ++ f23)))+ = beta reduce: f1 --> \f23 -> k (f1 ++ f23)+ \k -> o1 (\f1 -> (o2 (\f2 -> o3 (\f3 -> (\f23 -> k (f1 ++ f23)) (f2 ++ f3)))))+ = beta reduce: f23 --> f2 ++ f3+ \k -> o1 (\f1 -> (o2 (\f2 -> o3 (\f3 -> (k (f1 ++ (f2 ++ f3)))))))+@++and from the other side:++@+ (o1 ^ o2) ^ o3+ = definition outer (^)+ \k -> (o1 ^ o2) (\f12 -> o3 (\f3 -> k (f12 ++ f3)))+ = definition inner (^)+ \k -> (\k' -> o1 (\f1 -> o2 (\f2 -> k' (f1 ++ f2)))) (\f12 -> o3 (\f3 -> k (f12 ++ f3)))+ = beta reduce: k' --> \f12 -> o3 (\f3 -> k (f12 ++ f3))+ \k -> (o1 (\f1 -> o2 (\f2 -> (\f12 -> o3 (\f3 -> k (f12 ++ f3))) (f1 ++ f2))))+ = beta reduce: f12 --> f1 ++ f2+ \k -> (o1 (\f1 -> o2 (\f2 -> (o3 (\f3 -> k ((f1 ++ f2) ++ f3))))))+@++so again we have reduced the problem to the associativity of @('++')@. Left+and right unit laws are left to the reader...++-}++-- | Identity 'OptSpec', unit for '^'+oid :: OptSpec d f a a+oid = OptSpec {..} where+ ounparse k = k []+ oparse k _ = k+ ocheck _ = []+ odesc = []++-- | 'OptSpec' composition, associative+(^) :: OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c+OptSpec ou1 op1 oc1 od1 ^ OptSpec ou2 op2 oc2 od2 = OptSpec {..} where+ ounparse k = ou1 (\fs1 -> ou2 (\fs2 -> k (fs1 ++ fs2)))+ oparse k fs = op2 (op1 k fs) fs+ ocheck fs = oc1 fs ++ oc2 fs+ odesc = od1 ++ od2++-- ** Derived combinators++-- | Normalise a flag list by parsing and then unparsing it. This adds all+-- implicit (default) flags to the list, which is useful as long as there is+-- legacy code that circumvents the 'OptSpec' abstraction and directly tests+-- for flag membership.+--+-- prop> onormalise opts = (oparse opts . ounparse opts) id+onormalise :: OptSpec d f [f] b -> [f] -> [f]+onormalise opts = (oparse opts . ounparse opts) id++-- | The list of default flags for an 'OptSpec'.+--+-- prop> defaultFlags opts = onormalise opts []+defaultFlags :: OptSpec d f [f] b -> [f]+defaultFlags opts = onormalise opts []++-- ** Lifting isomorphisms++-- | Lift an isomorphism between @b@ and @c@ to one between+-- @'OptSpec' d f a b@ and @'OptSpec' d f a c@.+--+-- The forward component of the 'Iso' is needed for 'ounparse', the backward+-- component for 'oparse'. For the other two components this is the identity.+oimap :: Iso b c -> OptSpec d f a b -> OptSpec d f a c+oimap (Iso fw bw) (OptSpec ou op oc od) = OptSpec {..} where+ ounparse k = fw (ou k)+ oparse k = op (bw k)+ ocheck = oc+ odesc = od++instance IsoFunctor (OptSpec d f a) where+ imap = oimap++-- * Primitive options++-- | Type of primitive (not yet combined) options. The type parameter @b@+-- gets instantiated to @(v -> a)@, adding one argument of type @v@+-- to the answer type of the continuation.+type PrimOptSpec d f a v = OptSpec d f a (v -> a)++-- | Combine two list valued options of the same type \"in parellel\". This+-- is done by concatenating the resulting option values ('oparse'), flags+-- ('ounparse'), errors ('ocheck'), and descriptors ('odesc'),+-- respectively, of the input options.+oappend :: PrimOptSpec d f a [v] -> PrimOptSpec d f a [v] -> PrimOptSpec d f a [v]+OptSpec ou1 op1 oc1 od1 `oappend` OptSpec ou2 op2 oc2 od2 = OptSpec {..} where+ ounparse k bs = ou1 (\fs1 -> ou2 (\fs2 -> k (fs1 ++ fs2)) bs) bs+ oparse k fs = op2 (\bs2 -> op1 (\bs1 -> k (bs1 ++ bs2)) fs) fs+ ocheck fs = oc1 fs ++ oc2 fs+ odesc = od1 ++ od2++-- | Unit for 'oappend'.+oempty :: PrimOptSpec d f a [v]+oempty = OptSpec {..} where+ ounparse k _ = k []+ oparse k _ = k []+ ocheck _ = []+ odesc = []++-- | See 'oappend' and 'oempty'.+instance Monoid (PrimOptSpec d f a [v]) where+ mappend = oappend+ mempty = oempty++-- | Parse a list of flags against a primitive option spec, returning the+-- value associated with the option. As noted above, this cannot fail because+-- options always have a default value.+--+-- prop> parseFlags o fs = oparse o id fs+parseFlags :: (forall a. PrimOptSpec d f a v) -> [f] -> v+parseFlags o fs = oparse o id fs
+ src/Darcs/UI/Options/Flags.hs view
@@ -0,0 +1,95 @@+-- |This module should only be imported by Darcs.UI.Options.*+-- and by 'Darcs.UI.Flags'. Other modules needing access to 'DarcsFlag'+-- should import 'Darcs.UI.Flags'+module Darcs.UI.Options.Flags ( DarcsFlag(..) ) where++import Darcs.Util.Path ( AbsolutePath, AbsolutePathOrStd )++-- | The 'DarcsFlag' type is a list of all flags that can ever be+-- passed to darcs, or to one of its commands.+data DarcsFlag = Version | ExactVersion | ListCommands+ | Help | ListOptions | NoTest | Test+ | OnlyChangesToFiles | ChangesToAllFiles+ | LeaveTestDir | NoLeaveTestDir+ | Timings | Debug | DebugHTTP+ | Verbose | NormalVerbosity | Quiet+ | Target String | Cc String+ | Output AbsolutePathOrStd | OutputAutoName AbsolutePath | Mail+ | Subject String | InReplyTo String | Charset String+ | SendmailCmd String | Author String | SelectAuthor | PatchName String+ | OnePatch String | SeveralPatch String+ | OneHash String+ | AfterPatch String | UpToPatch String+ | AfterHash String | UpToHash String+ | TagName String | LastN Int | MaxCount Int | PatchIndexRange Int Int+ | NumberPatches+ | OneTag String | AfterTag String | UpToTag String+ | GenContext | Context AbsolutePath | Count+ | LogFile AbsolutePath | RmLogFile | DontRmLogFile+ | DistName String | DistZip | All+ | Recursive | NoRecursive+ | Minimize | NoMinimize+ | Reorder | NoReorder+ | RestrictPaths | DontRestrictPaths+ | AskDeps | NoAskDeps | IgnoreTimes | DontIgnoreTimes+ | LookForAdds | NoLookForAdds+ | LookForMoves | NoLookForMoves+ | LookForReplaces | NoLookForReplaces+ | UseMyersDiff | UsePatienceDiff+ | Intersection | Union | Complement+ | Sign | SignAs String | NoSign | SignSSL String+ | HappyForwarding | NoHappyForwarding+ | Verify AbsolutePath | VerifySSL AbsolutePath+ | RemoteDarcsOpt String+ | EditDescription | NoEditDescription+ | Toks String+ | EditLongComment | NoEditLongComment | PromptLongComment+ | KeepDate | NoKeepDate+ | AllowConflicts | MarkConflicts | NoAllowConflicts+ | SkipConflicts+ | Boring | SkipBoring+ | AllowCaseOnly | DontAllowCaseOnly+ | AllowWindowsReserved | DontAllowWindowsReserved+ | DontGrabDeps | DontPromptForDependencies | PromptForDependencies+ | Compress | NoCompress | UnCompress+ | WorkRepoDir String | WorkRepoUrl String | RemoteRepo String+ | NewRepo String+ | NotInRemote (Maybe String)+ | Reply String | ApplyAs String+ | MachineReadable | HumanReadable+ | Pipe | Interactive+ | DiffCmd String+ | ExternalMerge String | Summary | NoSummary+ | PauseForGui | NoPauseForGui+ | Unified | NonUnified | Reverse | Forward+ | Complete | Lazy+ | DiffFlags String+ | XMLOutput+ | ForceReplace+ | OnePattern String | SeveralPattern String+ | AfterPattern String | UpToPattern String+ | NonApply | NonVerify | NonForce+ | DryRun+ | SetDefault | NoSetDefault+ | Disable | SetScriptsExecutable | DontSetScriptsExecutable+ | Once | Linear | Backoff | Bisect+ | Hashed -- deprecated flag, here to output an error message+ | UseFormat1 | UseFormat2 | UseNoWorkingDir | UseWorkingDir+ | Sibling AbsolutePath+ | Files | NoFiles | Directories | NoDirectories+ | Pending | NoPending+ | PosthookCmd String | NoPosthook | AskPosthook | RunPosthook+ | PrehookCmd String | NoPrehook | AskPrehook | RunPrehook+ | UMask String+ | StoreInMemory | ApplyOnDisk+ | NoHTTPPipelining+ | Packs | NoPacks+ | NoCache+ | AllowUnrelatedRepos+ | Check | Repair | JustThisRepo+ | ReadMarks String | WriteMarks String+ | NullFlag+ | NoAmendUnrecord | AmendUnrecord+ | PatchIndexFlag+ | NoPatchIndexFlag+ deriving ( Eq, Show )
+ src/Darcs/UI/Options/Iso.hs view
@@ -0,0 +1,25 @@+module Darcs.UI.Options.Iso where+-- * Isomorphisms++-- | Lightweight type ismomorphisms (a.k.a. invertible functions). If+-- +-- > Iso fw bw :: Iso a b+--+-- then @fw@ and @bw@ are supposed to satisfy+--+-- prop> fw . bw = id = bw . fw+data Iso a b = Iso (a -> b) (b -> a)++-- | Lift an isomorphism between @a@ and @b@ to one between @f a@ and @f b@.+-- Like 'Functor', except we can only map invertible functions (i.e. an+-- Isomorphisms).+class IsoFunctor f where+ imap :: Iso a b -> f a -> f b++-- | Apply an iso under a functor.+under :: Functor f => Iso a b -> Iso (f a) (f b)+under (Iso fw bw) = Iso (fmap fw) (fmap bw)++-- | Apply an iso under cps (which is a cofunctor).+cps :: Iso a b -> Iso (a -> c) (b -> c)+cps (Iso fw bw) = Iso (\k -> k . bw) (\k -> k . fw)
+ src/Darcs/UI/Options/Markdown.hs view
@@ -0,0 +1,35 @@+-- Support for @darcs help markdown@+module Darcs.UI.Options.Markdown ( optionsMarkdown ) where++import Data.Functor.Compose ( Compose(..) )+import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) )+import Darcs.UI.Options.Util ( DarcsOptDescr )++optionsMarkdown :: [DarcsOptDescr f] -> String+optionsMarkdown opts = unlines+ [ "<table>", unlines (map optionMarkdown opts), "</table>" ]++optionMarkdown :: DarcsOptDescr f -> String+optionMarkdown (Compose (Option a b (NoArg _) h)) = unlines+ [ "<tr>", "<td>", showShortOptionsMd a, "</td>"+ , "<td>", showLongOptionsMd b , "</td>"+ , "<td>", h, "</td>"+ , "</tr>" ]+optionMarkdown (Compose (Option a b (ReqArg _ arg) h)) = unlines+ [ "<tr>", "<td>", showShortOptionsMd a, "</td>"+ , "<td>", showLongOptionsMd (map (++(' ' : arg)) b), "</td>"+ , "<td>", h, "</td>", "</tr>" ]+optionMarkdown (Compose (Option a b (OptArg _ arg) h)) = unlines+ [ "<tr>", "<td>", showShortOptionsMd a, "</td>"+ , "<td>", showLongOptionsMd (map (++("[="++arg++"]")) b), "</td>"+ , "<td>", h, "</td>", "</tr>" ]++showShortOptionsMd :: [Char] -> String+showShortOptionsMd [] = ""+showShortOptionsMd [c] = "`-"++[c]++"` "+showShortOptionsMd (c:cs) = "`-"++[c]++"`,"++showShortOptionsMd cs++showLongOptionsMd :: [String] -> String+showLongOptionsMd [] = " "+showLongOptionsMd [s] = "`--" ++ s ++ "` "+showLongOptionsMd (s:ss) = "`--" ++ s ++ "`,"++ showLongOptionsMd ss
+ src/Darcs/UI/Options/Matching.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE RecordWildCards #-}+{-| Patch matching options.++These are all of the same type 'MatchOption' defined below.++Multiple flags per option are allowed and do not raise a conflict error.+This is how Darcs currently operates, even though I suspect that it ignores+all but the first 'MatchFlag' (since it does so for many other options).++Given a suitable semantics (and documentation thereof), for instance \"all+the given patterns must match\", this could be turned into a useful feature.++-}+module Darcs.UI.Options.Matching+ ( MatchFlag(..) -- re-export+ , matchOne+ , matchOneContext+ , matchOneNontag+ , matchSeveral+ , matchSeveralOrFirst+ , matchSeveralOrLast+ , matchRange+ , matchSeveralOrRange+ , matchAny -- temporary, for toMatchFlags+ , context -- temporary, for getContext+ ) where++import Prelude hiding ( last )+import Data.Char ( isDigit )+import Data.Monoid ( (<>), mconcat )++import Darcs.Patch.Match ( MatchFlag(..) )+import qualified Darcs.UI.Options.Flags as F ( DarcsFlag(..) )+import Darcs.UI.Options.Core+import Darcs.UI.Options.Util++-- * Type instantiations++type MatchOption = PrimDarcsOption [MatchFlag]++-- * Combined matching options++matchOne :: MatchOption -- ^ amend, show files/contents, dist, annotate+matchOne = mconcat [match, patch, hash, tag, index]++-- | Used by: clone+matchOneContext :: MatchOption+matchOneContext = mconcat [toMatch, toPatch, toHash, tag, context]++-- [NOTE --index removed from matchOneNontag because issue1926]+-- The --index option was removed for 2.5 release because it isn't handled+-- by amend-record (see issue1926).+--+-- At this moment, amend-record is the only command that uses 'matchOneNontag',+-- so there is no other command affected.++-- | Used by: amend+matchOneNontag :: MatchOption+matchOneNontag = match <> patch <> hash++-- | Used by: rebase pull, apply, send, push, pull, fetch+matchSeveral :: MatchOption+matchSeveral = matches <> patches <> tags <> hash++-- | Used by: rebase unsuspend/reify+matchSeveralOrFirst :: MatchOption+matchSeveralOrFirst = mconcat [ matchTo, last, matches, patches, tags, hash ]++-- | Used by: unrecord, obliterate, rebase suspend, rollback+matchSeveralOrLast :: MatchOption+matchSeveralOrLast = mconcat [ matchFrom, last, matches, patches, tags, hash ]++-- | Used by: diff+matchRange :: MatchOption+matchRange = mconcat [ matchTo, matchFrom, match, patch, hash, last, indexes ]++-- | Used by: log+matchSeveralOrRange :: MatchOption+matchSeveralOrRange = mconcat+ [ matchTo, matchFrom, last, indexes, matches, patches, tags, hash ]++matchTo :: MatchOption+matchTo = toMatch <> toPatch <> toHash <> toTag++matchFrom :: MatchOption+matchFrom = fromMatch <> fromPatch <> fromHash <> fromTag++matchAny :: MatchOption+matchAny = mconcat [ toMatch, toPatch, toHash, toTag,+ fromMatch, fromPatch, fromHash, fromTag,+ tag, tags, patch, patches, match, matches, index, indexes, context, last ]++-- * Primitive matching options++toMatch, toPatch, toHash, toTag,+ fromMatch, fromPatch, fromHash, fromTag,+ tag, tags,+ patch, patches,+ hash,+ match, matches,+ index, indexes,+ context, last :: MatchOption++toMatch = OptSpec {..} where+ ounparse k mfs = k [ F.UpToPattern s | UpToPattern s <- mfs ]+ oparse k fs = k [ UpToPattern s | F.UpToPattern s <- fs ]+ ocheck _ = []+ odesc = [ strArg [] ["to-match"] F.UpToPattern "PATTERN"+ "select changes up to a patch matching PATTERN" ]++toPatch = OptSpec {..} where+ ounparse k mfs = k [ F.UpToPatch s | UpToPatch s <- mfs ]+ oparse k fs = k [ UpToPatch s | F.UpToPatch s <- fs ]+ ocheck _ = []+ odesc = [ strArg [] ["to-patch"] F.UpToPatch "REGEXP"+ "select changes up to a patch matching REGEXP" ]++toHash = OptSpec {..} where+ ounparse k mfs = k [ F.UpToHash s | UpToHash s <- mfs ]+ oparse k fs = k [ UpToHash s | F.UpToHash s <- fs ]+ ocheck _ = []+ odesc = [ strArg [] ["to-hash"] F.UpToHash "HASH"+ "select changes up to a patch with HASH" ]++context = OptSpec {..} where+ ounparse k mfs = k [ F.Context p | Context p <- mfs ]+ oparse k fs = k [ Context p | F.Context p <- fs ]+ ocheck _ = []+ odesc = [ absPathArg [] ["context"] F.Context "FILENAME"+ "version specified by the context in FILENAME" ]++toTag = OptSpec {..} where+ ounparse k mfs = k [ F.UpToTag s | UpToTag s <- mfs ]+ oparse k fs = k [ UpToTag s | F.UpToTag s <- fs ]+ ocheck _ = []+ odesc = [ strArg [] ["to-tag"] F.UpToTag "REGEXP"+ "select changes up to a tag matching REGEXP" ]++fromMatch = OptSpec {..} where+ ounparse k mfs = k [ F.AfterPattern s | AfterPattern s <- mfs ]+ oparse k fs = k [ AfterPattern s | F.AfterPattern s <- fs ]+ ocheck _ = []+ odesc = [ strArg [] ["from-match"] F.AfterPattern "PATTERN"+ "select changes starting with a patch matching PATTERN" ]++fromPatch = OptSpec {..} where+ ounparse k mfs = k [ F.AfterPatch s | AfterPatch s <- mfs ]+ oparse k fs = k [ AfterPatch s | F.AfterPatch s <- fs ]+ ocheck _ = []+ odesc = [ strArg [] ["from-patch"] F.AfterPatch "REGEXP"+ "select changes starting with a patch matching REGEXP" ]++fromHash = OptSpec {..} where+ ounparse k mfs = k [ F.AfterHash s | AfterHash s <- mfs ]+ oparse k fs = k [ AfterHash s | F.AfterHash s <- fs ]+ ocheck _ = []+ odesc = [ strArg [] ["from-hash"] F.AfterHash "HASH"+ "select changes starting with a patch with HASH" ]++fromTag = OptSpec {..} where+ ounparse k mfs = k [ F.AfterTag s | AfterTag s <- mfs ]+ oparse k fs = k [ AfterTag s | F.AfterTag s <- fs ]+ ocheck _ = []+ odesc = [ strArg [] ["from-tag"] F.AfterTag "REGEXP"+ "select changes starting with a tag matching REGEXP" ]++tag = OptSpec {..} where+ ounparse k mfs = k [ F.OneTag s | OneTag s <- mfs ]+ oparse k fs = k [ OneTag s | F.OneTag s <- fs ]+ ocheck _ = []+ odesc = [ strArg ['t'] ["tag"] F.OneTag "REGEXP" "select tag matching REGEXP" ]++tags = OptSpec {..} where+ ounparse k mfs = k [ F.OneTag s | OneTag s <- mfs ]+ oparse k fs = k [ OneTag s | F.OneTag s <- fs ]+ ocheck _ = []+ odesc = [ strArg ['t'] ["tags"] F.OneTag "REGEXP" "select tags matching REGEXP" ]++patch = OptSpec {..} where+ ounparse k mfs = k [ F.OnePatch s | OnePatch s <- mfs ]+ oparse k fs = k [ OnePatch s | F.OnePatch s <- fs ]+ ocheck _ = []+ odesc = [ strArg ['p'] ["patch"] F.OnePatch "REGEXP"+ "select a single patch matching REGEXP" ]++patches = OptSpec {..} where+ ounparse k mfs = k [ F.SeveralPatch s | SeveralPatch s <- mfs ]+ oparse k fs = k [ SeveralPatch s | F.SeveralPatch s <- fs ]+ ocheck _ = []+ odesc = [ strArg ['p'] ["patches"] F.SeveralPatch "REGEXP"+ "select patches matching REGEXP" ]++hash = OptSpec {..} where+ ounparse k mfs = k [ F.OneHash s | OneHash s <- mfs ]+ oparse k fs = k [ OneHash s | F.OneHash s <- fs ]+ ocheck _ = []+ odesc = [ strArg ['h'] ["hash"] F.OneHash "HASH"+ "select a single patch with HASH" ]++match = OptSpec {..} where+ ounparse k mfs = k [ F.OnePattern s | OnePattern s <- mfs ]+ oparse k fs = k [ OnePattern s | F.OnePattern s <- fs ]+ ocheck _ = []+ odesc = [ strArg [] ["match"] F.OnePattern "PATTERN"+ "select a single patch matching PATTERN" ]++matches = OptSpec {..} where+ ounparse k mfs = k [ F.SeveralPattern s | SeveralPattern s <- mfs ]+ oparse k fs = k [ SeveralPattern s | F.SeveralPattern s <- fs ]+ ocheck _ = []+ odesc = [ strArg [] ["matches"] F.SeveralPattern "PATTERN"+ "select patches matching PATTERN" ]++last = OptSpec {..} where+ ounparse k mfs = k [ F.LastN s | LastN s <- mfs ]+ oparse k fs = k [ LastN s | F.LastN s <- fs ]+ ocheck _ = []+ odesc = [ strArg [] ["last"] (F.LastN . toInt) "NUMBER"+ "select the last NUMBER patches" ]+ toInt s = if not (null s) && all isDigit s then read s else (-1)++-- | TODO: see 'Darcs.UI.Options.matchMaxcount'.+index = OptSpec {..} where+ ounparse k mfs = k [ F.PatchIndexRange n m | PatchIndexRange n m <- mfs ]+ oparse k fs = k [ PatchIndexRange n m | F.PatchIndexRange n m <- fs ]+ ocheck _ = []+ odesc = [ strArg ['n'] ["index"] indexrange "N" "select one patch" ]+ indexrange s = if all isDigit s+ then F.PatchIndexRange (read s) (read s)+ else F.PatchIndexRange 0 0++-- | TODO: see 'Darcs.UI.Options.matchMaxcount'.+indexes = OptSpec {..} where+ ounparse k mfs = k [ F.PatchIndexRange n m | PatchIndexRange n m <- mfs ]+ oparse k fs = k [ PatchIndexRange n m | F.PatchIndexRange n m <- fs ]+ ocheck _ = []+ odesc = [ strArg ['n'] ["index"] indexrange "N-M" "select a range of patches" ]+ indexrange s = if all isokay s+ then if '-' `elem` s+ then let x1 = takeWhile (/= '-') s+ x2 = reverse $ takeWhile (/= '-') $ reverse s+ in F.PatchIndexRange (read x1) (read x2)+ else F.PatchIndexRange (read s) (read s)+ else F.PatchIndexRange 0 0+ isokay c = isDigit c || c == '-'
+ src/Darcs/UI/Options/Util.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE RecordWildCards #-}+-- | Constructing 'OptSpec's and 'OptDescr's+module Darcs.UI.Options.Util+ ( Flag+ , PrimDarcsOption+ , DarcsOptDescr+ , noArg+ , strArg+ , optStrArg+ , absPathArg+ , absPathOrStdArg+ , optAbsPathArg+ , RawOptSpec(..)+ , withDefault+ , singleNoArg+ , singleStrArg+ , multiStrArg+ , multiOptStrArg+ , singleAbsPathArg+ , multiAbsPathArg+ , deprecated+ -- Re-exports+ , AbsolutePath+ , AbsolutePathOrStd+ , makeAbsolute+ , makeAbsoluteOrStd+ ) where++import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) )+import Data.Functor.Compose+import Data.List ( intercalate )+import Data.Maybe ( maybeToList, fromMaybe )+import Darcs.UI.Options.Core+import Darcs.UI.Options.Flags ( DarcsFlag )+import Darcs.UI.Options.Iso+import Darcs.Util.Path+ ( AbsolutePath+ , AbsolutePathOrStd+ , makeAbsolute+ , makeAbsoluteOrStd+ )++-- * Instantiating 'OptSpec' and 'PrimOptSpec'++-- | This type synonym is here for brevity and because we want to import+-- the data constructors (but not the type) of 'DarcsFlag' qualified.+type Flag = DarcsFlag++{- | We do not instantiate the @d@ in @'OptSpec' d f@ directly with+'System.Console.GetOpt.OptDescr'. Instead we (post-) compose it with @(->)+'DarcsUtil.Path.AbsolutePath'@. Modulo newtype noise, this is the same as++@ type 'DarcsOptDescr f = 'System.Console.GetOpt.OptDescr' ('AbsolutePath' -> f)@++This is so we can pass a directory relative to which an option argument is+interpreted (if it has the form of a relative path).+-}+type DarcsOptDescr = Compose OptDescr ((->) AbsolutePath)++-- | This is 'PrimOptSpec' instantiated with 'DarcsOptDescr and 'Flag'.+type PrimDarcsOption v = forall a. PrimOptSpec DarcsOptDescr Flag a v++-- * Constructing 'OptDescr's++-- | Construct an 'DarcsOptDescr with no arguments.+noArg :: [Char] -> [String] -> f -> String -> DarcsOptDescr f+noArg s l f h = Compose $ Option s l (NoArg (const f)) h++-- | A 'DarcsOptDescr' that requires a single argument of type 'a' and handles+-- flags of type 'f'.+type SingleArgOptDescr a f =+ [Char] -> [String] -> (a -> f) -> String -> String -> DarcsOptDescr f++-- | Construct an 'DarcsOptDescr with a 'String' argument.+strArg :: SingleArgOptDescr String f+strArg s l f a h = Compose $ Option s l (ReqArg (\x _ -> f x) a) h++-- | Construct an 'DarcsOptDescr with an optional 'String' argument.+optStrArg :: SingleArgOptDescr (Maybe String) f+optStrArg s l f a h = Compose $ Option s l (OptArg (\x _ -> f x) a) h++-- | Construct an 'DarcsOptDescr with an 'AbsolutePath'+-- argument.+absPathArg :: SingleArgOptDescr AbsolutePath f+absPathArg s l f a h = Compose $ Option s l (ReqArg (\x wd -> f $ makeAbsolute wd x) a) h++-- | Construct an 'DarcsOptDescr with an 'AbsolutePathOrStd'+-- argument.+absPathOrStdArg :: SingleArgOptDescr AbsolutePathOrStd f+absPathOrStdArg s l f a h = Compose $ Option s l (ReqArg (\x wd -> f $ makeAbsoluteOrStd wd x) a) h++-- | Construct an 'DarcsOptDescr with an optional 'AbsolutePath'+-- argument.+optAbsPathArg :: [Char] -> [String] -> String -> (AbsolutePath -> f)+ -> String -> String -> DarcsOptDescr f+optAbsPathArg s l d f a h = Compose $ Option s l (OptArg (\x wd -> f $ makeAbsolute wd $ fromMaybe d x) a) h++-- * Raw option specs++-- | The raw material from which multi-valued options are built. See 'withDefault'.+data RawOptSpec f v+ = RawNoArg [Char] [String] f v String+ | RawStrArg [Char] [String] (String -> f) (f -> [String]) (String -> v) (v -> [String])+ String String+ | RawAbsPathArg [Char] [String] (AbsolutePath -> f) (f -> [AbsolutePath])+ (AbsolutePath -> v) (v -> [AbsolutePath]) String String+ | RawAbsPathOrStdArg [Char] [String] (AbsolutePathOrStd -> f) (f -> [AbsolutePathOrStd])+ (AbsolutePathOrStd -> v) (v -> [AbsolutePathOrStd]) String String+ | RawOptAbsPathArg [Char] [String] (AbsolutePath -> f) (f -> [AbsolutePath])+ (AbsolutePath -> v) (v -> [AbsolutePath]) String String String++instance IsoFunctor (RawOptSpec f) where+ imap (Iso fw _) (RawNoArg s l f v h) = RawNoArg s l f (fw v) h+ imap (Iso fw bw) (RawStrArg s l mkF unF mkV unV n h) = RawStrArg s l mkF unF (fw . mkV) (unV . bw) n h+ imap (Iso fw bw) (RawAbsPathArg s l mkF unF mkV unV n h) = RawAbsPathArg s l mkF unF (fw . mkV) (unV . bw) n h+ imap (Iso fw bw) (RawAbsPathOrStdArg s l mkF unF mkV unV n h) = RawAbsPathOrStdArg s l mkF unF (fw . mkV) (unV . bw) n h+ imap (Iso fw bw) (RawOptAbsPathArg s l mkF unF mkV unV d n h) = RawOptAbsPathArg s l mkF unF (fw . mkV) (unV . bw) d n h++-- | Get the long switch names from a raw option. Used to construct error messages.+switchNames :: RawOptSpec f v -> [String]+switchNames (RawNoArg _ l _ _ _) = l+switchNames (RawStrArg _ l _ _ _ _ _ _) = l+switchNames (RawAbsPathArg _ l _ _ _ _ _ _) = l+switchNames (RawAbsPathOrStdArg _ l _ _ _ _ _ _) = l+switchNames (RawOptAbsPathArg _ l _ _ _ _ _ _ _) = l++-- | Given a list of 'RawOptSpec', find all flags that match a given value.+rawUnparse :: Eq v => [RawOptSpec f v] -> v -> [f]+rawUnparse ropts val =+ [ f | RawNoArg _ _ f v _ <- ropts, v == val ]+ ++ [ mkF s | RawStrArg _ _ mkF _ mkV unV _ _ <- ropts, s <- unV val, mkV s == val ]+ ++ [ mkF p | RawAbsPathArg _ _ mkF _ mkV unV _ _ <- ropts, p <- unV val, mkV p == val ]+ ++ [ mkF p | RawAbsPathOrStdArg _ _ mkF _ mkV unV _ _ <- ropts, p <- unV val, mkV p == val ]+ ++ [ mkF p | RawOptAbsPathArg _ _ mkF _ mkV unV _ _ _ <- ropts, p <- unV val, mkV p == val ]++-- | Given a list of 'RawOptSpec', find all values that match a given flag list+-- in the order in which they appear in the flag list.+rawParse :: Eq f => [RawOptSpec f v] -> [f] -> [(v,RawOptSpec f v)]+rawParse ropts = concatMap rawParseFlag where+ rawParseFlag f = concatMap (go f) ropts+ go f o@(RawNoArg _ _ f' v _) = [ (v, o) | f == f' ]+ go f o@(RawStrArg _ _ _ unF mkV _ _ _) = [ (mkV s, o) | s <- unF f ]+ go f o@(RawAbsPathArg _ _ _ unF mkV _ _ _) = [ (mkV p, o) | p <- unF f ]+ go f o@(RawAbsPathOrStdArg _ _ _ unF mkV _ _ _) = [ (mkV p, o) | p <- unF f ]+ go f o@(RawOptAbsPathArg _ _ _ unF mkV _ _ _ _) = [ (mkV p, o) | p <- unF f ]++-- [ (v, o) | f <- fs, o@(RawNoArg _ _ f' v _) <- ropts, f == f' ]+-- ++ [ (mkV s, o) | f <- fs, o@(RawStrArg _ _ _ unF mkV _ _ _) <- ropts, s <- unF f ]+-- ++ [ (mkV p, o) | f <- fs, o@(RawAbsPathArg _ _ _ unF mkV _ _ _) <- ropts, p <- unF f ]+-- ++ [ (mkV p, o) | f <- fs, o@(RawAbsPathOrStdArg _ _ _ unF mkV _ _ _) <- ropts, p <- unF f ]+-- ++ [ (mkV p, o) | f <- fs, o@(RawOptAbsPathArg _ _ _ unF mkV _ _ _ _) <- ropts, p <- unF f ]++-- | The first element of a list, or a default if the list is empty.+defHead :: a -> [a] -> a+defHead def [] = def+defHead _ (x:_) = x++-- | Append \" [DEFAULT\" to the help text of options that match the default value.+addDefaultHelp :: Eq v => v -> RawOptSpec f v -> DarcsOptDescr f+addDefaultHelp dval (RawNoArg s l f v h)+ | dval == v = noArg s l f (h++" [DEFAULT]")+ | otherwise = noArg s l f h+addDefaultHelp dval (RawStrArg s l mkF _ mkV unV a h)+ | [dval] == map mkV (unV dval) = strArg s l mkF a (h++" [DEFAULT]")+ | otherwise = strArg s l mkF a h+addDefaultHelp dval (RawAbsPathArg s l mkF _ mkV unV a h)+ | [dval] == map mkV (unV dval) = absPathArg s l mkF a (h++" [DEFAULT]")+ | otherwise = absPathArg s l mkF a h+addDefaultHelp dval (RawAbsPathOrStdArg s l mkF _ mkV unV a h)+ | [dval] == map mkV (unV dval) = absPathOrStdArg s l mkF a (h++" [DEFAULT]")+ | otherwise = absPathOrStdArg s l mkF a h+addDefaultHelp dval (RawOptAbsPathArg s l mkF _ mkV unV d a h)+ | [dval] == map mkV (unV dval) = optAbsPathArg s l d mkF a (h++" [DEFAULT]")+ | otherwise = optAbsPathArg s l d mkF a h++-- | Construct a 'PrimDarcsOption' from a default value and a list of 'RawOptSpec'.+--+-- Precondition: the list must have an entry for each possible value (type @v@).+withDefault :: Eq v => v -> [RawOptSpec Flag v] -> PrimDarcsOption v+withDefault dval ropts = OptSpec {..} where+ ounparse k = k . rawUnparse ropts+ oparse k = k . defHead dval . map fst . rawParse ropts+ ocheck fs = case map snd (rawParse ropts fs) of+ [] -> [] -- error "this should not happen"+ [_] -> []+ ropts' -> ["conflicting flags: " ++ intercalate ", " (map (intercalate "/" . switchNames) ropts')]+ odesc = map (addDefaultHelp dval) ropts++-- * Simple primitive scalar valued options++-- | Construct a 'Bool' valued option with a single flag that takes no arguments+-- and has no default flag.+--+-- The arguments are: short switches, long switches, flag value, help string.+singleNoArg :: [Char] -> [String] -> Flag -> String -> PrimDarcsOption Bool+singleNoArg s l f h = withDefault False [RawNoArg s l f True h]++-- | Construct a @'Maybe' 'String'@ valued option with a single flag that takes a+-- 'String' argument and has no default flag.+--+-- The arguments are: short switches, long switches, flag constructor, single flag+-- parser, help string.+singleStrArg :: [Char] -> [String] -> (String -> Flag) -> (Flag -> Maybe String)+ -> String -> String -> PrimDarcsOption (Maybe String)+singleStrArg s l mkf isf n h =+ withDefault Nothing [ RawStrArg s l mkf (maybeToList . isf) Just maybeToList n h ]++-- | Construct a @'Maybe' 'AbsolutePath'@ valued option with a single flag that+-- takes an 'AbsolutePath' argument and has no default flag.+--+-- The arguments are: short switches, long switches, flag constructor, single flag+-- parser, help string.+singleAbsPathArg :: [Char] -> [String]+ -> (AbsolutePath -> Flag) -> (Flag -> Maybe AbsolutePath)+ -> String -> String -> PrimDarcsOption (Maybe AbsolutePath)+singleAbsPathArg s l mkf isf n h =+ withDefault Nothing [ RawAbsPathArg s l mkf (maybeToList . isf) Just maybeToList n h ]++-- * Simple primitive list valued options++-- | Similar to 'singleStrArg', except that the flag can be given more than once.+-- The flag arguments are collected in a list of 'String's.+multiStrArg :: [Char] -> [String] -> (String -> Flag) -> ([Flag] -> [String])+ -> String -> String -> PrimDarcsOption [String]+multiStrArg = multiArg strArg++-- | Similar to 'multiStrArg', except that the flag arguments are optional.+multiOptStrArg :: [Char] -> [String] -> (Maybe String -> Flag)+ -> ([Flag] -> [Maybe String]) -> String -> String+ -> PrimDarcsOption [Maybe String]+multiOptStrArg = multiArg optStrArg++-- | Similar to 'singleAbsPathArg', except that the flag can be given more than once.+-- The flag arguments are collected in a list of 'AbsolutePath's.+multiAbsPathArg :: [Char] -> [String] -> (AbsolutePath -> Flag) -> ([Flag] -> [AbsolutePath])+ -> String -> String -> PrimDarcsOption [AbsolutePath]+multiAbsPathArg = multiArg absPathArg++-- | A multi-arg option, defined in terms of a single-arg option, returning a+-- list of single args.+--+-- The parameters are: single argument description, short switches, long+-- switches, flag constructor, flag list parser, arg name string, help string.+multiArg :: SingleArgOptDescr a Flag+ -> [Char] -> [String] -> (a -> Flag) -> ([Flag] -> [a])+ -> String -> String -> PrimDarcsOption [a]+multiArg singleArg s l mkf isf n h = OptSpec {..} where+ ounparse k xs = k [ mkf x | x <- xs ]+ oparse k = k . isf+ ocheck _ = []+ odesc = [singleArg s l mkf n h]++-- | A deprecated option. If you want to deprecate only some flags and not the+-- whole option, extract the 'RawOptSpec's out of the original option and create+-- a new deprecated option.+-- The strings in the first argument are appended to the automatically generated+-- error message in case additional hints should be provided.+deprecated :: [String] -> [RawOptSpec Flag v] -> PrimDarcsOption ()+deprecated comments ropts = OptSpec {..} where+ ounparse k _ = k []+ oparse k _ = k ()+ ocheck fs = case map snd (rawParse ropts fs) of+ [] -> []+ ropts' -> ("deprecated flag(s): " ++ intercalate ", " (concatMap switchNames ropts')) : comments+ odesc = map noDefaultHelp ropts+ noDefaultHelp (RawNoArg s l f _ h) = noArg s l f h+ noDefaultHelp (RawStrArg s l mkF _ _ _ a h) = strArg s l mkF a h+ noDefaultHelp (RawAbsPathArg s l mkF _ _ _ a h) = absPathArg s l mkF a h+ noDefaultHelp (RawAbsPathOrStdArg s l mkF _ _ _ a h) = absPathOrStdArg s l mkF a h+ noDefaultHelp (RawOptAbsPathArg s l mkF _ _ _ d a h) = optAbsPathArg s l d mkF a h
+ src/Darcs/UI/PrintPatch.hs view
@@ -0,0 +1,71 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.UI.PrintPatch+ ( printPatch+ , contextualPrintPatch+ , printPatchPager+ , printFriendly+ , showFriendly+ ) where++import Storage.Hashed.Monad( virtualTreeIO )+import Storage.Hashed.Tree( Tree )++import Darcs.Util.Printer.Color ( fancyPrinters )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch ( showContextPatch, showPatch, showNicely, description,+ summary )+import Darcs.Patch.Show ( ShowPatch )+import Darcs.UI.External ( viewDocWith )+--import Darcs.UI.Flags ( DarcsFlag(Summary, Verbose), isUnified )+import Darcs.UI.Options.All ( Verbosity(..), Summary(..), WithContext(..) )++import Darcs.Util.Printer ( Doc, putDocLnWith, RenderMode(..) )++-- | @'printFriendly' opts patch@ prints @patch@ in accordance with the flags+-- in opts, ie, whether @--verbose@ or @--summary@ were passed at the+-- command-line.+printFriendly :: (ShowPatch p, ApplyState p ~ Tree) => Maybe (Tree IO)+ -> Verbosity -> Summary -> WithContext -> p wX wY -> IO ()+printFriendly (Just pristine) _ _ YesContext = contextualPrintPatch pristine+printFriendly _ v s _ = putDocLnWith fancyPrinters . showFriendly v s++-- | @'showFriendly' flags patch@ returns a 'Doc' representing the right+-- way to show @patch@ given the list @flags@ of flags darcs was invoked with.+showFriendly :: ShowPatch p => Verbosity -> Summary -> p wX wY -> Doc+showFriendly Verbose _ = showNicely+showFriendly _ YesSummary = summary+showFriendly _ NoSummary = description++-- | 'printPatch' prints a patch on standard output.+printPatch :: ShowPatch p => p wX wY -> IO ()+printPatch p = putDocLnWith fancyPrinters $ showPatch p++-- | 'printPatchPager' runs '$PAGER' and shows a patch in it.+printPatchPager :: ShowPatch p => p wX wY -> IO ()+printPatchPager p = viewDocWith fancyPrinters Standard $ showPatch p++-- | 'contextualPrintPatch' prints a patch, together with its context, on+-- standard output.+contextualPrintPatch :: (ShowPatch p, ApplyState p ~ Tree) => Tree IO+ -> p wX wY -> IO ()+contextualPrintPatch s p = do+ (contextedPatch, _) <- virtualTreeIO (showContextPatch p) s+ putDocLnWith fancyPrinters contextedPatch
+ src/Darcs/UI/RemoteApply.hs view
@@ -0,0 +1,65 @@+-- | This module is used by the push and put commands to apply a bundle to a+-- remote repository. By remote I do not necessarily mean a repository on another+-- machine, it is just not the repository we're located in.+module Darcs.UI.RemoteApply ( remoteApply ) where++import System.Exit ( ExitCode )++import Darcs.UI.Flags ( DarcsFlag, remoteDarcs, applyAs )+import Darcs.Util.Text ( breakCommand )+import Darcs.Util.URL ( isHttpUrl, isSshUrl, splitSshUrl, SshFilePath(..) )+import Darcs.UI.External+ ( darcsProgram+ , pipeDoc+ , pipeDocSSH+ , maybeURLCmd+ )+import Darcs.UI.Options ( parseFlags )+import Darcs.UI.Options.All ( debug, compress )+import qualified Darcs.Repository.Ssh as Ssh ( remoteDarcs )+import Darcs.Util.Printer ( Doc, RenderMode(..) )++remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode+remoteApply opts repodir bundle+ = case applyAs opts of+ Nothing+ | isSshUrl repodir -> applyViaSsh opts (splitSshUrl repodir) bundle+ | isHttpUrl repodir -> applyViaUrl opts repodir bundle+ | otherwise -> applyViaLocal opts repodir bundle+ Just un -> if isSshUrl repodir+ then applyViaSshAndSudo opts (splitSshUrl repodir) un bundle+ else applyViaSudo un repodir bundle++applyViaSudo :: String -> String -> Doc -> IO ExitCode+applyViaSudo user repo bundle =+ darcsProgram >>= \darcs ->+ pipeDoc Standard "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle++applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode+applyViaLocal opts repo bundle =+ darcsProgram >>= \darcs ->+ pipeDoc Standard darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle++applyViaUrl :: [DarcsFlag] -> String -> Doc -> IO ExitCode+applyViaUrl opts repo bundle =+ do maybeapply <- maybeURLCmd "APPLY" repo+ case maybeapply of+ Nothing -> applyViaLocal opts repo bundle+ Just apply ->+ do let (cmd, args) = breakCommand apply+ pipeDoc Standard cmd (args ++ [repo]) bundle++applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode+applyViaSsh opts repo =+ pipeDocSSH (parseFlags compress opts) Standard repo+ [Ssh.remoteDarcs (remoteDarcs opts) ++" apply --all "++unwords (applyopts opts)+++ " --repodir '"++sshRepo repo++"'"]++applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO ExitCode+applyViaSshAndSudo opts repo username =+ pipeDocSSH (parseFlags compress opts) Standard repo+ ["sudo -u "++username++" "++Ssh.remoteDarcs (remoteDarcs opts)+++ " apply --all --repodir '"++sshRepo repo++"'"]++applyopts :: [DarcsFlag] -> [String]+applyopts opts = if parseFlags debug opts then ["--debug"] else []
+ src/Darcs/UI/RunCommand.hs view
@@ -0,0 +1,222 @@+-- Copyright (C) 2002,2003,2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+-- | This is the actual heavy lifter code, which is responsible for parsing the+-- arguments and then running the command itself.+module Darcs.UI.RunCommand ( runTheCommand ) where++import Prelude hiding ( (^) )+import Data.Functor ((<$>))+import Control.Monad ( unless, when )+import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ),+ OptDescr( Option ),+ getOpt )+import System.Exit ( ExitCode ( ExitSuccess ), exitWith )++import Darcs.UI.Options ( DarcsOption, (^), odesc, oparse, parseFlags, optDescr )+import Darcs.UI.Options.All+ ( stdCmdActions, StdCmdAction(..)+ , anyVerbosity, verbosity, Verbosity(..), network, NetworkOptions(..)+ , preHook, postHook )++import Darcs.UI.Defaults ( applyDefaults )+import Darcs.UI.Flags ( DarcsFlag (NewRepo), toMatchFlags, fixRemoteRepos )+import Darcs.UI.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ),+ CommandControl,+ DarcsCommand,+ commandName,+ commandCommand,+ commandPrereq,+ commandExtraArgHelp,+ commandExtraArgs,+ commandArgdefaults,+ commandGetArgPossibilities,+ commandOptions,+ commandParseOptions,+ wrappedCommandName,+ disambiguateCommands,+ getCommandHelp, getCommandMiniHelp,+ getSubcommands,+ extractCommands,+ superName,+ subusage+ , formatPath+ )+import Darcs.UI.Commands.GZCRCs ( doCRCWarnings )+import Darcs.UI.Commands.Clone ( makeRepoName, cloneToSSH )++import Darcs.UI.External ( viewDoc )+import Darcs.Util.AtExit ( atexit )+import Darcs.Util.Global ( setDebugMode, setTimingsMode )+import Darcs.Patch.Match ( checkMatchSyntax )+import Darcs.Util.Progress ( setProgressMode )+import Darcs.Util.Path ( AbsolutePath, getCurrentDirectory, toPath, ioAbsoluteOrRemote, makeAbsolute )++import Darcs.Repository.Test ( runPosthook, runPrehook )+import Data.List ( intercalate )+import Darcs.Util.Printer ( text )+import Darcs.Util.Download ( setDebugHTTP, disableHTTPPipelining )+import Darcs.Util.Text ( chompTrailingNewline )+++runTheCommand :: [CommandControl] -> String -> [String] -> IO ()+runTheCommand commandControlList cmd args =+ either fail rtc $ disambiguateCommands commandControlList cmd args+ where+ rtc (CommandOnly c, as) = runCommand Nothing c as+ rtc (SuperCommandOnly c, as) = runRawSupercommand c as+ rtc (SuperCommandSub c s, as) = runCommand (Just c) s as++runCommand :: Maybe (DarcsCommand pf1) -> DarcsCommand pf2 -> [String] -> IO ()+runCommand _ _ args -- Check for "dangerous" typoes...+ | "-all" `elem` args = -- -all indicates --all --look-for-adds!+ fail "Are you sure you didn't mean --all rather than -all?"+runCommand msuper cmd args = do+ old_wd <- getCurrentDirectory+ let options = commandOptions old_wd cmd+ case getOpt Permute options args of+ (cmdline_flags,orig_extra,[]) -> do+ prereq_errors <- commandPrereq cmd cmdline_flags+ -- Important: we must applyDefaults only after commandPrereq has been run,+ -- so it sees the cwd after commandPrereq has changed it.+ flags <- applyDefaults (fmap commandName msuper) cmd cmdline_flags+ case parseFlags stdCmdActions flags of+ Just Help -> viewDoc $ text $ getCommandHelp msuper cmd+ Just ListOptions -> do+ setProgressMode False+ file_args <- commandGetArgPossibilities cmd+ putStrLn $ unlines $ getOptionsOptions options : file_args+ Just Disable ->+ fail $ "Command "++commandName cmd++" disabled with --disable option!"+ Nothing -> case prereq_errors of+ Left complaint -> fail $+ "Unable to " ++ formatPath ("darcs " ++ superName msuper ++ commandName cmd) +++ " here.\n\n" ++ complaint+ Right () -> do+ extra <- commandArgdefaults cmd flags old_wd orig_extra+ case extraArgumentsError extra cmd msuper of+ Nothing -> runWithHooks cmd old_wd flags extra+ Just msg -> fail msg+ (_,_,ermsgs) -> fail $ chompTrailingNewline(unlines ermsgs)++{- removed the --debug-verbose flag+ where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts+ | otherwise = opts+-}++withHookOpts :: DarcsOption a (t2 -> t3 -> t4 -> t1)+ -> (t2 -> t3 -> t4 -> t -> t1) -> [DarcsFlag] -> t -> a+withHookOpts opts runHook flags path = oparse opts runHook' flags where+ runHook' mcmd ask verb = runHook mcmd ask verb path++runWithHooks :: DarcsCommand pf+ -> AbsolutePath -> [DarcsFlag] -> [String] -> IO ()+runWithHooks cmd old_wd flags extra = do+ -- NOTE: we must get the cwd again because commandPrereq has the side-effect of changing it.+ new_wd <- getCurrentDirectory+ checkMatchSyntax $ toMatchFlags flags+ -- set any global variables+ oparse (anyVerbosity ^ network) setGlobalVariables flags+ -- actually run the command and its hooks+ preHookExitCode <- withHookOpts (preHook ^ verbosity) runPrehook flags new_wd+ if preHookExitCode /= ExitSuccess+ then exitWith preHookExitCode+ else do fixedFlags <- fixRemoteRepos old_wd flags+ phDir <- getPosthookDir new_wd cmd fixedFlags extra+ let parsedFlags = commandParseOptions cmd fixedFlags+ commandCommand cmd (new_wd, old_wd) parsedFlags extra+ postHookExitCode <- withHookOpts (postHook ^ verbosity) runPosthook flags phDir+ exitWith postHookExitCode++setGlobalVariables :: Bool -> Bool -> Verbosity -> Bool -> NetworkOptions -> IO ()+setGlobalVariables debug debugHttp verb timings net = do+ when timings setTimingsMode+ when debug setDebugMode+ when debugHttp setDebugHTTP+ when (verb == Quiet) $ setProgressMode False+ when (noHttpPipelining net) disableHTTPPipelining+ unless (verb == Quiet) $ atexit $ doCRCWarnings (verb == Verbose)++-- | Returns the working directory for the posthook. For most commands, the+-- first parameter is returned. For the \'get\' command, the path of the newly+-- created repository is returned if it is not an ssh url.+getPosthookDir :: AbsolutePath -> DarcsCommand pf -> [DarcsFlag] -> [String] -> IO AbsolutePath+getPosthookDir new_wd cmd flags extra | commandName cmd `elem` ["get","clone"] = do+ case extra of+ [inrepodir, outname] -> getPosthookDir new_wd cmd (NewRepo outname:flags) [inrepodir]+ [inrepodir] ->+ case cloneToSSH flags of+ Nothing -> do+ repodir <- toPath <$> ioAbsoluteOrRemote inrepodir+ reponame <- makeRepoName False flags repodir+ return $ makeAbsolute new_wd reponame+ _ -> return new_wd+ _ -> fail "You must provide 'clone' with either one or two arguments."+getPosthookDir new_wd _ _ _ = return new_wd+++-- | Checks if the number of extra arguments matches the number of extra+-- arguments supported by the command as specified in `commandExtraArgs`.+-- Extra arguments are arguments that follow the command but aren't+-- considered a flag. In `darcs push xyz`, xyz would be an extra argument.+extraArgumentsError :: [String] -- extra commands provided by user+ -> DarcsCommand pf1+ -> Maybe (DarcsCommand pf2)+ -> Maybe String+extraArgumentsError extra cmd msuper+ | extraArgsCmd < 0 = Nothing+ | extraArgsInput > extraArgsCmd = Just badArg+ | extraArgsInput < extraArgsCmd = Just missingArg+ | otherwise = Nothing+ where+ extraArgsInput = length extra+ extraArgsCmd = commandExtraArgs cmd+ badArg = "Bad argument: `" ++ unwords extra +++ "'\n" ++ getCommandMiniHelp msuper cmd+ missingArg = "Missing argument: " ++ nthArg (length extra + 1) +++ "\n" ++ getCommandMiniHelp msuper cmd+ nthArg n = nthOf n (commandExtraArgHelp cmd)+ nthOf 1 (h:_) = h+ nthOf n (_:hs) = nthOf (n-1) hs+ nthOf _ [] = "UNDOCUMENTED"++getOptionsOptions :: [OptDescr DarcsFlag] -> String+getOptionsOptions = intercalate "\n" . concatMap goo+ where+ goo (Option _ os _ _) = map ("--"++) os++runRawSupercommand :: DarcsCommand pf -> [String] -> IO ()+runRawSupercommand super [] =+ fail $ "Command '"++ commandName super ++"' requires a subcommand!\n\n"+ ++ subusage super+runRawSupercommand super args = do+ cwd <- getCurrentDirectory+ case getOpt RequireOrder (map (optDescr cwd) (odesc stdCmdActions)) args of+ -- note: we do not apply defaults here+ (flags,_,[]) -> case parseFlags stdCmdActions flags of+ Just Help ->+ viewDoc $ text $ getCommandHelp Nothing super+ Just ListOptions -> do+ putStrLn "--help"+ mapM_ (putStrLn . wrappedCommandName) (extractCommands $ getSubcommands super)+ Just Disable -> do+ fail $ "Command " ++ commandName super +++ " disabled with --disable option!"+ Nothing ->+ fail $ "Invalid subcommand!\n\n" ++ subusage super+ (_,_,ermsgs) -> fail $ chompTrailingNewline(unlines ermsgs)
+ src/Darcs/UI/SelectChanges.hs view
@@ -0,0 +1,1112 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+++module Darcs.UI.SelectChanges+ ( -- * Working with changes+ selectChanges+ , WhichChanges(..)+ , viewChanges+ , withSelectedPatchFromRepo+ , runSelection+ , selectionContextPrim+ , selectionContextGeneric+ , selectionContext+ , PatchSelectionContext(allowSkipAll)+ , printSummary+ -- * Interactive selection utils+ , PatchSelectionOptions(..)+ , InteractiveSelectionM+ , InteractiveSelectionContext(..)+ -- ** Navigating the patchset+ , currentPatch+ , skipMundane+ , skipOne+ , backOne+ , backAll+ , showCur+ -- ** Decisions+ , decide+ , decideWholeFile+ -- ** Prompts and queries+ , isSingleFile+ , currentFile+ , promptUser+ , prompt+ , KeyPress(..)+ , keysFor+ , helpFor+ , askAboutDepends+ ) where++import Prelude hiding ( (^) )+import Control.Monad ( liftM, unless, when, (>=>) )+import Control.Monad.Identity ( Identity (..) )+import Control.Monad.Reader+ ( Reader, ReaderT, asks+ , runReader, runReaderT+ )+import Control.Monad.State+ ( StateT, execStateT, gets+ , modify, runStateT+ )+import Control.Monad.Trans ( liftIO )+import Data.Char ( toUpper )+import Data.List ( intercalate, union )+import Data.Maybe ( isJust, isNothing, catMaybes )+import System.Exit ( exitSuccess )++import Darcs.Patch+ ( Patchy, PrimPatch, RepoPatch, PrimOf+ , commuteFLorComplain, invert+ , listTouchedFiles, anonymous, fromPrims+ )+import qualified Darcs.Patch ( thing, things, summary )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Choices+ ( PatchChoices, Slot (..), LabelledPatch+ , patchChoicesLps, forceFirsts+ , forceFirst, forceLast, forceMatchingFirst+ , forceMatchingLast, getChoices+ , makeEverythingLater, makeEverythingSooner+ , makeUncertain, patchChoices+ , patchChoicesLpsSub, patchSlot'+ , refineChoices, selectAllMiddles+ , separateFirstFromMiddleLast+ , substitute, label, lpPatch+ )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.Match ( haveNonrangeMatch, matchAPatch, matchAPatchread )+import Darcs.Patch.Named ( Named )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info, n2pia )+import Darcs.Patch.Set ( PatchSet(..), newset2RL )+import Darcs.Patch.Show ( ShowPatch )+import Darcs.Patch.Split ( Splitter (..) )+import qualified Darcs.Patch.TouchesFiles as TouchesFiles+import Darcs.Patch.Type ( PatchType (..) )+import Darcs.Patch.Witnesses.Eq ( unsafeCompare )+import Darcs.Patch.Witnesses.Ordered+ ( (:>) (..), (:||:) (..), FL (..)+ , RL (..), filterFL, lengthFL, mapFL+ , mapFL_FL, reverseFL, spanFL, spanFL_M+ , (+<+), (+>+), reverseRL+ )+import Darcs.Patch.Witnesses.Sealed+ ( FlippedSeal (..), Sealed2 (..)+ , flipSeal, seal2, unseal2+ )+import Darcs.Patch.Witnesses.WZipper+ ( FZipper (..), left, right+ , rightmost, toEnd, toStart+ )+import Darcs.Repository ( Repository, readRepo, readTentativeRepo )+import Darcs.UI.External ( editText )+import Darcs.UI.Options.All+ ( Verbosity(..), Summary(..), DiffAlgorithm(..)+ , WithContext(..), SelectDeps(..), MatchFlag )+import Darcs.UI.PrintPatch+ ( printFriendly, printPatch+ , printPatchPager, showFriendly )+import Darcs.Util.English ( Noun (..), englishNum )+import Darcs.Util.Printer ( prefix, putDocLn )+import Darcs.Util.Prompt ( PromptConfig (..), askUser, promptChar )+import Storage.Hashed.Tree ( Tree )+++-- | When asking about patches, we either ask about them in+-- oldest-first or newest first (with respect to the current ordering+-- of the repository), and we either want an initial segment or a+-- final segment of the poset of patches.+--+-- @First@: ask for an initial+-- segment, first patches first (default for all pull-like commands)+--+-- @FirstReversed@: ask for an initial segment, last patches first+-- (used to ask about dependencies in record, and for pull-like+-- commands with the @--reverse@ flag).+--+-- @LastReversed@: ask for a final segment, last patches first. (default+-- for unpull-like commands, except for selecting *primitive* patches in+-- rollback)+--+-- @Last@: ask for a final segment, first patches first. (used for selecting+-- primitive patches in rollback, and for unpull-like commands with the+-- @--reverse@ flag+data WhichChanges = Last | LastReversed | First | FirstReversed deriving (Eq, Show)++-- | A @WhichChanges@ is backwards if the order in which patches are presented+-- is the opposite of the order of dependencies for that operation.+backward :: WhichChanges -> Bool+backward w = w == Last || w == FirstReversed++-- | The type of the function we use to filter patches when @--match@ is+-- given.+data MatchCriterion p = MatchCriterion+ { mcHasNonrange :: Bool+ , mcFunction :: WhichChanges -> Sealed2 p -> Bool+ }++data PatchSelectionOptions = PatchSelectionOptions+ { verbosity :: Verbosity+ , matchFlags :: [MatchFlag]+ , diffAlgorithm :: DiffAlgorithm+ , interactive :: Bool+ , selectDeps :: SelectDeps+ , summary :: Summary+ , withContext :: WithContext+ }++-- | A @PatchSelectionContext@ contains all the static settings for selecting+-- patches. See "PatchSelectionM"+data PatchSelectionContext p = PSC { opts :: PatchSelectionOptions+ , splitter :: Maybe (Splitter p)+ , files :: Maybe [FilePath]+ , matchCriterion :: MatchCriterion p+ , jobname :: String+ , allowSkipAll :: Bool+ , pristine :: Maybe (Tree IO)+ , whichChanges :: WhichChanges+ }++-- | A 'PatchSelectionContext' for selecting 'Prim' patches.+selectionContextPrim :: PrimPatch prim+ => WhichChanges+ -> String+ -> PatchSelectionOptions+ -> Maybe (Splitter prim)+ -> Maybe [FilePath]+ -> Maybe (Tree IO)+ -> PatchSelectionContext prim+selectionContextPrim whch jn o spl fs p =+ PSC { opts = o+ , splitter = spl+ , files = fs+ , matchCriterion = triv+ , jobname = jn+ , allowSkipAll = True+ , pristine = p+ , whichChanges = whch+ }++-- | A 'PatchSelectionContext' for selecting full patches ('PatchInfoAnd' patches)+selectionContext :: (RepoPatch p) => WhichChanges -> String -> PatchSelectionOptions -> Maybe (Splitter (PatchInfoAnd p))+ -> Maybe [FilePath] -> PatchSelectionContext (PatchInfoAnd p)+selectionContext whch jn o spl fs =+ PSC { opts = o+ , splitter = spl+ , files = fs+ , matchCriterion = iswanted (seal2 . hopefully) (matchFlags o)+ , jobname = jn+ , allowSkipAll = True+ , pristine = Nothing+ , whichChanges = whch+ }++-- | A generic 'PatchSelectionContext'.+selectionContextGeneric :: (RepoPatch p, Invert q)+ => (forall wX wY . q wX wY -> Sealed2 (Named p))+ -> WhichChanges+ -> String+ -> PatchSelectionOptions+ -> Maybe [FilePath]+ -> PatchSelectionContext q+selectionContextGeneric extract whch jn o fs =+ PSC { opts = o+ , splitter = Nothing+ , files = fs+ , matchCriterion = iswanted extract (matchFlags o)+ , jobname = jn+ , allowSkipAll = True+ , pristine = Nothing+ , whichChanges = whch+ }++-- | The dynamic parameters for interactive selection of patches.+data InteractiveSelectionContext p wX wY = ISC { total :: Int+ -- ^ total number of patches+ , current :: Int+ -- ^ number of already-seen patches+ , lps :: FZipper (LabelledPatch p) wX wY+ -- ^ the patches we offer+ , choices :: PatchChoices p wX wY+ -- ^ the user's choices+ }++type PatchSelectionM p a = ReaderT (PatchSelectionContext p) a++type InteractiveSelectionM p wX wY a =+ StateT (InteractiveSelectionContext p wX wY)+ (PatchSelectionM p IO) a++type PatchSelection p wX wY =+ PatchSelectionM p IO ((FL p :> FL p) wX wY)++-- Common match criteria++-- | For commands without @--match@, 'triv' matches all patches+triv :: MatchCriterion p+triv = MatchCriterion { mcHasNonrange = False, mcFunction = \ _ _ -> True }++-- | 'iswanted' selects patches according to the given match flags+iswanted :: forall p q+ . (RepoPatch p, Invert q)+ => (forall wX wY . q wX wY -> Sealed2 (Named p))+ -> [MatchFlag]+ -> MatchCriterion q+iswanted extract mflags = MatchCriterion+ { mcHasNonrange = haveNonrangeMatch (PatchType :: PatchType p) mflags+ , mcFunction = isWantedMcFunction+ }+ where+ isWantedMcFunction x = unseal2 $ iw x+ iw First = unseal2 (matchAPatch mflags) . extract+ iw Last = unseal2 (matchAPatch mflags) . extract+ iw LastReversed = unseal2 (matchAPatch mflags) . extract . invert+ iw FirstReversed = unseal2 (matchAPatch mflags) . extract . invert++liftR :: Monad m => Reader r a -> ReaderT r m a+liftR = asks . runReader++-- | runs a 'PatchSelection' action in the given 'PatchSelectionContext'.+runSelection :: (Patchy p) => PatchSelection p wX wY -> PatchSelectionContext p+ -> IO ((FL p :> FL p) wX wY)+runSelection = runReaderT++-- | Select patches from a @FL@.+selectChanges :: forall p wX wY . (Patchy p, PatchInspect p, ShowPatch p, ApplyState p ~ Tree) =>+ FL p wX wY+ -> PatchSelection p wX wY+selectChanges ps = do+ whch <- asks whichChanges+ case whch of+ First -> normal ps+ Last -> normal ps+ FirstReversed -> reversed ps+ LastReversed -> reversed ps+ where normal = sc1+ reversed = return . invert >=> sc1 >=> return . invertC++sc1 :: forall p wX wY . (Patchy p, PatchInspect p, ShowPatch p, ApplyState p ~ Tree) =>+ FL p wX wY+ -> PatchSelection p wX wY+sc1 =+ (liftR . patchesToConsider)+ >=> realSelectChanges+ >=> (\ps -> do whch <- asks whichChanges ; return $ selectedPatches whch ps)+ >=> (liftR . canonizeAfterSplitter)++-- | inverses the choices that have been made+invertC :: (Patchy p) => (FL p :> FL p) wX wY -> (FL p :> FL p) wY wX+invertC (a :> b) = invert b :> invert a++-- | Shows the patch that is actually being selected the way the user+-- should see it.+repr :: (Patchy p) => WhichChanges -> Sealed2 p -> Sealed2 p+repr First (Sealed2 p) = Sealed2 p+repr LastReversed (Sealed2 p) = Sealed2 (invert p)+repr Last (Sealed2 p) = Sealed2 p+repr FirstReversed (Sealed2 p) = Sealed2 (invert p)++-- | The equivalent of 'selectChanges' for the @darcs changes@ command+viewChanges :: (Patchy p, ShowPatch p, ApplyState p ~ Tree) => PatchSelectionOptions -> [Sealed2 p] -> IO ()+viewChanges ps_opts = textView ps_opts Nothing 0 []++-- | The type of the answers to a "shall I [wiggle] that [foo]?" question+-- They are found in a [[KeyPress]] bunch, each list representing a set of+-- answers which belong together+data KeyPress = KeyPress { kp :: Char+ , kpHelp :: String }++-- | Generates the help for a set of basic and advanced 'KeyPress' groups.+helpFor :: String -> [[KeyPress]] -> [[KeyPress]] -> String+helpFor jn basicKeypresses advancedKeyPresses =+ unlines $ [ "How to use "++jn++":" ]+ ++ intercalate [""] (map (map help) keypresses)+ ++ [ ""+ , "?: show this help"+ , ""+ , "<Space>: accept the current default (which is capitalized)"+ ]+ where help i = kp i:(": "++kpHelp i)+ keypresses = basicKeypresses ++ advancedKeyPresses++-- | The keys used by a list of 'keyPress' groups.+keysFor :: [[KeyPress]] -> [Char]+keysFor = concatMap (map kp)++-- | The function for selecting a patch to amend record. Read at your own risks.+withSelectedPatchFromRepo ::+ forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree)+ => String -- name of calling command (always "amend" as of now)+ -> Repository p wR wU wT+ -> PatchSelectionOptions+ -> (forall wA . (FL (PatchInfoAnd p) :> PatchInfoAnd p) wA wR -> IO ())+ -> IO ()+withSelectedPatchFromRepo jn repository o job = do+ patchSet <- readRepo repository+ sp <- wspfr jn (matchAPatchread $ matchFlags o) (newset2RL patchSet) NilFL+ case sp of+ Just (FlippedSeal (skipped :> selected')) -> job (skipped :> selected')+ Nothing ->+ putStrLn $ "Cancelling " ++ jn ++ " since no patch was selected."++data SkippedReason = SkippedAutomatically | SkippedManually++data WithSkipped p wX wY = WithSkipped { _skippedReason :: SkippedReason, skippedPatch :: p wX wY }++-- | This ensures that the selected patch commutes freely with the skipped+-- patches, including pending and also that the skipped sequences has an+-- ending context that matches the recorded state, z, of the repository.+wspfr :: forall p wX wY wU. (RepoPatch p, ApplyState p ~ Tree)+ => String+ -> (forall wA wB . (PatchInfoAnd p) wA wB -> Bool)+ -> RL (PatchInfoAnd p) wX wY+ -> FL (WithSkipped (PatchInfoAnd p)) wY wU+ -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd p) :> PatchInfoAnd p) wU))+wspfr _ _ NilRL _ = return Nothing+wspfr jn matches remaining@(p:<:pps) skipped+ | not $ matches p = wspfr jn matches pps+ (WithSkipped SkippedAutomatically p :>: skipped)+ | otherwise =+ case commuteFLorComplain (p :> mapFL_FL skippedPatch skipped) of+ Left _ -> do putStrLn "\nSkipping depended-upon patch:"+ defaultPrintFriendly p+ wspfr jn matches pps (WithSkipped SkippedAutomatically p :>: skipped)++ Right (skipped' :> p') -> do+ defaultPrintFriendly p+ yorn <- promptChar+ PromptConfig { pPrompt = prompt'+ , pBasicCharacters = keysFor basicOptions+ , pAdvancedCharacters = keysFor advancedOptions+ , pDefault = Just 'n'+ , pHelp = "?h" }+ case yorn of+ 'y' -> return $ Just $ flipSeal $ skipped' :> p'+ 'n' -> nextPatch+ 'j' -> nextPatch+ 'k' -> previousPatch remaining skipped+ 'v' -> printPatch p >> repeatThis+ 'p' -> printPatchPager p >> repeatThis+ 'x' -> do putDocLn $ prefix " " $ Darcs.Patch.summary p+ repeatThis+ 'q' -> do putStrLn $ jnCapital ++ " cancelled."+ exitSuccess+ _ -> do putStrLn $ helpFor jn basicOptions advancedOptions+ repeatThis+ where jnCapital = toUpper (head jn) : tail jn+ repeatThis = wspfr jn matches (p:<:pps) skipped+ prompt' = "Shall I " ++ jn ++ " this patch?"+ nextPatch = wspfr jn matches pps (WithSkipped SkippedManually p:>:skipped)+ previousPatch :: RL (PatchInfoAnd p) wX wQ+ -> FL (WithSkipped (PatchInfoAnd p)) wQ wU+ -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd p) :> PatchInfoAnd p) wU))+ previousPatch remaining' NilFL = wspfr jn matches remaining' NilFL+ previousPatch remaining' (WithSkipped sk prev :>: skipped'') =+ case sk of+ SkippedManually -> wspfr jn matches (prev :<: remaining') skipped''+ SkippedAutomatically -> previousPatch (prev :<: remaining') skipped''+ basicOptions =+ [[ KeyPress 'y' (jn ++ " this patch")+ , KeyPress 'n' ("don't " ++ jn ++ " it")+ , KeyPress 'j' "skip to next patch"+ , KeyPress 'k' "back up to previous patch"+ ]]+ advancedOptions =+ [[ KeyPress 'v' "view this patch in full"+ , KeyPress 'p' "view this patch in full with pager"+ , KeyPress 'x' "view a summary of this patch"+ , KeyPress 'q' ("cancel " ++ jn)+ ]]+ defaultPrintFriendly =+ printFriendly Nothing NormalVerbosity NoSummary NoContext++-- After selecting with a splitter, the results may not be canonical+canonizeAfterSplitter :: (FL p :> FL p) wX wY -> Reader (PatchSelectionContext p) ((FL p :> FL p) wX wY)+canonizeAfterSplitter (x :> y) =+ do o <- asks opts+ mspl <- asks splitter+ let canonizeIfNeeded = maybe (\_ b -> b) canonizeSplit mspl+ da = diffAlgorithm o+ return $ canonizeIfNeeded da x :> canonizeIfNeeded da y++realSelectChanges :: forall p wX wY.+ (Patchy p, ShowPatch p, PatchInspect p, ApplyState p ~ Tree)+ => PatchChoices p wX wY+ -> PatchSelectionM p IO (PatchChoices p wX wY)+realSelectChanges autoChoices =+ do+ o <- asks opts+ whch <- asks whichChanges+ if not $ interactive o+ then return $ promote whch autoChoices+ else refineChoices textSelect autoChoices+ where forward whch = not $ backward whch+ promote whch =+ if forward whch+ then makeEverythingSooner+ else makeEverythingLater++-- | When using @--match@, remove unmatched patches not depended upon by matched+-- patches.+deselectUnwanted :: forall p wX wY . Patchy p =>+ PatchChoices p wX wY ->+ Reader (PatchSelectionContext p) (PatchChoices p wX wY)+deselectUnwanted pc =+ do+ o <- asks opts+ mc <- asks matchCriterion+ whichch <- asks whichChanges+ let iswanted_ = mcFunction mc whichch . seal2 . lpPatch+ select = if forward whichch+ then forceMatchingFirst iswanted_+ else forceMatchingLast iswanted_+ deselect = if forward whichch+ then forceMatchingLast (not . iswanted_)+ else forceMatchingFirst (not . iswanted_)+ return $+ if mcHasNonrange mc+ then if selectDeps o == NoDeps+ then deselect pc+ else demote whichch $ select pc+ else pc+ where+ forward whichch = not $ backward whichch+ demote whichch =+ if forward whichch+ then makeEverythingLater+ else makeEverythingSooner++-- | Selects the patches matching the match criterion, and puts them first or last+-- according to whch, while respecting any dependencies.+patchesToConsider :: forall p wX wY+ . (Patchy p, PatchInspect p, ApplyState p ~ Tree)+ => FL p wX wY+ -> Reader (PatchSelectionContext p) (PatchChoices p wX wY)+patchesToConsider ps =+ do+ fs <- asks files+ crit <- asks matchCriterion+ whch <- asks whichChanges+ let deselectNotTouching =+ case whch of+ First -> TouchesFiles.deselectNotTouching+ Last -> TouchesFiles.selectNotTouching+ FirstReversed -> TouchesFiles.selectNotTouching+ LastReversed -> TouchesFiles.deselectNotTouching+ everything = patchChoices ps+ if isNothing fs && not (mcHasNonrange crit)+ then return everything+ else do notUnwanted <- deselectUnwanted everything+ return $ deselectNotTouching fs notUnwanted++-- | Returns the results of a patch selection user interaction+selectedPatches :: Patchy p => WhichChanges -> PatchChoices p wY wZ+ -> (FL p :> FL p) wY wZ+selectedPatches Last pc =+ case getChoices pc of+ fc :> mc :> lc -> mapFL_FL lpPatch (fc +>+ mc) :> mapFL_FL lpPatch lc++selectedPatches First pc =+ case separateFirstFromMiddleLast pc of+ xs :> ys -> mapFL_FL lpPatch xs :> mapFL_FL lpPatch ys++selectedPatches LastReversed pc =+ case separateFirstFromMiddleLast pc of+ xs :> ys -> mapFL_FL lpPatch xs :> mapFL_FL lpPatch ys++selectedPatches FirstReversed pc =+ case getChoices pc of+ fc :> mc :> lc -> mapFL_FL lpPatch (fc +>+ mc) :> mapFL_FL lpPatch lc++-- | Runs a function on the underlying @PatchChoices@ object+liftChoices :: forall p a wX wY . Patchy p =>+ StateT (PatchChoices p wX wY) Identity a+ -> InteractiveSelectionM p wX wY a+liftChoices act = do+ ch <- gets choices+ let (result, _) = runIdentity $ runStateT act ch+ modify $ \isc -> isc {choices = ch} -- Should this be ch or the result of runState?+ return result++-- | @justDone n@ notes that @n@ patches have just been processed+justDone :: Patchy p => Int -> InteractiveSelectionM p wX wY ()+justDone n = modify $ \isc -> isc{ current = current isc + n}++-- | The actual interactive selection process.+textSelect :: forall p wX wY . (Patchy p, ShowPatch p, PatchInspect p, ApplyState p ~ Tree)+ => FL (LabelledPatch p) wX wY -> PatchChoices p wX wY+ -> PatchSelectionM p IO (PatchChoices p wX wY)+textSelect lps' pcs = do+ userSelection <- execStateT (skipMundane >>+ showCur >>+ textSelectIfAny)+ ISC { total = lengthFL lps'+ , current = 0+ , lps = FZipper NilRL lps'+ , choices = pcs }+ return $ choices userSelection+ where textSelectIfAny = do+ z <- gets lps+ unless (rightmost z) $+ textSelect'++textSelect' :: (Patchy p, ShowPatch p, PatchInspect p, ApplyState p ~ Tree)+ => InteractiveSelectionM p wX wY ()+textSelect' = do+ z <- gets lps+ done <- if not $ rightmost z+ then textSelectOne+ else lastQuestion+ unless done $ textSelect'++optionsBasic :: String -> String -> [KeyPress]+optionsBasic jn aThing =+ [ KeyPress 'y' (jn++" this "++aThing)+ , KeyPress 'n' ("don't "++jn++" it")+ , KeyPress 'w' "wait and decide later, defaulting to no" ]++optionsFile :: String -> [KeyPress]+optionsFile jn =+ [ KeyPress 's' ("don't "++jn++" the rest of the changes to this file")+ , KeyPress 'f' (jn++" the rest of the changes to this file") ]++optionsView :: String -> String -> [KeyPress]+optionsView aThing someThings =+ [ KeyPress 'v' ("view this "++aThing++" in full")+ , KeyPress 'p' ("view this "++aThing++" in full with pager")+ , KeyPress 'l' ("list all selected "++someThings) ]++optionsSummary :: String -> [KeyPress]+optionsSummary aThing =+ [ KeyPress 'x' ("view a summary of this "++aThing) ]++optionsQuit :: String -> Bool -> String -> [KeyPress]+optionsQuit jn allowsa someThings =+ [ KeyPress 'd' (jn++" selected "++someThings++", skipping all the remaining "++someThings)+ | allowsa ]+ +++ [ KeyPress 'a' (jn++" all the remaining "++someThings)+ , KeyPress 'q' ("cancel "++jn) ]++optionsNav :: String -> Bool -> [KeyPress]+optionsNav aThing isLast=+ [ KeyPress 'j' ("skip to next "++ aThing) | not isLast ]+ +++ [ KeyPress 'k' ("back up to previous "++ aThing)+ , KeyPress 'g' ("start over from the first "++aThing)]++optionsSplit :: Maybe (Splitter a) -> String -> [KeyPress]+optionsSplit split aThing+ | Just _ <- split+ = [ KeyPress 'e' ("interactively edit this "++ aThing) ]+ | otherwise = []++optionsLast :: String -> String -> ([[KeyPress]], [[KeyPress]])+optionsLast jn aThing =+ (optionsNav aThing True:+ [[ KeyPress 'y' "confirm this operation"+ , KeyPress 'q' ("cancel " ++ jn) ]+ , [ KeyPress 'l' "list all selected" ]+ ]+ ,[[KeyPress 'a' "confirm this operation"+ , KeyPress 'd' "confirm this operation"+ , KeyPress 'n' ("cancel " ++ jn) ]])++options :: forall p wX wY . (Patchy p, ShowPatch p) => Bool ->+ InteractiveSelectionM p wX wY ([[KeyPress]],[[KeyPress]])+options single = do+ split <- asks splitter+ jn <- asks jobname+ allowsa <- asks allowSkipAll+ aThing <- thing+ someThings <- things+ o <- asks opts+ return ([optionsBasic jn aThing]+ ,[optionsSplit split aThing]+ ++ [optionsFile jn | single]+ ++ [optionsView aThing someThings +++ if summary o == YesSummary+ then []+ else optionsSummary aThing]+ ++ [optionsQuit jn allowsa someThings]+ ++ [optionsNav aThing False]+ )++-- | Returns a @Sealed2@ version of the patch we are asking the user+-- about.+currentPatch :: forall p wX wY . Patchy p =>+ InteractiveSelectionM p wX wY+ (Maybe (Sealed2 (LabelledPatch p)))+currentPatch = do+ (FZipper _ lps_todo) :: FZipper (LabelledPatch p) wX wY <- gets lps+ case lps_todo of+ NilFL -> return Nothing+ (lp:>:_) -> return $ Just (Sealed2 lp)++-- | Returns the patches we have yet to ask the user about.+todo :: forall p wX wY . Patchy p+ => InteractiveSelectionM p wX wY+ (FlippedSeal (FL (LabelledPatch p)) wY)+todo = do+ (FZipper _ lps_todo) <- gets lps+ return (FlippedSeal lps_todo)++-- | Modify the underlying @PatchChoices@ by some function+modChoices :: forall p wX wY . Patchy p =>+ (PatchChoices p wX wY -> PatchChoices p wX wY)+ -> InteractiveSelectionM p wX wY ()+modChoices f = modify $ \isc -> isc{choices = f $ choices isc}++-- | returns @Just f@ if the 'currentPatch' only modifies @f@,+-- @Nothing@ otherwise.+currentFile :: forall p wX wY . (Patchy p, PatchInspect p)+ => InteractiveSelectionM p wX wY (Maybe FilePath)+currentFile = do+ c <- currentPatch+ return $ case c of+ Nothing -> Nothing+ Just (Sealed2 lp) ->+ case listTouchedFiles lp of+ [f] -> Just f+ _ -> Nothing++-- | @decide True@ selects the current patch, and @decide False@ deselects+-- it.+decide :: forall p wX wY wT wU . Patchy p => Bool+ -> LabelledPatch p wT wU+ -> InteractiveSelectionM p wX wY ()+decide takeOrDrop lp = do+ whch <- asks whichChanges+ if backward whch == takeOrDrop -- we go backward xor we are dropping+ then modChoices $ forceLast (label lp)+ else modChoices $ forceFirst (label lp)++-- | like 'decide', but for all patches touching @file@+decideWholeFile :: forall p wX wY. (Patchy p, PatchInspect p) =>+ FilePath -> Bool -> InteractiveSelectionM p wX wY ()+decideWholeFile file takeOrDrop =+ do+ FlippedSeal lps_todo <- todo+ let patches_to_skip =+ filterFL (\lp' -> listTouchedFiles lp' == [file]) lps_todo+ mapM_ (unseal2 $ decide takeOrDrop) patches_to_skip++-- | Undecide the current patch.+postponeNext :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY ()+postponeNext =+ do+ Just (Sealed2 lp) <- currentPatch+ modChoices $ makeUncertain (label lp)++-- | Focus the next patch.+skipOne :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY ()+skipOne = modify so+ where so x = x{lps = right (lps x), current = current x +1}++-- | Focus the previous patch.+backOne :: forall p wX wY . Patchy p => InteractiveSelectionM p wX wY ()+backOne = modify so+ where so isc = isc{lps = left (lps isc), current = max (current isc-1) 0}++-- | Split the current patch (presumably a hunk), and add the replace it+-- with its parts.+splitCurrent :: forall p wX wY . Patchy p+ => Splitter p+ -> InteractiveSelectionM p wX wY ()+splitCurrent s = do+ FZipper lps_done (lp:>:lps_todo) <- gets lps+ o <- asks opts+ case applySplitter s (diffAlgorithm o) (lpPatch lp) of+ Nothing -> return ()+ Just (text, parse) ->+ do+ newText <- liftIO $ editText "darcs-patch-edit" text+ case parse newText of+ Nothing -> return ()+ Just ps -> do+ lps_new <- liftIO . return . snd+ $ patchChoicesLpsSub (Just (label lp)) ps+ modify $ \isc -> isc { total = total isc + lengthFL lps_new - 1+ , lps = FZipper lps_done+ (lps_new +>+ lps_todo)+ , choices = substitute+ (seal2 (lp :||: lps_new))+ (choices isc)+ }++-- | Returns a list of the currently selected patches, in+-- their original context, i.e., not commuted past unselected+-- patches.+selected :: forall p wX wY. Patchy p =>+ InteractiveSelectionM p wX wY [Sealed2 p]+selected = do+ whichch <- asks whichChanges+ c <- gets choices+ (first_chs :> _ :> last_chs) <- return $ getChoices c+ return $ if backward whichch+ then+ mapFL (repr whichch . Sealed2 . lpPatch) last_chs+ else+ mapFL (repr whichch . Sealed2 . lpPatch) first_chs++-- | Prints the list of the selected patches. See 'selected'.+printSelected :: (Patchy p, ShowPatch p) =>+ InteractiveSelectionM p wX wY ()+printSelected = do+ someThings <- things+ o <- asks opts+ s <- selected+ liftIO $ do+ putStrLn $ "---- Already selected "++someThings++" ----"+ mapM_ (putDocLn . unseal2 (showFriendly (verbosity o) (summary o))) s+ putStrLn $ "---- end of already selected "++someThings++" ----"++printSummary :: forall p wX wY . ShowPatch p => p wX wY -> IO ()+printSummary = putDocLn . prefix " " . Darcs.Patch.summary++-- | Skips all remaining patches.+skipAll :: forall p wX wY . Patchy p =>+ InteractiveSelectionM p wX wY ()+skipAll = modify $ \isc -> isc {lps = toEnd $ lps isc}++backAll :: forall p wX wY . Patchy p =>+ InteractiveSelectionM p wX wY ()+backAll = modify $ \isc -> isc {lps = toStart $ lps isc+ ,current = 0}++isSingleFile :: PatchInspect p => p wX wY -> Bool+isSingleFile p = length (listTouchedFiles p) == 1++askConfirmation :: forall p wX wY . Patchy p =>+ InteractiveSelectionM p wX wY ()+askConfirmation = do+ jn <- asks jobname+ liftIO $ when (jn `elem` ["unpull", "unrecord", "obliterate"]) $ do+ yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? "+ case yorn of+ ('y':_) -> return ()+ _ -> exitSuccess++-- | The singular form of the noun for items of type @p@.+thing :: (Patchy p, ShowPatch p) => InteractiveSelectionM p wX wY String+thing = (Darcs.Patch.thing . helper) `liftM` gets choices+ where+ helper :: PatchChoices p wA wB -> p wA wB+ helper = undefined++-- | The plural form of the noun for items of type @p@.+things :: (Patchy p, ShowPatch p) => InteractiveSelectionM p wX wY String+things = (Darcs.Patch.things . helper) `liftM` gets choices+ where+ helper :: PatchChoices p wA wB -> p wA wB+ helper = undefined++-- | The question to ask about one patch.+prompt :: (Patchy p, ShowPatch p) => InteractiveSelectionM p wX wY String+prompt = do+ jn <- asks jobname+ aThing <- thing+ n <- gets current+ n_max <- gets total+ return $ "Shall I "++jn++" this "++aThing++"? "+ ++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ") "++-- | Asks the user about one patch, returns their answer.+promptUser :: forall p wX wY . (Patchy p, ShowPatch p) => Bool -> Char+ -> InteractiveSelectionM p wX wY Char+promptUser single def = do+ thePrompt <- prompt+ (basicOptions,advancedOptions) <- options single+ liftIO $ promptChar PromptConfig { pPrompt = thePrompt+ , pBasicCharacters = keysFor basicOptions+ , pAdvancedCharacters = keysFor advancedOptions+ , pDefault = Just def+ , pHelp = "?h"+ }++-- | Ask the user what to do with the next patch.+textSelectOne :: forall p wX wY. (Patchy p, ShowPatch p, PatchInspect p, ApplyState p ~ Tree)+ => InteractiveSelectionM p wX wY Bool+textSelectOne = do+ c <- currentPatch+ case c of+ Nothing -> return False+ Just (Sealed2 lp) ->+ do+ jn <- asks jobname+ spl <- asks splitter+ whichch <- asks whichChanges+ let singleFile = isSingleFile (lpPatch lp)+ reprCur = repr whichch (Sealed2 (lpPatch lp))+ (basicOptions,advancedOptions) <- options singleFile+ theSlot <- liftChoices $ patchSlot' lp+ let+ the_default = getDefault (whichch == Last || whichch == FirstReversed) theSlot+ jnCapital = toUpper (head jn) : tail jn+ yorn <- promptUser singleFile the_default+ let nextPatch = skipMundane >> showCur+ case yorn of+ 'y' -> decide True lp >> skipOne >> nextPatch+ >> return False+ 'n' -> decide False lp >> skipOne >> nextPatch+ >> return False+ 'w' -> postponeNext >> skipOne >> nextPatch+ >> return False+ 'e' | (Just s) <- spl -> splitCurrent s >> showCur+ >> return False+ 's' -> currentFile >>= maybe+ (return ())+ (\f -> decideWholeFile f False) >> nextPatch+ >> return False+ 'f' -> currentFile >>= maybe+ (return ())+ (\f -> decideWholeFile f True) >> nextPatch+ >> return False+ 'v' -> liftIO $ unseal2 printPatch reprCur >> return False+ 'p' -> liftIO $ unseal2 printPatchPager reprCur >> return False+ 'l' -> printSelected >> showCur >> return False+ 'x' -> liftIO $ unseal2 printSummary reprCur >> return False+ 'd' -> skipAll >> return True+ 'g' -> backAll >> showCur >> return False+ 'a' ->+ do+ askConfirmation+ modChoices $ selectAllMiddles (whichch == Last || whichch == FirstReversed)+ skipAll+ return True+ 'q' -> liftIO $+ do putStrLn $ jnCapital++" cancelled."+ exitSuccess+ 'j' -> skipOne >> showCur >> return False+ 'k' -> backOne >> showCur >> return False+ _ -> do+ liftIO . putStrLn $ helpFor jn basicOptions advancedOptions+ return False++lastQuestion :: forall p wX wY . (Patchy p, ShowPatch p, ApplyState p ~ Tree) =>+ InteractiveSelectionM p wX wY Bool+lastQuestion = do+ jn <- asks jobname+ theThings <-things+ aThing <- thing+ let (basicOptions, advancedOptions) = optionsLast jn aThing+ yorn <- liftIO . promptChar $+ PromptConfig { pPrompt = "Do you want to "++jn++" these "++ theThings++"?"+ , pBasicCharacters = "yglqk"+ , pAdvancedCharacters = "dan"+ , pDefault = Just 'y'+ , pHelp = "?h"}+ case yorn of c | c `elem` "yda" -> return True+ | c `elem` "qn" -> liftIO $+ do putStrLn $ jn ++" cancelled."+ exitSuccess+ 'g' -> backAll >> showCur >> return False+ 'l' -> printSelected >> return False+ 'k' -> backOne >> showCur >> return False+ _ -> do+ liftIO . putStrLn $ helpFor "this confirmation prompt" basicOptions advancedOptions+ return False++-- | Shows the current patch as it should be seen by the user.+showCur :: forall p wX wY . (Patchy p, ShowPatch p, ApplyState p ~ Tree)+ => InteractiveSelectionM p wX wY ()+showCur = do+ o <- asks opts+ p <- asks pristine+ c <- currentPatch+ whichch <- asks whichChanges+ case c of+ Nothing -> return ()+ Just (Sealed2 lp) -> do+ let reprCur = repr whichch (Sealed2 (lpPatch lp))+ liftIO . unseal2 (printFriendly p (verbosity o) (summary o) (withContext o)) $ reprCur++-- | The interactive part of @darcs changes@+textView :: forall p . (Patchy p, ShowPatch p, ApplyState p ~ Tree)+ => PatchSelectionOptions -> Maybe Int -> Int+ -> [Sealed2 p] -> [Sealed2 p]+ -> IO ()+textView _ _ _ _ [] = return ()+textView o n_max n+ ps_done ps_todo@(p:ps_todo') = do+ unseal2 (printFriendly Nothing (verbosity o) (summary o) (withContext o)) p+ repeatThis -- prompt the user+ where+ prev_patch :: IO ()+ prev_patch = case ps_done of+ [] -> repeatThis+ (p':ps_done') ->+ textView o+ n_max (n-1) ps_done' (p':ps_todo)+ next_patch :: IO ()+ next_patch = case ps_todo' of+ [] -> -- May as well work out the length now we have all+ -- the patches in memory+ textView o n_max+ n ps_done []+ _ -> textView o n_max+ (n+1) (p:ps_done) ps_todo'+ first_patch = textView o n_max 0 [] (ps_done++ps_todo)+ options_yn =+ [ KeyPress 'y' "view this patch and go to the next"+ , KeyPress 'n' "skip to the next patch" ]+ optionsView' =+ [ KeyPress 'v' "view this patch in full"+ , KeyPress 'p' "view this patch in full with pager" ]+ optionsSummary' =+ [ KeyPress 'x' "view a summary of this patch" ]+ optionsNav' =+ [ KeyPress 'q' "quit view changes"+ , KeyPress 'k' "back up to previous patch"+ , KeyPress 'j' "skip to next patch"+ , KeyPress 'g' "start over from the first patch"+ , KeyPress 'c' "count total patch number" ]+ basicOptions = [ options_yn ]+ advancedOptions =+ (optionsView' +++ if summary o == YesSummary then [] else optionsSummary')+ : [ optionsNav' ]+ prompt' = "Shall I view this patch? "+ ++ "(" ++ show (n+1) ++ "/" ++ maybe "?" show n_max ++ ")"+ repeatThis :: IO ()+ repeatThis = do+ yorn <- promptChar (PromptConfig prompt' (keysFor basicOptions) (keysFor advancedOptions) (Just 'n') "?h")+ case yorn of+ 'y' -> unseal2 printPatch p >> next_patch+ 'n' -> next_patch+ 'v' -> unseal2 printPatch p >> repeatThis+ 'p' -> unseal2 printPatchPager p >> repeatThis+ 'x' -> do putDocLn $ prefix " " $ unseal2 Darcs.Patch.summary p+ repeatThis+ 'q' -> exitSuccess+ 'k' -> prev_patch+ 'j' -> next_patch+ 'g' -> first_patch+ 'c' -> textView o+ count_n_max n ps_done ps_todo+ _ -> do putStrLn $ helpFor "view changes" basicOptions advancedOptions+ repeatThis+ count_n_max | isJust n_max = n_max+ | otherwise = Just $ length ps_done + length ps_todo++-- | Skips patches we should not ask the user about+skipMundane :: (Patchy p, ShowPatch p)+ => InteractiveSelectionM p wX wY ()+skipMundane = do+ (FZipper lps_done lps_todo) <- gets lps+ o <- asks opts+ crit <- asks matchCriterion+ jn <- asks jobname+ whichch <- asks whichChanges+ (skipped :> unskipped) <- liftChoices $ spanFL_M+ (patchSlot' >=> return . decided)+ lps_todo+ let numSkipped = lengthFL skipped+ when (numSkipped > 0) . liftIO $ show_skipped o jn numSkipped skipped+ let boringThenInteresting =+ if selectDeps o == AutoDeps+ then spanFL (not. mcFunction crit whichch . seal2 . lpPatch)+ unskipped+ else NilFL :> unskipped+ case boringThenInteresting of+ boring :> interesting ->+ do+ justDone $ lengthFL boring + numSkipped+ modify $ \isc -> isc {lps = FZipper (reverseFL boring +<+ reverseFL skipped +<+ lps_done) interesting}+ where+ show_skipped o jn n ps = do putStrLn $ _nevermind_ jn ++ _these_ n ++ "."+ when (verbosity o == Verbose) $+ showskippedpatch ps+ _nevermind_ jn = "Will not ask whether to " ++ jn ++ " "+ _these_ n = show n ++ " already decided " ++ _elem_ n ""+ _elem_ n = englishNum n (Noun "patch")+ showskippedpatch :: (Patchy p, ShowPatch p) => FL (LabelledPatch p) wY wT -> IO ()+ showskippedpatch =+ sequence_ . mapFL (printSummary . lpPatch)++decided :: Slot -> Bool+decided InMiddle = False+decided _ = True++-- | The action bound to space, depending on the current status of the+-- patch.+getDefault :: Bool -> Slot -> Char+getDefault _ InMiddle = 'w'+getDefault True InFirst = 'n'+getDefault True InLast = 'y'+getDefault False InFirst = 'y'+getDefault False InLast = 'n'++askAboutDepends :: forall p wR wU wT wY . (RepoPatch p, ApplyState p ~ Tree)+ => Repository p wR wU wT -> FL (PrimOf p) wT wY+ -> PatchSelectionOptions+ -> [PatchInfo] -> IO [PatchInfo]+askAboutDepends repository pa' ps_opts olddeps = do+ -- ideally we'd just default the olddeps to yes but still ask about them.+ -- SelectChanges doesn't currently (17/12/09) offer a way to do this so would+ -- have to have this support added first.+ pps <- readTentativeRepo repository+ pa <- n2pia `fmap` anonymous (fromPrims pa')+ -- FIXME: this code is completely unreadable+ FlippedSeal ps <- return+ ((case pps of+ PatchSet x _ -> FlippedSeal (reverseRL x+>+(pa:>:NilFL)))+ :: FlippedSeal (FL (PatchInfoAnd p)) wY)+ let (pc, my_lps) = patchChoicesLps ps+ tas = case catMaybes (mapFL (\lp -> if pa `unsafeCompare` lpPatch lp || info (lpPatch lp) `elem` olddeps+ then Just (label lp) else Nothing) my_lps) of++ [] -> error "askAboutDepends: []"+ tgs -> tgs+ Sealed2 ps' <- return $ case getChoices (forceFirsts tas pc) of _ :> mc :> _ -> Sealed2 $ mapFL_FL lpPatch mc+ (deps:>_) <- runSelection (selectChanges ps') $+ selectionContext FirstReversed "depend on" ps_opts { matchFlags = [], interactive = True } Nothing Nothing+ return $ olddeps `union` mapFL info deps+{-+ where+ askdep_allowed = not . patchSelectFlag+ opts' = filter askdep_allowed cfg+ psOpts = (recordPatchSelOpts cfg)+-}++{-+-- | @'patchSelectFlag' f@ holds whenever @f@ is a way of selecting+-- patches such as @PatchName n@. <- ???+patchSelectFlag :: F.DarcsFlag -> Bool+patchSelectFlag F.All = True+patchSelectFlag (F.PatchName _) = True -- ???+patchSelectFlag (F.OnePatch _) = True+patchSelectFlag (F.OneHash _) = True+patchSelectFlag (F.SeveralPatch _) = True+patchSelectFlag (F.AfterPatch _) = True+patchSelectFlag (F.UpToPatch _) = True+patchSelectFlag (F.TagName _) = True+patchSelectFlag (F.LastN _) = True+patchSelectFlag (F.OneTag _) = True+patchSelectFlag (F.AfterTag _) = True+patchSelectFlag (F.UpToTag _) = True+patchSelectFlag (F.OnePattern _) = True+patchSelectFlag (F.SeveralPattern _) = True+patchSelectFlag (F.AfterPattern _) = True+patchSelectFlag (F.UpToPattern _) = True+patchSelectFlag _ = False+-}
+ src/Darcs/UI/TheCommands.hs view
@@ -0,0 +1,102 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}+module Darcs.UI.TheCommands ( commandControlList ) where++import Prelude ()+import Darcs.UI.Commands.Add ( add )+import Darcs.UI.Commands.Amend ( amend, amendrecord )+import Darcs.UI.Commands.Annotate ( annotate )+import Darcs.UI.Commands.Apply ( apply )+import Darcs.UI.Commands.Clone ( clone, get, put )+import Darcs.UI.Commands.Convert ( convert )+import Darcs.UI.Commands.Diff ( diffCommand )+import Darcs.UI.Commands.Dist ( dist )+import Darcs.UI.Commands.GZCRCs ( gzcrcs )+import Darcs.UI.Commands.Init ( initialize )+import Darcs.UI.Commands.Log ( log, changes )+import Darcs.UI.Commands.Show ( showCommand, list, query )+import Darcs.UI.Commands.MarkConflicts ( markconflicts )+import Darcs.UI.Commands.Move ( move, mv )+import Darcs.UI.Commands.Optimize ( optimize )+import Darcs.UI.Commands.Pull ( pull, fetch )+import Darcs.UI.Commands.Push ( push )+import Darcs.UI.Commands.Rebase ( rebase )+import Darcs.UI.Commands.Record ( record, commit )+import Darcs.UI.Commands.Remove ( remove, rm, unadd )+import Darcs.UI.Commands.Repair ( repair, check )+import Darcs.UI.Commands.Replace ( replace )+import Darcs.UI.Commands.Revert ( revert )+import Darcs.UI.Commands.Rollback ( rollback )+import Darcs.UI.Commands.Send ( send )+import Darcs.UI.Commands.SetPref ( setpref )+import Darcs.UI.Commands.Tag ( tag )+import Darcs.UI.Commands.Test ( test )+import Darcs.UI.Commands.TransferMode ( transferMode )+import Darcs.UI.Commands.Unrecord ( unrecord, unpull, obliterate )+import Darcs.UI.Commands.Unrevert ( unrevert )+import Darcs.UI.Commands.WhatsNew ( whatsnew, status )+import Darcs.UI.Commands ( CommandControl, normalCommand, hiddenCommand, commandGroup )++-- | The commands that darcs knows about (e.g. whatsnew, record),+-- organized into thematic groups. Note that hidden commands+-- are also listed here.+commandControlList :: [CommandControl]+commandControlList =+ [ commandGroup "Changing and querying the working copy:"+ , normalCommand add+ , normalCommand remove, hiddenCommand unadd, hiddenCommand rm+ , normalCommand move, hiddenCommand mv+ , normalCommand replace+ , normalCommand revert+ , normalCommand unrevert+ , normalCommand whatsnew, hiddenCommand status+ , commandGroup "Copying changes between the working copy and the repository:"+ , normalCommand record, hiddenCommand commit+ , normalCommand unrecord+ , normalCommand amend+ , hiddenCommand amendrecord+ , normalCommand markconflicts+ , commandGroup "Direct modification of the repository:"+ , normalCommand tag+ , normalCommand setpref+ , commandGroup "Querying the repository:"+ , normalCommand diffCommand+ , normalCommand log, hiddenCommand changes+ , normalCommand annotate+ , normalCommand dist+ , normalCommand test+ , normalCommand showCommand, hiddenCommand list, hiddenCommand query+ , hiddenCommand transferMode+ , commandGroup "Copying patches between repositories with working copy update:"+ , normalCommand pull+ , normalCommand fetch+ , normalCommand obliterate, hiddenCommand unpull+ , normalCommand rollback+ , normalCommand push+ , normalCommand send+ , normalCommand apply+ , normalCommand clone, hiddenCommand get, hiddenCommand put+ , commandGroup "Administrating repositories:"+ , normalCommand initialize+ , normalCommand optimize+ , normalCommand repair, hiddenCommand check+ , normalCommand convert+ , hiddenCommand gzcrcs+ , normalCommand rebase+ ]
+ src/Darcs/UI/Usage.hs view
@@ -0,0 +1,66 @@+-- | This module provides a variant of 'System.Console.GetOpt.usageInfo'.+--+-- Unlike the standard @usageInfo@ function, lists of long switches are broken+-- across multiple lines to economise on columns. For example,+--+-- @+-- -r --recursive add contents of subdirectories+-- --not-recursive,+-- --no-recursive don't add contents of subdirectories+-- @++module Darcs.UI.Usage ( usageInfo ) where+import Data.Functor.Compose+import System.Console.GetOpt( OptDescr(..), ArgDescr(..) )+import Darcs.UI.Options ( DarcsOptDescr )++-- | Variant of 'System.Console.GetOpt.usageInfo'.+-- Return a string describing the usage of a command, derived from the header+-- (first argument) and the options described by the second argument.+--+-- Sequences of long switches are presented on separate lines.+usageInfo :: String -- header+ -> [DarcsOptDescr a] -- option descriptors+ -> String -- nicely formatted decription of options+usageInfo header optDescr = unlines (header:table)+ where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr+ table = zipWith3 paste+ shortPadded+ (zipWith (++) (map (unlines' . init) ls)+ (sameLen $ map last ls))+ ds+ shortPadded = sameLen ss+ prePad = replicate (4 + length (head shortPadded)) ' '+ -- Similar to unlines (additional ',' and padding):+ unlines' = concatMap (\x -> x ++ ",\n" ++ prePad)+ -- Unchanged:+ paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z+ sameLen xs = flushLeft ((maximum . map length) xs) xs+ flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]++-- Mild variant of the standard definition: 'losFmt' is a list rather than a+-- comma separated string.+fmtOpt :: DarcsOptDescr a -> [(String,[String],String)]+fmtOpt (Compose (Option sos los ad descr)) =+ case lines descr of+ [] -> [(sosFmt,losFmt,"")]+ (d:ds) -> (sosFmt,losFmt,d) : [ ("",[],d') | d' <- ds ]+ where sepBy _ [] = ""+ sepBy _ [x] = x+ sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs+ sosFmt = sepBy ',' (map (fmtShort ad) sos)+ losFmt = map (fmtLong ad) los++--------------------------------------------------------------------------------+-- Verbatim copies: these definitions aren't exported by System.Console.GetOpt+--------------------------------------------------------------------------------++fmtShort :: ArgDescr a -> Char -> String+fmtShort (NoArg _ ) so = ['-', so]+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"++fmtLong :: ArgDescr a -> String -> String+fmtLong (NoArg _ ) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
− src/Darcs/URL.hs
@@ -1,126 +0,0 @@-{-# LANGUAGE CPP #-}--{--Copyright (C) 2004 David Roundy--This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2, or (at your option)-any later version.--This program is distributed in the hope that it will be useful,-but WITHOUT ANY WARRANTY; without even the implied warranty of-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the-GNU General Public License for more details.--You should have received a copy of the GNU General Public License-along with this program; see the file COPYING. If not, write to-the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,-Boston, MA 02110-1301, USA.--}--{-|-- Path resolving:-- * An http URL contains the sequence @\"http(s):\/\/\"@.-- * A local filepath does not contain colons, except- as second character (windows drives) when this- filepath is meant to be used as repository name-- * A path that is neither an http URL nor a local file- is an ssh-path.-- Examples:-- > /usr/repo/foo -- local file- > c:/src/darcs -- local file- > http://darcs.net/ -- URL- > peter@host:/path -- ssh- > droundy@host: -- ssh- > host:/path -- ssh-- This means that single-letter hosts in ssh-paths do not work,- unless a username is provided.-- Perhaps ssh-paths should use @\"ssh:\/\/user\@host\/path\"@-syntax instead?--}--module Darcs.URL (- isFile, isHttpUrl, isSshUrl, isRelative, isAbsolute,- isSshNopath, SshFilePath, sshRepo, sshUhost, sshFile, urlOf, splitSshUrl- ) where--import Darcs.Global(darcsdir)-import Data.List ( isPrefixOf, isInfixOf )-import Data.Char ( isSpace )-import qualified System.FilePath as FP (isRelative, isAbsolute, isValid)--#include "impossible.h"--isRelative :: String -> Bool-isRelative "" = bug "Empty filename in isRelative"-isRelative f = FP.isRelative f--isAbsolute :: String -> Bool-isAbsolute "" = bug "isAbsolute called with empty filename"-isAbsolute f = FP.isAbsolute f--isFile :: String -> Bool-isFile f@(_:_:fou) = ':' `notElem` fou && FP.isValid f-isFile f = FP.isValid f--isHttpUrl :: String -> Bool-isHttpUrl u =- let u' = dropWhile isSpace u in- ("http://" `isPrefixOf` u') || ("https://" `isPrefixOf` u')---isSshUrl :: String -> Bool-isSshUrl s = isu' (dropWhile isSpace s)- where- isu' s'- | "ssh://" `isPrefixOf` s' = True- | "://" `isInfixOf` s' = False- | isFile s' = False- | otherwise = ":" `isInfixOf` s'--isSshNopath :: String -> Bool-isSshNopath s = case reverse s of- ':':x@(_:_:_) -> ':' `notElem` x- _ -> False---- | Gives the (user, host, dir) out of an ssh url-splitSshUrl :: String -> SshFilePath-splitSshUrl s | "ssh://" `isPrefixOf` s =- let s' = drop (length "ssh://") $ dropWhile isSpace s- (dir, file) = cleanrepodir '/' s'- in- SshFP { sshUhost = takeWhile (/= '/') s'- , sshRepo = dir- , sshFile = file }-splitSshUrl s =- let (dir, file) = cleanrepodir ':' s in- SshFP { sshUhost = dropWhile isSpace $ takeWhile (/= ':') s- , sshRepo = dir- , sshFile = file }---cleanrepourl :: String -> (String, String)-cleanrepourl zzz | dd `isPrefixOf` zzz = ([], drop (length dd) zzz)- where dd = darcsdir++"/"-cleanrepourl (z:zs) =- let (repo',file) = cleanrepourl zs in- (z : repo', file)-cleanrepourl "" = ([],[])--cleanrepodir :: Char -> String -> (String, String)-cleanrepodir sep = cleanrepourl . drop 1 . dropWhile (/= sep)--data SshFilePath = SshFP { sshUhost :: String- , sshRepo :: String- , sshFile :: String}--urlOf :: SshFilePath -> String-urlOf (SshFP uhost dir file) = uhost ++ ":" ++ dir ++ "/" ++ darcsdir ++ "/" ++ file
+ src/Darcs/Util/AtExit.hs view
@@ -0,0 +1,80 @@+-- Copyright (C) 2005 Tomasz Zielonka+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++-- |+-- Module : Darcs.Util.AtExit+-- Copyright : 2005 Tomasz Zielonka+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable+--+-- This was originally Tomasz Zielonka's AtExit module, slightly generalised+-- to include global variables. Here, we attempt to cover broad, global+-- features, such as exit handlers. These features slightly break the Haskellian+-- purity of darcs, in favour of programming convenience.++module Darcs.Util.AtExit+ (+ atexit+ , withAtexit+ ) where+++import Control.Concurrent.MVar+import Control.Exception+ ( bracket_, catch, SomeException+ , mask+ )+import System.IO.Unsafe (unsafePerformIO)+import System.IO ( hPutStrLn, stderr, hPrint )+import Prelude hiding (catch)+++atexitActions :: MVar (Maybe [IO ()])+atexitActions = unsafePerformIO (newMVar (Just []))+{-# NOINLINE atexitActions #-}+++-- | Registers an IO action to run just before darcs exits. Useful for removing+-- temporary files and directories, for example. Referenced in Issue1914.+atexit :: IO ()+ -> IO ()+atexit action =+ modifyMVar_ atexitActions $ \ml ->+ case ml of+ Just l ->+ return (Just (action : l))+ Nothing -> do+ hPutStrLn stderr "It's too late to use atexit"+ return Nothing+++withAtexit :: IO a -> IO a+withAtexit = bracket_ (return ()) exit+ where+ exit = mask $ \unmask -> do+ Just actions <- swapMVar atexitActions Nothing+ -- from now on atexit will not register new actions+ mapM_ (runAction unmask) actions+ runAction unmask action =+ catch (unmask action) $ \(exn :: SomeException) -> do+ hPutStrLn stderr "Exception thrown by an atexit registered action:"+ hPrint stderr exn+
+ src/Darcs/Util/Bug.hs view
@@ -0,0 +1,27 @@+-- Reporting bugs in darcs. See also impossible.h.+module Darcs.Util.Bug+ ( _bug, _bugDoc, _impossible, _fromJust+ ) where++import Data.Maybe(fromMaybe)+import Darcs.Util.Printer ( Doc, errorDoc, text, ($$) )++type BugStuff = (String, Int, String, String)++_bug :: BugStuff -> String -> a+_bug bs s = _bugDoc bs (text s)++_bugDoc :: BugStuff -> Doc -> a+_bugDoc bs s = errorDoc $+ text ("bug at " ++ _bugLoc bs) $$ s $$+ text ("See http://wiki.darcs.net/BugTracker/Reporting " +++ "for help on bug reporting.")++_bugLoc :: BugStuff -> String+_bugLoc (file, line, date, time) = file++":"++show line++" compiled "++time++" "++date++_impossible :: BugStuff -> a+_impossible bs = _bug bs $ "Impossible case at "++_bugLoc bs++_fromJust :: BugStuff -> Maybe a -> a+_fromJust bs = fromMaybe (_bug bs $ "fromJust error at " ++ _bugLoc bs)
+ src/Darcs/Util/ByteString.hs view
@@ -0,0 +1,508 @@+{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2+{-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP, ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Darcs.Util.ByteString+-- Copyright : (c) The University of Glasgow 2001,+-- David Roundy 2003-2005+-- License : GPL (I'm happy to also license this file BSD style but don't+-- want to bother distributing two license files with darcs.+--+-- Maintainer : droundy@abridgegame.org+-- Stability : experimental+-- Portability : portable+--+-- GZIp and MMap IO for ByteStrings, encoding utilities, and miscellaneous+-- functions for Data.ByteString+--++module Darcs.Util.ByteString (++ unsafeWithInternals,+ unpackPSFromUTF8,+ packStringToUTF8,++ -- IO with mmap or gzip+ gzReadFilePS,+ mmapFilePS,+ gzWriteFilePS,+ gzWriteFilePSs,+ gzReadStdin,+ gzWriteHandle,++ -- gzip handling+ isGZFile,+ gzDecompress,++ -- list utilities+ dropSpace,+ breakSpace,+ linesPS,+ unlinesPS,+ hashPS,+ breakFirstPS,+ breakLastPS,+ substrPS,+ readIntPS,+ isFunky,+ fromHex2PS,+ fromPS2Hex,+ betweenLinesPS,+ breakAfterNthNewline,+ breakBeforeNthNewline,+ intercalate,++ -- encoding and unicode utilities+ isAscii,+ decodeLocale,+ encodeLocale,+ decodeString+ ) where++import Prelude hiding ( catch )+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Internal as BI+import Data.ByteString (intercalate)+import Data.ByteString.Internal (fromForeignPtr)++import Control.Exception ( catch, SomeException )+import System.IO+import System.IO.Unsafe ( unsafePerformIO )++import Foreign.Storable ( peekElemOff, peek )+import Foreign.Marshal.Array ( advancePtr )+import Foreign.C.Types ( CInt(..) )++import Data.Bits ( rotateL )+import Data.Char ( ord, isSpace )+import Data.Word ( Word8 )+import Data.Int ( Int32 )+import qualified Data.Text as T ( pack, unpack )+import Data.Text.Encoding ( encodeUtf8, decodeUtf8With )+import Data.Text.Encoding.Error ( lenientDecode )+import Control.Monad ( when )++import Foreign.Ptr ( plusPtr, Ptr )+import Foreign.ForeignPtr ( withForeignPtr )++#ifdef DEBUG_PS+import Foreign.ForeignPtr ( addForeignPtrFinalizer )+import Foreign.Ptr ( FunPtr )+#endif++import qualified Data.ByteString.Lazy as BL+import qualified Codec.Compression.GZip as GZ+import qualified Codec.Compression.Zlib.Internal as ZI+import Darcs.Util.Encoding ( decode, encode )+import Darcs.Util.Global ( addCRCWarning )++import System.IO.MMap( mmapFileByteString )+import System.Mem( performGC )+import System.Posix.Files( fileSize, getSymbolicLinkStatus )++-- -----------------------------------------------------------------------------+-- obsolete debugging code++-- -----------------------------------------------------------------------------+-- unsafeWithInternals++-- | Do something with the internals of a PackedString. Beware of+-- altering the contents!+unsafeWithInternals :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a+unsafeWithInternals ps f+ = case BI.toForeignPtr ps of+ (fp,s,l) -> withForeignPtr fp $ \p -> f (p `plusPtr` s) l++-- | readIntPS skips any whitespace at the beginning of its argument, and+-- reads an Int from the beginning of the PackedString. If there is no+-- integer at the beginning of the string, it returns Nothing, otherwise it+-- just returns the int read, along with a B.ByteString containing the+-- remainder of its input.++readIntPS :: B.ByteString -> Maybe (Int, B.ByteString)+readIntPS = BC.readInt . BC.dropWhile isSpace++-- -----------------------------------------------------------------------------+-- Destructor functions (taking PackedStrings apart)++-- | Decodes a 'ByteString' containing UTF-8 to a 'String'. Decoding errors are+-- flagged with the U+FFFD character.+unpackPSFromUTF8 :: B.ByteString -> String+unpackPSFromUTF8 = T.unpack . decodeUtf8With lenientDecode++packStringToUTF8 :: String -> B.ByteString+packStringToUTF8 = encodeUtf8 . T.pack++------------------------------------------------------------------------+-- A reimplementation of Data.ByteString.Char8.dropSpace, but+-- specialised to darcs' need for a 4 way isspace.+--+-- TODO: if it is safe to use the expanded definition of isSpaceWord8+-- provided by Data.ByteString.Char8, then all this can go.++-- A locale-independent isspace(3) so patches are interpreted the same everywhere.+-- ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r')+isSpaceWord8 :: Word8 -> Bool+isSpaceWord8 = (`elem` [0x20, 0x09, 0x0A, 0x0D])+{-# INLINE isSpaceWord8 #-}++dropSpace :: B.ByteString -> B.ByteString+dropSpace bs = B.dropWhile isSpaceWord8 bs++breakSpace :: B.ByteString -> (B.ByteString, B.ByteString)+breakSpace bs = B.break isSpaceWord8 bs++------------------------------------------------------------------------++{-# INLINE isFunky #-}+isFunky :: B.ByteString -> Bool+isFunky ps = case BI.toForeignPtr ps of+ (x,s,l) ->+ unsafePerformIO $ withForeignPtr x $ \p->+ (/=0) `fmap` has_funky_char (p `plusPtr` s) (fromIntegral l)++foreign import ccall unsafe "fpstring.h has_funky_char" has_funky_char+ :: Ptr Word8 -> CInt -> IO CInt++------------------------------------------------------------------------++-- ByteString rewrites break (=='x') to breakByte 'x'+-- break ((==) x) = breakChar x+-- break (==x) = breakChar x+--++{-+{-# INLINE breakOnPS #-}+breakOnPS :: Char -> B.ByteString -> (B.ByteString, B.ByteString)+breakOnPS c p = case BC.elemIndex c p of+ Nothing -> (p, BC.empty)+ Just n -> (B.take n p, B.drop n p)+-}++{-# INLINE hashPS #-}+hashPS :: B.ByteString -> Int32+hashPS ps =+ case BI.toForeignPtr ps of+ (x,s,l) ->+ unsafePerformIO $ withForeignPtr x $ \p->+ hash (p `plusPtr` s) l++hash :: Ptr Word8 -> Int -> IO Int32+hash = f (0 :: Int32)+ where f h _ 0 = return h+ f h p n = do x <- peek p+ let !h' = fromIntegral x + rotateL h 8+ f h' (p `advancePtr` 1) (n-1)++{-# INLINE substrPS #-}+substrPS :: B.ByteString -> B.ByteString -> Maybe Int+substrPS tok str+ | B.null tok = Just 0+ | B.length tok > B.length str = Nothing+ | otherwise = do n <- BC.elemIndex (BC.head tok) str+ let ttok = B.tail tok+ reststr = B.drop (n+1) str+ if ttok == B.take (B.length ttok) reststr+ then Just n+ else ((n+1)+) `fmap` substrPS tok reststr++------------------------------------------------------------------------++-- TODO: replace breakFirstPS and breakLastPS with definitions based on+-- ByteString's break/breakEnd+{-# INLINE breakFirstPS #-}+breakFirstPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString)+breakFirstPS c p = case BC.elemIndex c p of+ Nothing -> Nothing+ Just n -> Just (B.take n p, B.drop (n+1) p)++{-# INLINE breakLastPS #-}+breakLastPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString)+breakLastPS c p = case BC.elemIndexEnd c p of+ Nothing -> Nothing+ Just n -> Just (B.take n p, B.drop (n+1) p)++-- TODO: rename+{-# INLINE linesPS #-}+linesPS :: B.ByteString -> [B.ByteString]+linesPS ps+ | B.null ps = [B.empty]+ | otherwise = BC.split '\n' ps++{- QuickCheck property:++import Test.QuickCheck+import qualified Data.ByteString.Char8 as BC+import Data.Char+instance Arbitrary BC.ByteString where+ arbitrary = fmap BC.pack arbitrary+instance Arbitrary Char where+ arbitrary = chr `fmap` choose (32,127)+deepCheck = check (defaultConfig { configMaxTest = 10000})+testLines = deepCheck (\x -> (linesPS x == linesPSOld x))+linesPSOld ps = case BC.elemIndex '\n' ps of+ Nothing -> [ps]+ Just n -> B.take n ps : linesPS (B.drop (n+1) ps) -}++{-| This function acts exactly like the "Prelude" unlines function, or like+"Data.ByteString.Char8" 'unlines', but with one important difference: it will+produce a string which may not end with a newline! That is:++> unlinesPS ["foo", "bar"]++evaluates to \"foo\\nbar\", not \"foo\\nbar\\n\"! This point should hold true for+'linesPS' as well.++TODO: rename this function. -}+unlinesPS :: [B.ByteString] -> B.ByteString+unlinesPS [] = BC.empty+unlinesPS x = BC.init $ BC.unlines x+{-# INLINE unlinesPS #-}+{- QuickCheck property:++testUnlines = deepCheck (\x -> (unlinesPS x == unlinesPSOld x))+unlinesPSOld ss = BC.concat $ intersperse_newlines ss+ where intersperse_newlines (a:b:s) = a : newline : intersperse_newlines (b:s)+ intersperse_newlines s = s+ newline = BC.pack "\n" -}++-- -----------------------------------------------------------------------------+-- gzReadFilePS++-- |Decompress the given bytestring into a lazy list of chunks, along with a boolean+-- flag indicating (if True) that the CRC was corrupted.+-- Inspecting the flag will cause the entire list of chunks to be evaluated (but if+-- you throw away the list immediately this should run in constant space).+gzDecompress :: Maybe Int -> BL.ByteString -> ([B.ByteString], Bool)+gzDecompress mbufsize =+ -- This is what the code would be without the bad CRC recovery logic:+ -- return . BL.toChunks . GZ.decompressWith decompressParams+ toListWarn . ZI.decompressWithErrors ZI.gzipFormat decompressParams+ where+ decompressParams = case mbufsize of+ Just bufsize -> GZ.defaultDecompressParams { GZ.decompressBufferSize = bufsize }+ Nothing -> GZ.defaultDecompressParams++ toListWarn :: ZI.DecompressStream -> ([B.ByteString], Bool)+ toListWarn = foldDecompressStream (\x ~(xs, b) -> (x:xs, b)) ([], False) handleBad++ -- cut and paste from Zlib since it's not currently exported (interface not yet certain)+ foldDecompressStream :: (B.ByteString -> a -> a) -> a+ -> (ZI.DecompressError -> String -> a)+ -> ZI.DecompressStream -> a+ foldDecompressStream chunk end err = fold+ where+ fold ZI.StreamEnd = end+ fold (ZI.StreamChunk bs stream) = chunk bs (fold stream)+ fold (ZI.StreamError code msg) = err code msg++ -- For a while a bug in darcs caused gzip files with good data but bad CRCs to be+ -- produced. Trap bad CRC messages, run the specified action to report that it happened,+ -- but continue on the assumption that the data is valid.+ handleBad ZI.DataError "incorrect data check" = ([], True)+ handleBad _ msg = error msg++isGZFile :: FilePath -> IO (Maybe Int)+isGZFile f = do+ h <- openBinaryFile f ReadMode+ header <- B.hGet h 2+ if header /= BC.pack "\31\139"+ then do hClose h+ return Nothing+ else do hSeek h SeekFromEnd (-4)+ len <- hGetLittleEndInt h+ hClose h+ return (Just len)++-- | Read an entire file, which may or may not be gzip compressed, directly+-- into a 'B.ByteString'.+gzReadFilePS :: FilePath -> IO B.ByteString+gzReadFilePS f = do+ mlen <- isGZFile f+ case mlen of+ Nothing -> mmapFilePS f+ Just len ->+ do -- Passing the length to gzDecompress means that it produces produces one chunk,+ -- which in turn means that B.concat won't need to copy data.+ -- If the length is wrong this will just affect efficiency, not correctness+ let doDecompress buf = let (res, bad) = gzDecompress (Just len) buf+ in do when bad $ addCRCWarning f+ return res+ compressed <- (BL.fromChunks . return) `fmap` mmapFilePS f+ B.concat `fmap` doDecompress compressed++hGetLittleEndInt :: Handle -> IO Int+hGetLittleEndInt h = do+ b1 <- ord `fmap` hGetChar h+ b2 <- ord `fmap` hGetChar h+ b3 <- ord `fmap` hGetChar h+ b4 <- ord `fmap` hGetChar h+ return $ b1 + 256*b2 + 65536*b3 + 16777216*b4++gzWriteFilePS :: FilePath -> B.ByteString -> IO ()+gzWriteFilePS f ps = gzWriteFilePSs f [ps]++gzWriteFilePSs :: FilePath -> [B.ByteString] -> IO ()+gzWriteFilePSs f pss =+ BL.writeFile f $ GZ.compress $ BL.fromChunks pss++gzWriteHandle :: Handle -> [B.ByteString] -> IO ()+gzWriteHandle h pss =+ BL.hPut h $ GZ.compress $ BL.fromChunks pss++-- | Read standard input, which may or may not be gzip compressed, directly+-- into a 'B.ByteString'.+gzReadStdin :: IO B.ByteString+gzReadStdin = do+ header <- B.hGet stdin 2+ rest <- B.hGetContents stdin+ let allStdin = B.concat [header,rest]+ return $+ if header /= BC.pack "\31\139"+ then allStdin+ else let decompress = fst . gzDecompress Nothing+ compressed = BL.fromChunks [allStdin]+ in+ B.concat $ decompress compressed++-- -----------------------------------------------------------------------------+-- mmapFilePS++-- | Like readFilePS, this reads an entire file directly into a+-- 'B.ByteString', but it is even more efficient. It involves directly+-- mapping the file to memory. This has the advantage that the contents of+-- the file never need to be copied. Also, under memory pressure the page+-- may simply be discarded, wile in the case of readFilePS it would need to+-- be written to swap. If you read many small files, mmapFilePS will be+-- less memory-efficient than readFilePS, since each mmapFilePS takes up a+-- separate page of memory. Also, you can run into bus errors if the file+-- is modified. NOTE: as with 'readFilePS', the string representation in+-- the file is assumed to be ISO-8859-1.++mmapFilePS :: FilePath -> IO B.ByteString+mmapFilePS f =+ mmapFileByteString f Nothing+ `catch` (\(_ :: SomeException) -> do+ size <- fileSize `fmap` getSymbolicLinkStatus f+ if size == 0+ then return B.empty+ else performGC >> mmapFileByteString f Nothing)++-- -------------------------------------------------------------------------+-- fromPS2Hex++foreign import ccall unsafe "static fpstring.h conv_to_hex" conv_to_hex+ :: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()++fromPS2Hex :: B.ByteString -> B.ByteString+fromPS2Hex ps = case BI.toForeignPtr ps of+ (x,s,l) ->+ BI.unsafeCreate (2*l) $ \p -> withForeignPtr x $ \f ->+ conv_to_hex p (f `plusPtr` s) $ fromIntegral l++-- -------------------------------------------------------------------------+-- fromHex2PS++foreign import ccall unsafe "static fpstring.h conv_from_hex" conv_from_hex+ :: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()++fromHex2PS :: B.ByteString -> B.ByteString+fromHex2PS ps = case BI.toForeignPtr ps of+ (x,s,l) ->+ BI.unsafeCreate (l `div` 2) $ \p -> withForeignPtr x $ \f ->+ conv_from_hex p (f `plusPtr` s) (fromIntegral $ l `div` 2)++-- -------------------------------------------------------------------------+-- betweenLinesPS++-- | betweenLinesPS returns the B.ByteString between the two lines given,+-- or Nothing if they do not appear.++betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString+ -> Maybe B.ByteString+betweenLinesPS start end ps+ = case break (start ==) (linesPS ps) of+ (_, _:rest@(bs1:_)) ->+ case BI.toForeignPtr bs1 of+ (ps1,s1,_) ->+ case break (end ==) rest of+ (_, bs2:_) -> case BI.toForeignPtr bs2 of (_,s2,_) -> Just $ fromForeignPtr ps1 s1 (s2 - s1)+ _ -> Nothing+ _ -> Nothing++-- -------------------------------------------------------------------------+-- breakAfterNthNewline++breakAfterNthNewline :: Int -> B.ByteString+ -> Maybe (B.ByteString, B.ByteString)+breakAfterNthNewline 0 the_ps | B.null the_ps = Just (B.empty, B.empty)+breakAfterNthNewline n the_ps =+ case BI.toForeignPtr the_ps of+ (fp,the_s,l) ->+ unsafePerformIO $ withForeignPtr fp $ \p ->+ do let findit 0 s | s == end = return $ Just (the_ps, B.empty)+ findit _ s | s == end = return Nothing+ findit 0 s = let left_l = s - the_s+ in return $ Just (fromForeignPtr fp the_s left_l,+ fromForeignPtr fp s (l - left_l))+ findit i s = do w <- peekElemOff p s+ if w == nl then findit (i-1) (s+1)+ else findit i (s+1)+ nl = BI.c2w '\n'+ end = the_s + l+ findit n the_s++-- -------------------------------------------------------------------------+-- breakBeforeNthNewline++breakBeforeNthNewline :: Int -> B.ByteString -> (B.ByteString, B.ByteString)+breakBeforeNthNewline 0 the_ps+ | B.null the_ps = (B.empty, B.empty)+breakBeforeNthNewline n the_ps =+ case BI.toForeignPtr the_ps of+ (fp,the_s,l) ->+ unsafePerformIO $ withForeignPtr fp $ \p ->+ do let findit _ s | s == end = return (the_ps, B.empty)+ findit i s = do w <- peekElemOff p s+ if w == nl+ then if i == 0+ then let left_l = s - the_s+ in return (fromForeignPtr fp the_s left_l,+ fromForeignPtr fp s (l - left_l))+ else findit (i-1) (s+1)+ else findit i (s+1)+ nl = BI.c2w '\n'+ end = the_s + l+ findit n the_s++-- | Test if a ByteString is made of ascii characters+isAscii :: B.ByteString -> Bool+isAscii = B.all (< 128)++-- | Decode a ByteString to a String according to the current locale+-- unsafePerformIO in the locale function is ratified by the fact that GHC 6.12+-- 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 = unsafePerformIO . decode++-- | Encode a String to a ByteString with char8 encoding (i.e., the values of the+-- characters become the values of the bytes; if a character value is greater+-- than 255, its byte becomes the character value modulo 256)+encodeChar8 :: String -> B.ByteString+encodeChar8 = B.pack . map (fromIntegral . ord)++-- | Encode a String to a ByteString according to the current locale+encodeLocale :: String -> B.ByteString+encodeLocale = unsafePerformIO . encode++-- | Take a 'String' that represents byte values and re-decode it acording to+-- the current locale.+-- Note: we globally enforce char8 as the default encoding, see "Main" and+-- "Darcs.Utils". This means we get command line args and environment variables+-- as 'String's with char8 encoding, too. So we need this to convert such+-- strings back to the user's encoding.+decodeString :: String -> IO String+decodeString = decode . encodeChar8
+ src/Darcs/Util/CommandLine.hs view
@@ -0,0 +1,140 @@+-- Copyright (C) 2005 Benedikt Schmidt+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Module : Darcs.Util.CommandLine+-- Copyright : 2005 Benedikt Schmidt+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable+--+-- |A parser for commandlines, returns an arg list and expands+-- format strings given in a translation table. Additionally+-- the commandline can end with "%<" specifying that the command+-- expects input on stdin.+--+-- Some tests for the parser.+--+-- > formatTable = [('s',"<insert subject here>"),+-- > ('a',"<insert author here>")]+-- >+-- > testParser :: (Show a, Eq a) => Parser a -> String -> a -> a+-- > testParser p s ok = case parse p "" s of+-- > Left e -> error $ "Parser failed with: " ++ (show e)+-- > Right res -> if res == ok+-- > then res+-- > else error $ "Parser failed: got "+-- > ++ (show res) ++ ", expected "+-- > ++ (show ok)+-- >+-- > testCases = [("a b",(["a","b"], False)),+-- > ("a b %<",(["a","b"], True)),+-- > ("a b %< ",(["a","b"], True)),+-- > ("\"arg0 contains spaces \\\"quotes\\\"\" b",+-- > (["arg0 contains spaces \"quotes\"","b"],False)),+-- > ("a %s %<",(["a","<insert subject here>"], True))]+-- >+-- > runTests = map (uncurry $ testParser (commandline formatTable)) testCases++module Darcs.Util.CommandLine+ ( parseCmd+ , addUrlencoded+ ) where++import Control.Arrow ( (***) )+import Data.Char ( ord, intToDigit, toUpper )+import Data.List ( find )+import Text.ParserCombinators.Parsec++-- | assoc list mapping characters to strings+-- eg (c,s) means that %c is replaced by s+type FTable = [(Char,String)]++commandline :: FTable -> Parser ([String], Bool)+commandline ftable = consumeAll $ do+ l <- sepEndBy1 (arg ftable) (try separator)+ redir <- formatRedir+ spaces+ return (l,redir)++arg :: FTable -> Parser String+arg ftable = quotedArg ftable <|> unquotedArg ftable++unquotedArg :: FTable -> Parser String+unquotedArg ftable = try (format ftable) <|> many1 (noneOf " \t\"%")++quotedArg :: FTable -> Parser String+quotedArg ftable = between quoteChar quoteChar $ quoteContent ftable+ where+ quoteChar = char '"'++quoteContent :: FTable -> Parser String+quoteContent ftable = do s1 <- escape+ <|> try (format ftable)+ <|> many1 (noneOf "\"\\%")+ s2 <- quoteContent ftable+ return $ s1 ++ s2+ <|> return ""++formatRedir :: Parser Bool+formatRedir = (string "%<" >> return True)+ <|> return False++format :: FTable -> Parser String+format ftable = do _ <- char '%'+ c <- oneOf (map fst ftable)+ return $ expandFormat ftable c++escape :: Parser String+escape = do _ <- char '\\'+ c <- anyChar+ return [c]++consumeAll :: Parser a -> Parser a+consumeAll p = do r <- p+ eof+ return r++separator :: Parser ()+separator = skipMany1 space++expandFormat :: FTable -> Char -> String+expandFormat ftable c = case find ((==c) . fst) ftable of+ Just (_,s) -> s+ Nothing -> error "impossible"++-- | parse a commandline returning a list of strings+-- (intended to be used as argv) and a bool value which+-- specifies if the command expects input on stdin+-- format specifiers with a mapping in ftable are accepted+-- and replaced by the given strings. E.g. if the ftable is+-- [('s',"Some subject")], then "%s" is replaced by "Some subject"+parseCmd :: FTable -> String -> Either ParseError ([String],Bool)+parseCmd ftable = parse (commandline ftable) ""++urlEncode :: String -> String+urlEncode = concatMap escapeC+ where escapeC x = if allowed x then [x] else '%' : intToHex (ord x)+ intToHex i = map intToDigit [i `div` 16, i `mod` 16]+ allowed x = x `elem` allowedChars+ allowedChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "!'()*-.~"++-- | for every mapping (c,s), add a mapping with uppercase c+-- and the urlencoded string s+addUrlencoded :: FTable -> FTable+addUrlencoded ftable = ftable ++ map (toUpper *** urlEncode) ftable
+ src/Darcs/Util/Crypt/SHA1.hs view
@@ -0,0 +1,215 @@+-- Copyright (C) 2001, 2004 Ian Lynagh <igloo@earth.li>+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- name shadowing disabled because a,b,c,d,e are shadowed loads in step 4+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++{-# LANGUAGE CPP #-}++-- |+-- Module : Darcs.Util.Crypt.SHA1+-- Copyright : 2001, 2004 Ian Lynagh <igloo@earth.li>+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++module Darcs.Util.Crypt.SHA1 ( sha1PS, SHA1(..), showAsHex ) where++import Darcs.Util.ByteString (unsafeWithInternals)+import qualified Data.ByteString as B (ByteString, pack, length, concat)+import Data.Binary ( Binary(..) )+import Data.Char (intToDigit)+import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR)+import Data.Word (Word8, Word32)+import Foreign.Ptr (Ptr, castPtr)+import Foreign.Marshal.Array (advancePtr)+import Foreign.Storable (peek, poke)+import System.IO.Unsafe (unsafePerformIO)++data SHA1 = SHA1 !Word32 !Word32 !Word32 !Word32 !Word32+ deriving (Eq,Ord)+data XYZ = XYZ !Word32 !Word32 !Word32++instance Show SHA1 where+ show (SHA1 a b c d e) = concatMap showAsHex [a, b, c, d, e]++instance Binary SHA1 where+ put (SHA1 a b c d e) = put a >> put b >> put c >> put d >> put e+ get = do a <- get ; b <- get ; c <- get ; d <- get ; e <- get ; return (SHA1 a b c d e)++sha1PS:: B.ByteString -> SHA1+sha1PS s = abcde'+ where s1_2 = sha1Step12PadLength s+ abcde = sha1Step3Init+ abcde' = unsafePerformIO+ $ unsafeWithInternals s1_2 (\ptr len ->+ do let ptr' = castPtr ptr+#ifndef BIGENDIAN+ fiddleEndianness ptr' len+#endif+ sha1Step4Main abcde ptr' len)++fiddleEndianness :: Ptr Word32 -> Int -> IO ()+fiddleEndianness p 0 = p `seq` return ()+fiddleEndianness p n+ = do x <- peek p+ poke p $ shiftL x 24+ .|. shiftL (x .&. 0xff00) 8+ .|. (shiftR x 8 .&. 0xff00)+ .|. shiftR x 24+ fiddleEndianness (p `advancePtr` 1) (n - 4)++-- sha1Step12PadLength assumes the length is at most 2^61.+-- This seems reasonable as the Int used to represent it is normally 32bit,+-- but obviously could go wrong with large inputs on 64bit machines.+-- The B.ByteString library should probably move to Word64s if this is an+-- issue, though.++sha1Step12PadLength :: B.ByteString -> B.ByteString+sha1Step12PadLength s+ = let len = B.length s+ num_nuls = (55 - len) `mod` 64+ padding = 128:replicate num_nuls 0+ len_w8s = reverse $ sizeSplit 8 (fromIntegral len*8)+ in B.concat [s, B.pack padding, B.pack len_w8s]++sizeSplit :: Int -> Integer -> [Word8]+sizeSplit 0 _ = []+sizeSplit p n = fromIntegral d:sizeSplit (p-1) n'+ where (n', d) = divMod n 256++sha1Step3Init :: SHA1+sha1Step3Init = SHA1 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0++sha1Step4Main :: SHA1 -> Ptr Word32 -> Int -> IO SHA1+sha1Step4Main abcde _ 0 = return $! abcde+sha1Step4Main (SHA1 a0@a b0@b c0@c d0@d e0@e) s len+ = do+ (e, b) <- doit f1 0x5a827999 (x 0) a b c d e+ (d, a) <- doit f1 0x5a827999 (x 1) e a b c d+ (c, e) <- doit f1 0x5a827999 (x 2) d e a b c+ (b, d) <- doit f1 0x5a827999 (x 3) c d e a b+ (a, c) <- doit f1 0x5a827999 (x 4) b c d e a+ (e, b) <- doit f1 0x5a827999 (x 5) a b c d e+ (d, a) <- doit f1 0x5a827999 (x 6) e a b c d+ (c, e) <- doit f1 0x5a827999 (x 7) d e a b c+ (b, d) <- doit f1 0x5a827999 (x 8) c d e a b+ (a, c) <- doit f1 0x5a827999 (x 9) b c d e a+ (e, b) <- doit f1 0x5a827999 (x 10) a b c d e+ (d, a) <- doit f1 0x5a827999 (x 11) e a b c d+ (c, e) <- doit f1 0x5a827999 (x 12) d e a b c+ (b, d) <- doit f1 0x5a827999 (x 13) c d e a b+ (a, c) <- doit f1 0x5a827999 (x 14) b c d e a+ (e, b) <- doit f1 0x5a827999 (x 15) a b c d e+ (d, a) <- doit f1 0x5a827999 (m 16) e a b c d+ (c, e) <- doit f1 0x5a827999 (m 17) d e a b c+ (b, d) <- doit f1 0x5a827999 (m 18) c d e a b+ (a, c) <- doit f1 0x5a827999 (m 19) b c d e a+ (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e+ (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d+ (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c+ (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b+ (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a+ (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e+ (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d+ (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c+ (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b+ (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a+ (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e+ (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d+ (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c+ (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b+ (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a+ (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e+ (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d+ (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c+ (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b+ (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a+ (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e+ (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d+ (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c+ (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b+ (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a+ (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e+ (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d+ (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c+ (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b+ (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a+ (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e+ (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d+ (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c+ (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b+ (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a+ (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e+ (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d+ (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c+ (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b+ (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a+ (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e+ (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d+ (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c+ (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b+ (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a+ (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e+ (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d+ (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c+ (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b+ (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a+ (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e+ (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d+ (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c+ (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b+ (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a+ (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e+ (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d+ (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c+ (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b+ (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a+ let abcde' = SHA1 (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e)+ sha1Step4Main abcde' (s `advancePtr` 16) (len - 64)+ where {-# INLINE f1 #-}+ f1 (XYZ x y z) = (x .&. y) .|. (complement x .&. z)+ {-# INLINE f2 #-}+ f2 (XYZ x y z) = x `xor` y `xor` z+ {-# INLINE f3 #-}+ f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z)+ {-# INLINE x #-}+ x n = peek (s `advancePtr` n)+ {-# INLINE m #-}+ m n = do let base = s `advancePtr` (n .&. 15)+ x0 <- peek base+ x1 <- peek (s `advancePtr` ((n - 14) .&. 15))+ x2 <- peek (s `advancePtr` ((n - 8) .&. 15))+ x3 <- peek (s `advancePtr` ((n - 3) .&. 15))+ let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1+ poke base res+ return res+ {-# INLINE doit #-}+ doit f k i a b c d e = a `seq` c `seq`+ do i' <- i+ return (rotateL a 5 + f (XYZ b c d) + e + i' + k,+ rotateL b 30)++showAsHex :: Word32 -> String+showAsHex n = showIt 8 n ""+ where+ showIt :: Int -> Word32 -> String -> String+ showIt 0 _ r = r+ showIt i x r = case quotRem x 16 of+ (y, z) -> let c = intToDigit (fromIntegral z)+ in c `seq` showIt (i-1) y (c:r)
+ src/Darcs/Util/Crypt/SHA256.hs view
@@ -0,0 +1,9 @@+module Darcs.Util.Crypt.SHA256 ( sha256sum ) where++import Crypto.Hash.SHA256 ( hash )+import Data.ByteString ( ByteString )+import Data.ByteString.Base16 ( encode )+import Data.ByteString.Char8 ( unpack )++sha256sum :: ByteString -> String+sha256sum = unpack . encode . hash
+ src/Darcs/Util/DateMatcher.hs view
@@ -0,0 +1,189 @@+-- Copyright (C) 2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE ExistentialQuantification #-}++-- |+-- Module : Darcs.Util.DateMatcher+-- Copyright : 2004 David Roundy+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++module Darcs.Util.DateMatcher+ (+ parseDateMatcher+ -- for debugging only+ , DateMatcher(..)+ , getMatchers+ ) where++import Control.Exception ( catchJust )+import Data.Maybe ( isJust )++import System.IO.Error ( isUserError, ioeGetErrorString )+import System.Time+import Text.ParserCombinators.Parsec ( eof, parse, ParseError )++import Darcs.Util.IsoDate+ ( parseDate, englishDateTime, englishInterval, englishLast+ , iso8601Interval, resetCalendar, subtractFromMCal, getLocalTz+ , MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime+ , unsetTime+ )++-- | 'withinDay' @x y@ is true if @x <= y < (x + one_day)@+-- Note that this converts the two dates to @ClockTime@ to avoid+-- any timezone-related errors+withinDay :: CalendarTime -> CalendarTime -> Bool+withinDay a b = within (Just $ toClockTime a)+ (Just (addToClockTime day $ toClockTime a))+ (toClockTime b)+ where+ day = TimeDiff 0 0 1 0 0 0 0++-- | 'dateRange' @x1 x2 y@ is true if @x1 <= y < x2@+-- Since @x1@ and @x2@ can be underspecified, we simply assume the+-- first date that they could stand for.+dateRange :: Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool+dateRange a b = cDateRange (fmap unsafeToCalendarTime a)+ (fmap unsafeToCalendarTime b)++-- | 'cDateRange' @x1 x2 y@ is true if @x1 <= y < x2@+cDateRange :: Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool+cDateRange a b c = within (fmap toClockTime a)+ (fmap toClockTime b) (toClockTime c)++-- | 'within' @x1 x2 y@ is true if @x1 <= y < x2@+within :: Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool+within (Just start) (Just end) time = start <= time && time < end+within Nothing (Just end) time = time < end+within (Just start) Nothing time = start <= time+within _ _ _ = undefined++-- | 'samePartialDate' @range exact@ is true if @exact@ falls+-- within the a range of dates represented by @range@.+-- The purpose of this function is to support matching on partially+-- specified dates. That is, if you only specify the date 2007,+-- this function should match any dates within that year. On the+-- other hand, if you specify 2007-01, this function will match any+-- dates within that month. This function only matches up to the+-- second.+samePartialDate :: MCalendarTime -> CalendarTime -> Bool+samePartialDate a b_ =+ within (Just clockA)+ (Just $ addToClockTime interval clockA)+ (toClockTime calB)+ where+ interval+ | isJust (mctSec a) = second+ | isJust (mctMin a) = minute+ | isJust (mctHour a) = hour+ | isJust (mctYDay a) = day+ | mctWeek a = maybe week (const day) (mctWDay a)+ | isJust (mctDay a) = day+ | isJust (mctMonth a) = month+ | otherwise = year+ year = TimeDiff 1 0 0 0 0 0 0+ month = TimeDiff 0 1 0 0 0 0 0+ week = TimeDiff 0 0 7 0 0 0 0+ day = TimeDiff 0 0 1 0 0 0 0+ hour = TimeDiff 0 0 0 1 0 0 0+ minute = TimeDiff 0 0 0 0 1 0 0+ second = TimeDiff 0 0 0 0 0 1 0+ clockA = toClockTime $ unsafeToCalendarTime a+ calB = resetCalendar b_++-- | A 'DateMatcher' combines a potential parse for a date string+-- with a "matcher" function that operates on a given date.+-- We use an existential type on the matcher to allow+-- the date string to either be interpreted as a point in time+-- or as an interval.+data DateMatcher = forall d . (Show d) => DM+ String -- name+ (Either ParseError d) -- parser+ (d -> CalendarTime -> Bool) -- matcher++-- | 'parseDateMatcher' @s@ return the first matcher in+-- 'getMatchers' that can parse 's'+parseDateMatcher :: String -> IO (CalendarTime -> Bool)+parseDateMatcher d = testDateMatcher `catchUserError` handleError+ where+ catchUserError = catchJust $ \e ->+ if isUserError e then Just (ioeGetErrorString e) else Nothing++ -- If the user enters a date > maxint seconds ago, the toClockTime+ -- function cannot work.+ handleError e = if e == "Time.toClockTime: invalid input"+ then error "Can't handle dates that far back!"+ else error e++ -- Hack: test the matcher against the current date and discard the results.+ -- We just want to make sure it won't throw any exceptions when we use it+ -- for real.+ testDateMatcher = do+ matcher <- tryMatchers `fmap` getMatchers d+ matcher `fmap` now >>= (`seq` return matcher)++-- | 'getMatchers' @d@ returns the list of matchers that will be+-- applied on @d@. If you wish to extend the date parsing code,+-- this will likely be the function that you modify to do so.+getMatchers :: String -> IO [DateMatcher]+getMatchers d = do+ rightNow <- now+ let midnightToday = unsetTime rightNow+ mRightNow = toMCalendarTime rightNow+ matchIsoInterval (Left dur) =+ let durAgo = dur `subtractFromMCal` mRightNow in+ dateRange (Just durAgo) (Just mRightNow)+ matchIsoInterval (Right (a,b)) = dateRange (Just a) (Just b)+ tzNow <- getLocalTz+ return+ -- note that the order of these is quite important as some matchers can+ -- match the same date.+ [ DM "from English date"+ (parseDateWith $ englishLast midnightToday)+ (\(a,_) -> cDateRange (Just a) Nothing)+ , DM "specific English date"+ (parseDateWith $ englishDateTime midnightToday)+ withinDay+ , DM "English interval"+ (parseDateWith $ englishInterval rightNow)+ (uncurry cDateRange)+ , DM "ISO 8601 interval"+ (parseDateWith $ iso8601Interval tzNow)+ matchIsoInterval+ , DM "CVS, ISO 8601, old style, or RFC2822 date"+ (parseDate tzNow d)+ samePartialDate+ ]+ where+ tillEof p = do { x <- p; eof; return x }+ parseDateWith p = parse (tillEof p) "" d++-- | 'tryMatchers' @ms@ returns the first successful match in @ms@+-- It is an error if there are no matches+tryMatchers :: [DateMatcher] -> CalendarTime -> Bool+tryMatchers (DM _ parsed matcher : ms) =+ case parsed of+ Left _ -> tryMatchers ms+ Right d -> matcher d+tryMatchers [] = error "Can't support fancy dates."++now :: IO CalendarTime+now = getClockTime >>= toCalendarTime
+ src/Darcs/Util/DateTime.hs view
@@ -0,0 +1,76 @@+-- Copyright (C) 2011 Eric Sessoms+--+-- BSD3++{-# LANGUAGE CPP #-}+#if MIN_VERSION_time(1,5,0)+-- for parseTime, which we need to use while we support time-1.4+{-# OPTIONS_GHC -fno-warn-deprecations #-}+#endif+module Darcs.Util.DateTime+ ( getCurrentTime, toSeconds+ , formatDateTime, fromClockTime, parseDateTime, startOfTime+ ) where++import qualified Data.Time.Calendar as Calendar ( fromGregorian )+import Data.Time.Clock+ ( UTCTime(UTCTime), UniversalTime(ModJulianDate)+ , getModJulianDate, secondsToDiffTime, getCurrentTime+ )+import Data.Time.Format ( formatTime, parseTime )+import Data.Time.LocalTime+ ( utc+ , localTimeToUT1, ut1ToLocalTime+ , localTimeToUTC, utcToLocalTime+ )+#if MIN_VERSION_time(1,5,0)+import Data.Time ( defaultTimeLocale )+#else+import System.Locale ( defaultTimeLocale )+#endif+import System.Time ( ClockTime(TOD) )++toSeconds :: UTCTime -> Integer+toSeconds dt = floor $+ (86400.0 :: Double) * fromRational (toMJD dt - startOfTimeMJD)++toMJD :: UTCTime -> Rational+toMJD = getModJulianDate . toUniversalTime++startOfTimeMJD :: Rational+startOfTimeMJD = toMJD startOfTime++startOfTime :: UTCTime+startOfTime = fromGregorian' 1970 1 1++fromGregorian' :: Integer -> Int -> Int -> UTCTime+fromGregorian' y m d = fromGregorian y m d 0 0 0++fromGregorian :: Integer -> Int -> Int -> Int -> Int -> Int -> UTCTime+fromGregorian year month day hours minutes seconds =+ UTCTime day' (secondsToDiffTime . fromIntegral $ seconds')+ where+ day' = Calendar.fromGregorian year month day+ seconds' = 3600 * hours + 60 * minutes + seconds++toUniversalTime :: UTCTime -> UniversalTime+toUniversalTime = localTimeToUT1 0 . utcToLocalTime utc++formatDateTime :: String -> UTCTime -> String+formatDateTime = formatTime defaultTimeLocale++parseDateTime :: String -> String -> Maybe UTCTime+parseDateTime = parseTime defaultTimeLocale++fromClockTime :: ClockTime -> UTCTime+fromClockTime (TOD s _) = fromSeconds s++fromSeconds :: Integer -> UTCTime+fromSeconds s = fromMJD $+ fromIntegral s / 86400 + startOfTimeMJD++fromMJD :: Rational -> UTCTime+fromMJD = fromUniversalTime . ModJulianDate++fromUniversalTime :: UniversalTime -> UTCTime+fromUniversalTime = localTimeToUTC utc . ut1ToLocalTime 0
+ src/Darcs/Util/Diff.hs view
@@ -0,0 +1,18 @@+module Darcs.Util.Diff+ ( getChanges+ , DiffAlgorithm(..)+ ) where++import qualified Darcs.Util.Diff.Myers as M ( getChanges )+import qualified Darcs.Util.Diff.Patience as P ( getChanges )+import qualified Data.ByteString as B ( ByteString )+++data DiffAlgorithm = PatienceDiff | MyersDiff+ deriving ( Eq, Show )++getChanges :: DiffAlgorithm -> [B.ByteString] -> [B.ByteString]+ -> [(Int,[B.ByteString],[B.ByteString])]+getChanges dac = case dac of+ PatienceDiff -> P.getChanges+ MyersDiff -> M.getChanges
+ src/Darcs/Util/Diff/Myers.hs view
@@ -0,0 +1,494 @@+-- Copyright (C) 2002 David Roundy+-- Copyright (C) 2005 Benedikt Schmidt+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++-- |+-- Module : Darcs.Util.Diff.Myers+-- Copyright : 2003 David Roundy+-- 2005 Benedikt Schmidt+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable+--+-- LCS stands for Longest Common Subsequence, and it is a relatively+-- challenging problem to find an LCS efficiently. This module implements+-- the algorithm described in:+--+-- "An O(ND) Difference Algorithm and its Variations", Eugene Myers,+-- Algorithmica Vol. 1 No. 2, 1986, pp. 251-266;+-- especially the variation described in section 4.2 and most refinements+-- implemented in GNU diff (D is the edit-distance).+--+-- There is currently no heuristic to reduce the running time and produce+-- suboptimal output for large inputs with many differences. It behaves like+-- GNU diff with the -d option in this regard.+--+-- In the first step, a hash value for every line is calculated and collisions+-- are marked with a special value. This reduces a string comparison to an+-- int comparison for line tuples where at least one of the hash values is+-- not equal to the special value. After that, lines which only exists in one+-- of the files are removed and marked as changed which reduces the running+-- time of the following difference algorithm. GNU diff additionally removes+-- lines that appear very often in the other file in some cases.+-- The last step tries to create longer changed regions and line up deletions+-- in the first file to insertions in the second by shifting changed lines+-- forward and backward.++module Darcs.Util.Diff.Myers+ ( getChanges+ , shiftBoundaries+ , initP+ , aLen+ , PArray+ , getSlice+ ) where++import Control.Monad+import Data.Int+import Control.Monad.ST+import Data.Maybe+import Darcs.Util.ByteString (hashPS)+import qualified Data.ByteString as B (empty, ByteString)+import Data.Array.Base+import Data.Array.Unboxed+import qualified Data.Map as Map ( lookup, empty, insertWith )++#include "impossible.h"++-- | create a list of changes between a and b, each change has the form+-- (starta, lima, startb, limb) which means that a[starta, lima)+-- has to be replaced by b[startb, limb)+getChanges :: [B.ByteString] -> [B.ByteString]+ -> [(Int,[B.ByteString],[B.ByteString])]+getChanges a b = dropStart (initP a) (initP b) 1++dropStart :: PArray -> PArray -> Int+ -> [(Int,[B.ByteString],[B.ByteString])]+dropStart a b off+ | off > aLen a = [(off - 1, [], getSlice b off (aLen b))]+ | off > aLen b = [(off - 1, getSlice a off (aLen a), [])]+ | a!off == b!off = dropStart a b (off + 1)+ | otherwise = dropEnd a b off 0++dropEnd :: PArray -> PArray -> Int -> Int+ -> [(Int,[B.ByteString],[B.ByteString])]+dropEnd a b off end+ | off > alast = [(off - 1, [], getSlice b off blast)]+ | off > blast = [(off - 1, getSlice a off alast, [])]+ | a!alast == b!blast = dropEnd a b off (end + 1)+ | otherwise = getChanges' (a, (off, alast)) (b, (off, blast))+ where alast = aLen a - end+ blast = aLen b - end++getSlice :: PArray -> Int -> Int -> [B.ByteString]+getSlice a from to+ | from > to = []+ | otherwise = (a ! from) : getSlice a (from + 1) to++getChanges' :: (PArray, (Int, Int)) -> (PArray, (Int, Int))+ -> [(Int,[B.ByteString],[B.ByteString])]+getChanges' (a, abounds) (b, bbounds) =+ map (convertPatch 0 a b) $ createPatch c_a c_b+ where+ -- If the last few characters of two lines are the same, the lines are+ -- probably the same. The choice of 20 is plucked out of the air.+ toHash x bnds = listArray bnds [ hashPS $ x!i | i <- range bnds]+ ah = toHash a abounds :: HArray+ mkAMap m (i:is) =+ let ins (_,_,_,new) (collision,_,_,old) =+ (collision || (new /= old), True, False, old)+ m' = Map.insertWith ins (ah!i) (False, True, False, a!i) m+ in mkAMap m' is+ mkAMap m _ = m+ hm_a = mkAMap Map.empty (range abounds)+ --+ bh = toHash b bbounds :: HArray+ mkBMap m (i:is) =+ let ins (_,_,_,new) (collision,in_a,_,old) =+ (collision || (new /= old), in_a, True, old)+ m' = Map.insertWith ins (bh!i) (False, False, True, b!i) m+ in mkBMap m' is+ mkBMap m _ = m+ hm = mkBMap hm_a (range bbounds)+ -- take care of collisions, if there are different lines with the+ -- same hash in both files, then set the hash to markColl,+ -- PackedStrings are compared for two lines with the hash markColl+ get (i, h) = case Map.lookup h hm of+ Just (_,False,_,_) -> Nothing+ Just (_,_,False,_) -> Nothing+ Just (False,True,True,_) -> Just (i, h)+ Just (True,True,True,_) -> Just (i, markColl)+ Nothing -> impossible++ a' = mapMaybe get [(i, ah!i) | i <- range (bounds ah)]+ b' = mapMaybe get [(i, bh!i) | i <- range (bounds bh)]++ (c_a, c_b) = diffArr a' b' (a, abounds) (b, bbounds)++-- | mark hash value where collision occured+markColl :: Int32+markColl = 2345677++-- | return arrays with changes in a and b (1 indexed), offsets start with 0+diffArr :: [(Int,Int32)] -> [(Int,Int32)]+ -> (PArray, (Int, Int)) -> (PArray, (Int, Int))+ -> (BArray, BArray)+diffArr a b (p_a, (off_a, l_a)) (p_b, (off_b, l_b)) = runST (+ do let h_a = initH (map snd a)+ h_b = initH (map snd b)+ m_a = initM (map fst a)+ m_b = initM (map fst b)+ end_a = aLen p_a+ end_b = aLen p_b+ c_a <- initVChanged end_a+ c_b <- initVChanged end_b+ mapM_ (\ (l,_) -> writeArray c_a l False) a+ mapM_ (\ (l,_) -> writeArray c_b l False) b+ _ <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b 0 0 (aLen h_a) (aLen h_b)+ let unchanged ar = do {xs <- getElems ar; return $ length (filter not xs) -1}+ err <- liftM2 (/=) (unchanged c_a) (unchanged c_b)+ when err impossible+ -- Mark common lines at beginning and end+ mapM_ (\ i -> writeArray c_a i False ) [1..(off_a - 1)]+ mapM_ (\ i -> writeArray c_b i False ) [1..(off_b - 1)]+ mapM_ (\ i -> writeArray c_a i False ) [(l_a + 1) .. end_a]+ mapM_ (\ i -> writeArray c_b i False ) [(l_b + 1) .. end_b]+ shiftBoundaries c_a c_b p_a 1 1+ shiftBoundaries c_b c_a p_b 1 1+ err1 <- liftM2 (/=) (unchanged c_a) (unchanged c_b)+ when err1 impossible+ c_a' <- unsafeFreeze c_a+ c_b' <- unsafeFreeze c_b+ return (c_a', c_b'))++-- | set changes array for a and b and return number of changed lines+cmpseq :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+ -> BSTArray s -> BSTArray s -> Int -> Int -> Int -> Int -> ST s Int+cmpseq _ _ _ _ _ _ _ _ _ _ 0 0 = return 0+cmpseq h_a h_b p_a p_b m_a m_b c_a c_b off_a off_b l_a l_b = do+ let lim_a = off_a+l_a+ lim_b = off_b+l_b+ off_a' = findSnake h_a h_b p_a p_b m_a m_b off_a off_b l_a l_b off_a off_b+ off_b' = off_b+off_a'-off_a+ lim_a' = findSnakeRev h_a h_b p_a p_b m_a m_b lim_a lim_b off_a' off_b'+ lim_b' = lim_b+lim_a'-lim_a+ l_a' = lim_a'-off_a'+ l_b' = lim_b'-off_b'+ if l_a' == 0 || l_b' == 0+ then if l_a' == 0+ then do when (l_b' > 0) $+ mapM_ (\i -> writeArray c_b (m_b!i) True)+ [(off_b' + 1) .. lim_b']+ return l_b'+ else do when (l_a' > 0) $+ mapM_ (\i -> writeArray c_a (m_a!i) True)+ [(off_a' + 1) .. lim_a']+ return l_a'+ else do let m = l_a' + l_b'+ del = l_a' - l_b'+ dodd = odd del+ v <- initV m+ vrev <- initVRev m l_a'+ writeArray vrev 0 l_a'+ writeArray v 0 0+ (xmid, ymid, _) <- findDiag 1 h_a h_b p_a p_b m_a m_b v vrev+ off_a' off_b' l_a' l_b' del dodd+ when ((xmid == 0 && ymid == 0) || (xmid == l_a' && ymid == l_b')+ || (xmid < 0 || ymid < 0 || xmid > l_a' || ymid > l_b'))+ impossible+ c1 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b+ off_a' off_b' xmid ymid+ c2 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b+ (off_a' + xmid) (off_b' + ymid)+ (l_a' - xmid) (l_b' - ymid)+ return $ c1 + c2++-- | return (xmid, ymid, cost) for the two substrings+-- a[off_a+1..off_a+1+l_a] and b+findDiag :: Int -> HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+ -> VSTArray s -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> Bool+ -> ST s (Int, Int, Int)+findDiag c h_a h_b p_a p_b m_a m_b v vrev off_a off_b l_a l_b del dodd = do+ when (c > l_a + l_b) $ error "findDiag failed"+ r <- findF+ case r of+ Just (xmid, ymid) -> return (xmid, ymid, c*2 - 1)+ Nothing ->+ do r' <- findR+ case r' of+ Just (xmid, ymid) -> return (xmid, ymid, c*2)+ Nothing -> findDiag (c + 1) h_a h_b p_a p_b m_a m_b v vrev+ off_a off_b l_a l_b del dodd+ where fdmax = if c <= l_a then c else l_a - ((l_a + c) `mod` 2)+ rdmax = if c <= l_b then c else l_b - ((l_b + c) `mod` 2)+ lastrdmax = if (c-1) <= l_b then c-1 else l_b-(l_b + (c-1) `mod` 2)+ lastrdmin = -(if (c-1) <= l_a then c-1 else l_a-((l_a + (c-1)) `mod` 2))+ fdmin = -rdmax+ rdmin = -fdmax+ findF = findF' fdmax+ findR = findR' rdmax+ findF' d = do x <- findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b+ if dodd && d - del >= lastrdmin && d - del <= lastrdmax+ then do xr <- readArray vrev (d - del)+ if xr <= x then return $ Just (x, x - d)+ else if d <= fdmin then return Nothing+ else findF' (d-2)+ else if d <= fdmin then return Nothing else findF' (d-2)+ findR' d = do x <- findOneRev h_a h_b p_a p_b m_a m_b vrev d del off_a off_b+ if not dodd && (d + del >= fdmin) && (d + del <= fdmax)+ then do xf <- readArray v (d + del)+ if x <= xf then return $ Just (x,x-del-d)+ else if d <= rdmin then return Nothing+ else findR' (d-2)+ else if d <= rdmin then return Nothing else findR' (d-2)++-- | find position on diag d with one more insert/delete going forward+findOne :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+ -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int+findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b = do+ x0 <- do xbelow <- readArray v (d - 1)+ xover <- readArray v (d + 1)+ return $ if xover > xbelow then xover else xbelow + 1+ let y0 = x0 - d+ x = findSnake h_a h_b p_a p_b m_a m_b (x0+off_a) (y0+off_b)+ l_a l_b off_a off_b+ writeArray v d (x - off_a)+ return (x-off_a)++-- | follow snake from northwest to southeast, x and y are absolute positions+findSnake :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+ -> Int -> Int -> Int -> Int -> Int -> Int -> Int+findSnake h_a h_b p_a p_b m_a m_b x y l_a l_b off_a off_b =+ if x < l_a + off_a && y < l_b + off_b && h_a!(x+1) == h_b!(y+1)+ && (h_a!(x+1) /= markColl || p_a!(m_a!(x+1)) == p_b!(m_b!(y+1)))+ then findSnake h_a h_b p_a p_b m_a m_b (x + 1) (y + 1) l_a l_b off_a off_b+ else x++-- | find position on diag d with one more insert/delete going backward+findOneRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+ -> VSTArray s -> Int -> Int -> Int -> Int -> ST s Int+findOneRev h_a h_b p_a p_b m_a m_b v d del off_a off_b = do+ x0 <- do xbelow <- readArray v (d - 1)+ xover <- readArray v (d + 1)+ return $ if xbelow < xover then xbelow else xover-1+ let y0 = x0 - del - d+ x = findSnakeRev h_a h_b p_a p_b m_a m_b (x0+off_a) (y0+off_b)+ off_a off_b+ writeArray v d (x-off_a)+ return (x-off_a)++-- | follow snake from southeast to northwest, x and y are absolute positions+findSnakeRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+ -> Int -> Int -> Int -> Int -> Int+findSnakeRev h_a h_b p_a p_b m_a m_b x y off_a off_b =+ if x > off_a && y > off_b && h_a!x == h_b!y+ && (h_a!x /= markColl || p_a!(m_a!x) == p_b!(m_b!y))+ then findSnakeRev h_a h_b p_a p_b m_a m_b (x - 1) (y - 1) off_a off_b+ else x++-- | try to create nicer diffs by shifting around regions of changed lines+shiftBoundaries :: BSTArray s -> BSTArray s -> PArray -> Int -> Int -> ST s ()+shiftBoundaries c_a c_b p_a i_ j_ =+ do x <- nextChanged c_a i_+ case x of+ Just start ->+ do let skipped = start - i_+ j1 <- nextUnchangedN c_b skipped j_+ end <- nextUnchanged c_a start+ j2 <- nextUnchanged c_b j1+ (i3,j3) <- expand start end j2+ shiftBoundaries c_a c_b p_a i3 j3+ Nothing -> return () -- no change up to end of file+ where noline = aLen p_a + 1+ expand start i j =+ do let len = i - start+ (start0,i0,j0) <- shiftBackward start i j+ b <- if j0 > 1 then readArray c_b (j0-1) else return False+ let corr = if b then i0 else noline+ let blank = if p_a!(i0-1) == B.empty then i0+ else noline+ (start1,i1,j1,corr1,blank1) <- shiftForward start0 i0 j0 corr blank+ -- prefer corresponding to ending with blank line+ let newi = if corr1 == noline then blank1+ else corr1+ (start2,i2,j2) <- moveCorr start1 i1 j1 newi+ if len /= i2 - start2+ then expand start2 i2 j2+ else return (i2, j2)+ shiftBackward start i j =+ if start > 1 && p_a!(i-1) == p_a!(start-1)+ then do when (i == start) impossible+ b1 <- readArray c_a (i-1)+ b2 <- readArray c_a (start-1)+ when (not b1 || b2) impossible+ writeArray c_a (i-1) False+ writeArray c_a (start-1) True+ b <- if start > 2 then readArray c_a (start-2)+ else return False+ start' <- if b then liftM (1+) (prevUnchanged c_a (start-2))+ else return (start-1)+ j' <- prevUnchanged c_b (j-1)+ shiftBackward start' (i-1) j'+ else return (start,i,j)+ shiftForward start i j corr blank =+ if i <= aLen p_a && p_a!i == p_a!start &&+ -- B.empty at the end of file marks empty line after final newline+ not ((i == aLen p_a) && (p_a!i == B.empty))+ then do when (i == start) impossible+ b1 <- readArray c_a i+ b2 <- readArray c_a start+ when (not b2 || b1) impossible+ writeArray c_a i True+ writeArray c_a start False+ i0 <- nextUnchanged c_a (i+1)+ j0 <- nextUnchanged c_b (j+1)+ let corr0+ | i0 > (i+1) = noline+ | j0-j > 2 = i0+ | otherwise = corr+ let blank0+ | i0 > i+1 = noline+ | p_a!(i0-1) == B.empty = i0+ | otherwise = blank+ shiftForward (start+1) i0 j0 corr0 blank0+ else return (start,i,j,corr,blank)+ moveCorr start i j corr =+ if corr >= i+ then return (start,i,j)+ else do b1 <- readArray c_a (i-1)+ b2 <- readArray c_a (start-1)+ when (not b1 || b2) impossible+ when (p_a!(i-1) /= p_a!(start-1)) impossible+ writeArray c_a (i-1) False+ writeArray c_a (start-1) True+ j' <- prevUnchanged c_b (j-1)+ moveCorr (start-1) (i-1) j' corr++-- | goto next unchanged line, return the given line if unchanged+nextUnchanged :: BSTArray s -> Int -> ST s Int+nextUnchanged c i = do+ len <- aLenM c+ if i == len + 1 then return i+ else do b <- readArray c i+ if b then nextUnchanged c (i+1)+ else return i++-- | skip at least one unchanged line, if there is none advance+-- behind the last line+skipOneUnChanged :: BSTArray s -> Int -> ST s Int+skipOneUnChanged c i = do+ len <- aLenM c+ if i == len + 1+ then return i+ else do b <- readArray c i+ if not b then return (i+1)+ else skipOneUnChanged c (i+1)++-- | goto n-th next unchanged line+nextUnchangedN :: BSTArray s -> Int -> Int -> ST s Int+nextUnchangedN c n i =+ if n == 0 then return i+ else do i' <- skipOneUnChanged c i+ nextUnchangedN c (n-1) i'++-- | goto next changed line, return the given line if changed+nextChanged :: BSTArray s -> Int -> ST s (Maybe Int)+nextChanged c i = do+ len <- aLenM c+ if i <= len+ then do b <- readArray c i+ if not b then nextChanged c (i+1)+ else return $ Just i+ else return Nothing++-- | goto previous unchanged line, return the given line if unchanged+prevUnchanged :: BSTArray s -> Int -> ST s Int+prevUnchanged c i = do+ b <- readArray c i+ if b then prevUnchanged c (i-1)+ else return i++type HArray = UArray Int Int32+type BArray = UArray Int Bool+type PArray = Array Int B.ByteString+type MapArray = UArray Int Int+type VSTArray s = STUArray s Int Int+type BSTArray s = STUArray s Int Bool++initV :: Int -> ST s (VSTArray s)+initV dmax = newArray (-(dmax + 1), dmax + 1) (-1)++initVRev :: Int -> Int -> ST s (VSTArray s)+initVRev dmax xmax = newArray (-(dmax + 1), dmax + 1) (xmax + 1)++-- 1 indexed, v[0] is used as a guard element+initVChanged :: Int -> ST s (BSTArray s)+initVChanged l = do+ a <- newArray (0, l) True+ writeArray a 0 False+ return a+ -- set to false for all lines which have a mapping later+ -- other lines are only present in one of the files++initH :: [Int32] -> HArray+initH a = listArray (0, length a) (0:a)++initM :: [Int] -> MapArray+initM a = listArray (0, length a) (0:a)++initP :: [B.ByteString] -> PArray+initP a = listArray (0, length a) (B.empty:a)++aLen :: (IArray a e) => a Int e -> Int+aLen a = snd $ bounds a+aLenM :: (MArray a e m) => a Int e -> m Int+aLenM a = snd `liftM` getBounds a++convertPatch :: Int -> PArray -> PArray -> (Int, Int, Int, Int)+ -> (Int,[B.ByteString],[B.ByteString])+convertPatch off a b (a0,a1,b0,b1)+ | b0 == b1 = (b0+off,getDelete a a0 a1,[])+ | a0 == a1 = (b0+off,[],getInsert b b0 b1)+ | otherwise = (b0+off,getDelete a a0 a1,getInsert b b0 b1)++getInsert :: PArray -> Int -> Int -> [B.ByteString]+getInsert b from to+ | from >= to = []+ | otherwise = (b!(from+1)):getInsert b (from+1) to+getDelete :: PArray -> Int -> Int -> [B.ByteString]+getDelete a from to+ | from >= to = []+ | otherwise = (a!(from+1)):getDelete a (from+1) to++createPatch :: BArray -> BArray -> [(Int, Int, Int, Int)]+createPatch c_a c_b =+ reverse $ createP c_a c_b (aLen c_a) (aLen c_b)++createP :: BArray -> BArray -> Int -> Int -> [(Int, Int, Int, Int)]+createP _ _ 0 0 = []+createP c_a c_b ia ib =+ if c_a!ia || c_b!ib+ then let ia' = skipChangedRev c_a ia+ ib' = skipChangedRev c_b ib+ in (ia',ia,ib',ib):createP c_a c_b ia' ib'+ else createP c_a c_b (ia-1) (ib-1)++skipChangedRev :: BArray -> Int -> Int+skipChangedRev c i = if i >= 0 && c!i then skipChangedRev c (i-1) else i
+ src/Darcs/Util/Diff/Patience.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE CPP #-}++-- Copyright (C) 2002,2008-2009 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software Foundation,+-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++module Darcs.Util.Diff.Patience+ ( getChanges+ ) where++import Data.List ( sort )+import Data.Array.Unboxed+import Data.Array.ST+import Control.Monad.ST+import qualified Data.Set as S+import qualified Data.ByteString as B ( ByteString, elem )+import qualified Data.ByteString.Char8 as BC ( pack )+#ifdef USE_LOCAL_DATA_MAP_STRICT+import qualified Darcs.Data.Map.Strict as M+#else+import qualified Data.Map.Strict as M+#endif+ ( Map, lookup, insertWith, empty, elems )+import qualified Data.Hashable as H ( hash )+import Darcs.Util.Diff.Myers (initP, aLen, PArray, getSlice)++#include "impossible.h"++empty :: HunkMap+empty = HunkMapInfo 0 M.empty++getChanges :: [B.ByteString] -> [B.ByteString]+ -> [(Int,[B.ByteString],[B.ByteString])]+getChanges a b = dropStart (initP a) (initP b) 1++dropStart :: PArray -> PArray -> Int+ -> [(Int,[B.ByteString],[B.ByteString])]+dropStart a b off+ | off > aLen a = [(off - 1, [], getSlice b off (aLen b))]+ | off > aLen b = [(off - 1, getSlice a off (aLen a), [])]+ | a!off == b!off = dropStart a b (off + 1)+ | otherwise = dropEnd a b off 0++dropEnd :: PArray -> PArray -> Int -> Int+ -> [(Int,[B.ByteString],[B.ByteString])]+dropEnd a b off end+ | off > alast = [(off - 1, [], getSlice b off blast)]+ | off > blast = [(off - 1, getSlice a off alast, [])]+ | a!alast == b!blast = dropEnd a b off (end + 1)+ | otherwise = getChanges' (off-1) (getSlice a off (aLen a - end')) (getSlice b off (aLen b - end'))+ where end' = addBorings end -- don't drop Borings just in case. See hidden_conflict2.sh+ addBorings e | e > 0 && a!(aLen a - (e-1)) `elem` borings' = addBorings (e-1)+ | otherwise = e+ alast = aLen a - end+ blast = aLen b - end++getChanges' :: Int -> [B.ByteString] -> [B.ByteString]+ -> [(Int, [B.ByteString], [B.ByteString])]+getChanges' off o n = convertLBS [] $ genNestedChanges [byparagraph, bylines] off oh nh+ where+ (_,m') = listToHunk borings' empty+ (oh,m) = listToHunk o m'+ (nh,lmap) = listToHunk n m+ convertLBS ys [] = reverse ys+ convertLBS ys ((i,os,ns):xs) = convertLBS ((i, hunkToBS os, hunkToBS ns):ys) xs+ hunkToBS hs = map (\h -> (!) harray (abs h)) hs+ harray = getBArray lmap++type HMap = M.Map+type Hash = Int+type Hunk = Int+data HunkMap = HunkMapInfo Int (HMap Hash [(Hunk, B.ByteString)])++getMap :: HunkMap -> HMap Hash [(Hunk, B.ByteString)]+getMap (HunkMapInfo _ m) = m++getSize :: HunkMap -> Int+getSize (HunkMapInfo s _) = s++getBArray :: HunkMap -> Array Hunk B.ByteString+getBArray (HunkMapInfo size b) = array (1,size) $ map (\(x,a) -> (abs x, a)) $ concat $ M.elems b++insert :: Hash -> B.ByteString -> HunkMap -> (Hunk, HunkMap)+insert h bs hmap = (hunknumber, HunkMapInfo newsize (M.insertWith (\_ o -> (hunknumber,bs):o) h [(hunknumber,bs)] $ getMap hmap))+ where hunknumber = if B.elem nl bs then -newsize -- used by bylines+ else newsize+ newsize = getSize hmap+1+ nl = 10 -- '\n'++--Given a HunkMap, check collisions and return the line with an updated Map+toHunk' :: HunkMap -> B.ByteString -> (Hunk, HunkMap)+toHunk' lmap bs | oldbs == Nothing || null oldhunkpair = insert hash bs lmap+ | otherwise = (fst $ head $ oldhunkpair, lmap)+ where hash = H.hash bs+ oldbs = M.lookup hash (getMap lmap)+ oldhunkpair = filter ((== bs) . snd) $ fromJust oldbs++listToHunk :: [B.ByteString] -> HunkMap -> ([Hunk], HunkMap)+listToHunk [] hmap = ([], hmap)+listToHunk (x:xs) hmap = let (y, hmap') = toHunk' hmap x+ (ys, hmap'') = listToHunk xs hmap'+ in ((y:ys), hmap'')++--listToHunk :: [B.ByteString] -> HunkMap -> ([Hunk], HunkMap)+--listToHunk = listToHunk' []+-- where listToHunk' xs [] hmap = (reverse xs, hmap)+-- listToHunk' xs (y:ys) hmap = let (h,hmap') = toHunk' hmap y+-- in listToHunk' (h:xs) ys hmap'+++genNestedChanges :: [[Hunk] -> [[Hunk]]]+ -> Int -> [Hunk] -> [Hunk]+ -> [(Int, [Hunk], [Hunk])]+genNestedChanges (br:brs) i0 o0 n0 = nc i0 (lcus ol nl) ol nl+ where nl = br n0+ ol = br o0+ nc i [] o n = easydiff i o n+ nc i (x:xs) o n =+ case break (==x) o of+ (oa, _:ob) ->+ case break (==x) n of+ (na, _:nb) ->+ i' `seq` easydiff i oa na ++ nc i' xs ob nb+ where i' = i + length (concat na) + length x+ (_,[]) -> impossible+ (_,[]) -> impossible+ easydiff i o n = genNestedChanges brs i oo nn+ where (oo, nn) = (concat o, concat n)+genNestedChanges [] i o n = mkdiff (all (`elem` borings)) i mylcs o n+ where mylcs = patientLcs (filter (`notElem` borings) o)+ (filter (`notElem` borings) n)++borings :: [Hunk]+borings = fst $ listToHunk borings' empty++borings' :: [B.ByteString]+borings' = map BC.pack ["", "\n", " ", ")", "(", ","]++byparagraph :: [Hunk] -> [[Hunk]]+byparagraph = reverse . (map reverse) . byparagraphAcc []+ where byparagraphAcc xs [] = xs+ byparagraphAcc [] (a:b:c:d)+ | a == nl && c == nl && b == hnull = case d of+ [] -> [[c,b,a]]+ _ -> byparagraphAcc [[],[c,b,a]] d+ byparagraphAcc [] (a:as) = byparagraphAcc [[a]] as+ byparagraphAcc (x:xs) (a:b:c:d)+ | a == nl && c == nl && b == hnull = case d of+ [] -> ((c:b:a:x):xs)+ _ -> byparagraphAcc ([]:((c:b:a:x):xs)) d+ byparagraphAcc (x:xs) (a:as) = byparagraphAcc ((a:x):xs) as+ nl = -1 -- "\n" hunk+ hnull = 1 -- "" hunk toHunk $ BC.pack ""++bylines :: [Hunk] -> [[Hunk]]+bylines = reverse . bylinesAcc []+ where bylinesAcc !ys [] = ys+ bylinesAcc !ys xs = case break (<0) xs of+ (_,[]) -> xs:ys+ (a,n:b) -> bylinesAcc ((a++[n]):ys) b+++-- | the longest common subsequence of unique items++lcus :: Ord a => [a] -> [a] -> [a]+lcus xs0 ys0 = lcs (filter (`S.member`u) xs0) (filter (`S.member`u) ys0)+ where uxs = findUnique xs0+ uys = findUnique ys0+ u = S.intersection uxs uys+ findUnique xs = S.fromList $ gru $ sort xs+ gru (x:x':xs) | x == x' = gru (dropWhile (==x) xs)+ gru (x:xs) = x : gru xs+ gru [] = []+++mkdiff :: Ord a =>+ ([a] -> Bool) -> Int -> [a] -> [a] -> [a] -> [(Int,[a],[a])]+mkdiff b ny (l:ls) (x:xs) (y:ys)+ | l == x && l == y = mkdiff b (ny+1) ls xs ys+mkdiff boring ny (l:ls) xs ys =+ if rmd == add+ then mkdiff boring (ny+length add+1) ls restx resty+ else if boring rmd && boring add+ then case lcs rmd add of+ [] -> prefixPostfixDiff ny rmd add +++ mkdiff boring (ny+length add+1) ls restx resty+ ll -> mkdiff (const False) ny ll rmd add +++ mkdiff boring (ny+length add+1) ls restx resty+ else prefixPostfixDiff ny rmd add +++ mkdiff boring (ny+length add+1) ls restx resty+ where rmd = takeWhile (/= l) xs+ add = takeWhile (/= l) ys+ restx = drop (length rmd + 1) xs+ resty = drop (length add + 1) ys+mkdiff _ _ [] [] [] = []+mkdiff boring ny [] rmd add =+ if boring rmd && boring add+ then case lcs rmd add of [] -> prefixPostfixDiff ny rmd add+ ll -> mkdiff (const False) ny ll rmd add+ else prefixPostfixDiff ny rmd add++prefixPostfixDiff :: Ord a => Int -> [a] -> [a] -> [(Int,[a],[a])]+prefixPostfixDiff _ [] [] = []+prefixPostfixDiff ny [] ys = [(ny,[],ys)]+prefixPostfixDiff ny xs [] = [(ny,xs,[])]+prefixPostfixDiff ny (x:xs) (y:ys)+ | x == y = prefixPostfixDiff (ny+1) xs ys+ | otherwise = [(ny, reverse rxs', reverse rys')]+ where (rxs',rys') = dropPref (reverse (x:xs)) (reverse (y:ys))+ dropPref (a:as) (b:bs) | a == b = dropPref as bs+ dropPref as bs = (as,bs)++-- | The patientLcs algorithm is inspired by the "patience" algorithm+-- (for which I don't have a reference handy), in that it looks for+-- unique lines, and uses them to subdivide the problem. I use lcs to+-- diff the unique lines. It is slower, but should lead to "better"+-- diffs, in the sense of ones that better align with what humans+-- think changed.+-- +-- Note that when compared with the Meyers algorithm used in darcs,+-- this is somewhat slower (maybe 4x in some of my tests), but is+-- lacking its stack overflow problem. I'm not sure how it scales in+-- general, but it scales fine (just 10x slower than GNU diff) when+-- comparing a 6M american english dictionary with a british english+-- dictionary of the same size (which isn't a great test, but is the+-- largest pair of somewhat-differing files I could find).+-- +-- Note that the patientLcs algorithm is slower than the one used in+-- lcs for sequences with mostly unique elements (as is common in text+-- files), but much *faster* when the sequence has a high degree of+-- redundancy. i.e. lines /usr/share/dict/words vs lines (cat+-- /usr/share/dict/words | tr 'a-z' 'a')++{-# SPECIALIZE patientLcs ::[Hunk] -> [Hunk] -> [Hunk] #-}+patientLcs :: Ord a => [a] -> [a] -> [a]+patientLcs [] _ = []+patientLcs _ [] = []+patientLcs (c1:c1s) (c2:c2s)+ | c1 == c2 = c1: patientLcs c1s c2s+ | otherwise =+ reverse $ patientLcs0 (reverse (c1:c1s)) (reverse (c2:c2s))++patientLcs0 :: Ord a => [a] -> [a] -> [a]+patientLcs0 xs0@(cc1:cc1s) ys0@(cc2:cc2s)+ | cc1 == cc2 = cc1 : patientLcs0 cc1s cc2s+ | otherwise = case (filter (`S.member`uys) xs0, filter (`S.member`uxs) ys0) of+ ([],_) -> lcs xs0 ys0+ (_,[]) -> lcs xs0 ys0+ (xs',ys') -> joinU (lcs xs' ys') xs0 ys0+ where uxs = findUnique xs0+ uys = findUnique ys0+ joinU [] x y = lcs x y+ joinU (b:bs) cs ds =+ case break (==b) cs of+ ([],_:c2) -> b : joinU bs c2 (drop 1 $ dropWhile (/= b) ds)+ (c1,_:c2) -> case break (==b) ds of+ ([],_:d2) -> b : joinU bs c2 d2+ (d1,_:d2) -> lcs c1 d1 ++ b : joinU bs c2 d2+ _ -> impossible+ _ -> impossible+ findUnique xs = S.fromList $ gru $ sort xs+ gru (x:x':xs) | x == x' = gru (dropWhile (==x) xs)+ gru (x:xs) = x : gru xs+ gru [] = []+ --findUnique xs = fu S.empty S.empty xs+ -- where fu _ uni [] = uni+ -- fu multi uni (y:ys)+ -- | y `S.member` multi = fu multi uni ys+ -- | y `S.member` uni = fu (S.insert y multi) (S.delete y uni) ys+ -- | otherwise = fu multi (S.insert y uni) ys+patientLcs0 [] _ = []+patientLcs0 _ [] = []++-- | ``LCS'' stands for ``Longest Common Subsequence,'' and it is a relatively+-- challenging problem to find an LCS efficiently. I'm not going to explain+-- here what an LCS is, but will point out that it is useful in finding how+-- two sequences (lists, in this case) differ. This module implements the+-- Hunt-Szymanski algorithm, which is appropriate for applications in which+-- the sequence is on an infinite alphabet, such as diffing the lines in two+-- files, where many, or most lines are unique. In the best case scenario, a+-- permutation of unique lines, this algorithm is $O(n\log n)$. In the worst+-- case scenario, that of a finite alphabet (i.e.\ where the number of elements+-- in the sequence is much greater than the number of unique elements), it is+-- an $O(n^2\log n)$ algorithm, which is pretty terrible.++{-# SPECIALIZE lcs ::[Hunk] -> [Hunk] -> [Hunk] #-}+lcs :: Ord a => [a] -> [a] -> [a]+lcs [] _ = []+lcs _ [] = []+lcs (c1:c1s) (c2:c2s)+ | c1 == c2 = c1: lcs c1s c2s+ | otherwise =+ reverse $ lcs_simple (reverse (c1:c1s)) (reverse (c2:c2s))++lcs_simple :: Ord a => [a] -> [a] -> [a]+lcs_simple [] _ = []+lcs_simple _ [] = []+lcs_simple s1@(c1:c1s) s2@(c2:c2s)+ | c1 == c2 = c1: lcs c1s c2s+ | otherwise = hunt $ prune_matches s1 $! find_matches s1 s2++prune_matches :: [a] -> [[Int]] -> [(a, [Int])]+prune_matches _ [] = []+prune_matches [] _ = []+prune_matches (_:cs) ([]:ms) = prune_matches cs ms+prune_matches (c:cs) (m:ms) = (c,m): prune_matches cs ms++type Threshold s a = STArray s Int (Int,[a])++hunt :: [(a, [Int])] -> [a]+hunt [] = []+hunt csmatches =+ runST ( do th <- empty_threshold (length csmatches) l+ hunt_internal csmatches th+ hunt_recover th (-1) l )+ where l = maximum (0 : concat (map snd csmatches))++hunt_internal :: [(a, [Int])] -> Threshold s a -> ST s ()+hunt_internal [] _ = return ()+hunt_internal ((c,m):csms) th = do+ hunt_one_char c m th+ hunt_internal csms th++hunt_one_char :: a -> [Int] -> Threshold s a -> ST s ()+hunt_one_char _ [] _ = return ()+hunt_one_char c (j:js) th = do+ index_k <- my_bs j th+ case index_k of+ Nothing -> return ()+ Just k -> do+ (_, rest) <- readArray th (k-1)+ writeArray th k (j, c:rest)+ hunt_one_char c js th++-- This is O(n), which is stupid.+hunt_recover :: Threshold s a -> Int -> Int -> ST s [a]+hunt_recover th n limit =+ do (_, th_max) <- getBounds th+ if n < 0+ then hunt_recover th th_max limit+ else if n == 0+ then return []+ else if n > th_max+ then return []+ else do (thn, sn) <- readArray th n+ if thn <= limit+ then return $ reverse sn+ else hunt_recover th (n-1) limit++empty_threshold :: Int -> Int -> ST s (Threshold s a)+empty_threshold l th_max = do+ th <- newArray (0,l) (th_max+1, [])+ writeArray th 0 (0, [])+ return th++my_bs :: Int -> Threshold s a -> ST s (Maybe Int)+my_bs j th = do bnds <- getBounds th+ my_helper_bs j bnds th++my_helper_bs :: Int -> (Int,Int) -> Threshold s a ->+ ST s (Maybe Int)+my_helper_bs j (th_min,th_max) th =+ if th_max - th_min > 1 then do+ (midth, _) <- readArray th th_middle+ if j > midth+ then my_helper_bs j (th_middle,th_max) th+ else my_helper_bs j (th_min,th_middle) th+ else do+ (minth, _) <- readArray th th_min+ (maxth, _) <- readArray th th_max+ if minth < j && maxth > j+ then return $ Just th_max+ else if j < minth then return $ Just th_min+ else return Nothing+ where th_middle = (th_max+th_min) `div` 2++++find_matches :: Ord a => [a] -> [a] -> [[Int]]+find_matches [] [] = []+find_matches [] (_:bs) = []: find_matches [] bs+find_matches _ [] = []+find_matches a b =+ unzip_indexed $ sort $ find_sorted_matches indexeda indexedb [] []+ where indexeda = sort $ zip a [1..]+ indexedb = sort $ zip b [1..]++unzip_indexed :: [(Int,[a])] -> [[a]]+unzip_indexed s = unzip_indexed_helper 1 s+ where unzip_indexed_helper _ [] = []+ unzip_indexed_helper thisl ((l,c):rest)+ | thisl == l = c: unzip_indexed_helper (l+1) rest+ | otherwise = []: unzip_indexed_helper (thisl+1) ((l,c):rest)++find_sorted_matches :: Ord a => [(a, Int)] -> [(a, Int)] -> [a] -> [Int]+ -> [(Int, [Int])]+find_sorted_matches [] _ _ _ = []+find_sorted_matches _ [] _ _ = []+find_sorted_matches ((a,na):as) ((b,nb):bs) aold aoldmatches+ | [a] == aold = (na, aoldmatches) :+ find_sorted_matches as ((b,nb):bs) aold aoldmatches+ | a > b = find_sorted_matches ((a,na):as) bs aold aoldmatches+ | a < b = find_sorted_matches as ((b,nb):bs) aold aoldmatches+-- following line is inefficient if a line is repeated many times.+find_sorted_matches ((a,na):as) bs _ _ -- a == b+ = (na, matches) : find_sorted_matches as bs [a] matches+ where matches = reverse $ map snd $ filter ((==a) . fst) bs
+ src/Darcs/Util/Download.hs view
@@ -0,0 +1,351 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} -- using isEmptyChan+{-# LANGUAGE CPP #-}++-- |+-- Module : Darcs.Util.Download+-- Copyright : 2008 Dmitry Kurochkin <dmitry.kurochkin@gmail.com>+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++module Darcs.Util.Download+ ( copyUrl+ , copyUrlFirst+ , setDebugHTTP+ , disableHTTPPipelining+ , maxPipelineLength+ , waitUrl+ , Cachable(Cachable, Uncachable, MaxAge)+ , environmentHelpProxy+ , environmentHelpProxyPassword+ , ConnectionError(..)+ ) where++import Control.Arrow ( (&&&) )+import Control.Concurrent ( forkIO )+import Control.Concurrent.Chan ( isEmptyChan, newChan, readChan, writeChan,+ Chan )+import Control.Concurrent.MVar ( isEmptyMVar, modifyMVar_, modifyMVar, newEmptyMVar,+ newMVar, putMVar, readMVar, withMVar, MVar )+import Control.Monad ( unless, when )+import Control.Monad.State ( evalStateT, get, modify, put, StateT )+import Control.Monad.Trans ( liftIO )+import Data.IORef ( newIORef, readIORef, writeIORef, IORef )+import Data.Map ( Map )+import qualified Data.Map as Map+import Data.Tuple ( swap )+import System.Directory ( copyFile )+import System.IO.Unsafe ( unsafePerformIO )+import System.Random ( randomRIO )++import Darcs.Util.AtExit ( atexit )+import Darcs.Util.File ( removeFileMayNotExist )+import Numeric ( showHex )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Download.Request+import Darcs.Util.Workaround ( renameFile )++#ifdef HAVE_CURL+import qualified Darcs.Util.Download.Curl as Curl+#elif defined(HAVE_HTTP)+import qualified Darcs.Util.Download.HTTP as HTTP+#else+import Darcs.Util.Progress ( debugFail )+import qualified HTTP ( requestUrl, waitNextUrl )+#endif++#include "impossible.h"++{-# NOINLINE maxPipelineLengthRef #-}+maxPipelineLengthRef :: IORef Int+maxPipelineLengthRef = unsafePerformIO $ do+ enabled <- pipeliningEnabled+#ifdef HAVE_CURL+ unless enabled $ debugMessage $+ "Warning: pipelining is disabled, because libcurl version darcs was "+ ++ "compiled with is too old (< 7.19.1)"+#endif+ newIORef $ if enabled then 100 else 1++maxPipelineLength :: IO Int+maxPipelineLength = readIORef maxPipelineLengthRef++{-# NOINLINE urlNotifications #-}+urlNotifications :: MVar (Map String (MVar (Maybe String)))+urlNotifications = unsafePerformIO $ newMVar Map.empty++{-# NOINLINE urlChan #-}+urlChan :: Chan UrlRequest+urlChan = unsafePerformIO $ do+ ch <- newChan+ _ <- forkIO (urlThread ch)+ return ch++type UrlM a = StateT UrlState IO a++urlThread :: Chan UrlRequest -> IO ()+urlThread ch = do+ junk <- flip showHex "" `fmap` randomRIO rrange+ evalStateT urlThread' (UrlState Map.empty emptyQ 0 junk)+ where+ rrange = (0, 2 ^ (128 :: Integer) :: Integer)++ urlThread' :: UrlM ()+ urlThread' = do+ empty <- liftIO $ isEmptyChan ch+ (l, w) <- (pipeLength &&& waitToStart) `fmap` get+ -- If we've got UrlRequests waiting on the chan, or there's nothing+ -- waiting to start and nothing already downloading, we just block+ -- waiting for more UrlRequests.+ reqs <- if not empty || (nullQ w && l == 0)+ then liftIO readAllRequests+ else return []+ mapM_ addReq reqs+ checkWaitToStart+ waitNextUrl+ urlThread'++ readAllRequests :: IO [UrlRequest]+ readAllRequests = do+ r <- readChan ch+ debugMessage $ "URL.urlThread (" ++ url r ++ "\n"+++ "-> " ++ file r ++ ")"+ empty <- isEmptyChan ch+ reqs <- if not empty+ then readAllRequests+ else return []+ return (r : reqs)++ -- | addReq adds a UrlRequest to the current downloads, being careful to+ -- update the lists of target filenames if the url is already being+ -- downloaded.+ addReq :: UrlRequest -> UrlM ()+ addReq (UrlRequest u f c p) = do+ d <- liftIO (alreadyDownloaded u)+ if d+ then dbg "Ignoring UrlRequest of URL that is already downloaded."+ else do+ (ip, wts) <- (inProgress &&& waitToStart) `fmap` get+ case Map.lookup u ip of+ Nothing -> modify $ \st ->+ st { inProgress = Map.insert u (f, [], c) ip+ , waitToStart = addUsingPriority p u wts }+ Just (f', fs', c') -> do+ let new_c = minCachable c c'+ when (c /= c') $ do+ let new_p = Map.insert u (f', fs', new_c) ip+ modify (\s -> s { inProgress = new_p })+ dbg $ "Changing " ++ u ++ " request cachability from "+ ++ show c ++ " to " ++ show new_c+ when (u `elemQ` wts && p == High) $ do+ modify $ \s ->+ s { waitToStart = pushQ u (deleteQ u wts) }+ dbg $ "Moving " ++ u ++ " to head of download queue."+ if f `notElem` (f' : fs')+ then do+ let new_ip = Map.insert u (f', f : fs', new_c) ip+ modify (\s -> s { inProgress = new_ip })+ dbg "Adding new file to existing UrlRequest."+ else dbg $ "Ignoring UrlRequest of file that's "+ ++ "already queued."++ alreadyDownloaded :: String -> IO Bool+ alreadyDownloaded u = do+ n <- withMVar urlNotifications $ return . Map.lookup u+ maybe (return True) (\v -> not `fmap` isEmptyMVar v) n++-- |'checkWaitToStart' will inspect the current waiting-to-start queue, if the+-- pipe isn't full,+checkWaitToStart :: UrlM ()+checkWaitToStart = do+ st <- get+ let l = pipeLength st+ mpl <- liftIO maxPipelineLength+ when (l < mpl) $+ case readQ (waitToStart st) of+ Nothing -> return ()+ Just (u, rest) -> do+ case Map.lookup u (inProgress st) of+ Nothing -> bug $ "bug in URL.checkWaitToStart " ++ u+ Just (f, _, c) -> do+ dbg $ "URL.requestUrl (" ++ u ++ "\n"+ ++ "-> " ++ f ++ ")"+ let f_new = createDownloadFileName f st+ err <- liftIO $ requestUrl u f_new c+ if null err+ then do+ -- waitNextUrl might never return this url as+ -- complete/failed, so being careful, we should+ -- try and delete the corresponding file atexit+ liftIO $ atexit (removeFileMayNotExist f_new)+ -- We've started off another download, so the+ -- pipline length should increase.+ put $ st { waitToStart = rest+ , pipeLength = l + 1 }+ else do+ dbg $ "Failed to start download URL " ++ u+ ++ ": " ++ err+ liftIO $ do+ removeFileMayNotExist f_new+ downloadComplete u err+ put $ st { waitToStart = rest }+ checkWaitToStart++copyUrlFirst :: String -> FilePath -> Cachable -> IO ()+copyUrlFirst = copyUrlWithPriority High++copyUrl :: String -> FilePath -> Cachable -> IO ()+copyUrl = copyUrlWithPriority Low++copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO ()+copyUrlWithPriority p u f c = do+ debugMessage $ "URL.copyUrlWithPriority (" ++ u ++ "\n"+ ++ "-> " ++ f ++ ")"+ v <- newEmptyMVar+ old_mv <- modifyMVar urlNotifications (return . swap . Map.insertLookupWithKey (\_k _n old -> old) u v)+ case old_mv of+ Nothing -> writeChan urlChan $ UrlRequest u f c p -- ok, new URL+ Just _ -> debugMessage $ "URL.copyUrlWithPriority already in progress, skip (" ++ u ++ "\n" ++ "-> " ++ f ++ ")"++createDownloadFileName :: FilePath -> UrlState -> FilePath+createDownloadFileName f st = f ++ "-new_" ++ randomJunk st++waitNextUrl :: UrlM ()+waitNextUrl = do+ st <- get+ let l = pipeLength st+ when (l > 0) $ do+ dbg "URL.waitNextUrl start"+ (u, e, ce) <- liftIO waitNextUrl'+ let p = inProgress st+ liftIO $ case Map.lookup u p of+ Nothing ->+ -- A url finished downloading, but we don't have a record of it+ bug $ "bug in URL.waitNextUrl: " ++ u+ Just (f, fs, _) -> if null e+ then do -- Succesful download+ renameFile (createDownloadFileName f st) f+ mapM_ (safeCopyFile st f) fs+ downloadComplete u e+ debugMessage $+ "URL.waitNextUrl succeeded: " ++ u ++ " " ++ f+ else do -- An error while downloading+ removeFileMayNotExist (createDownloadFileName f st)+ downloadComplete u (maybe e show ce)+ debugMessage $+ "URL.waitNextUrl failed: " ++ u ++ " " ++ f ++ " " ++ e+ unless (null u) . put $ st { inProgress = Map.delete u p+ , pipeLength = l - 1 }+ where+ safeCopyFile st f t = do+ let new_t = createDownloadFileName t st+ copyFile f new_t+ renameFile new_t t++downloadComplete :: String -> String -> IO ()+downloadComplete u e = do+ r <- withMVar urlNotifications (return . Map.lookup u)+ case r of+ Just notifyVar ->+ putMVar notifyVar $ if null e then Nothing else Just e+ Nothing -> debugMessage $ "downloadComplete URL '" ++ u+ ++ "' downloaded several times"++waitUrl :: String -> IO ()+waitUrl u = do+ debugMessage $ "URL.waitUrl " ++ u+ r <- withMVar urlNotifications (return . Map.lookup u)+ case r of+ Nothing -> return () -- file was already downloaded+ Just var -> do+ mbErr <- readMVar var+ modifyMVar_ urlNotifications (return . Map.delete u)+ flip (maybe (return ())) mbErr $ \e -> do+ debugMessage $ "Failed to download URL " ++ u ++ ": " ++ e+ fail e++dbg :: String -> StateT a IO ()+dbg = liftIO . debugMessage++minCachable :: Cachable -> Cachable -> Cachable+minCachable Uncachable _ = Uncachable+minCachable _ Uncachable = Uncachable+minCachable (MaxAge a) (MaxAge b) = MaxAge $ min a b+minCachable (MaxAge a) _ = MaxAge a+minCachable _ (MaxAge b) = MaxAge b+minCachable _ _ = Cachable++disableHTTPPipelining :: IO ()+disableHTTPPipelining = writeIORef maxPipelineLengthRef 1++setDebugHTTP :: IO ()+requestUrl :: String -> FilePath -> Cachable -> IO String+waitNextUrl' :: IO (String, String, Maybe ConnectionError)+pipeliningEnabled :: IO Bool++#ifdef HAVE_CURL++setDebugHTTP = Curl.setDebugHTTP+requestUrl = Curl.requestUrl+waitNextUrl' = Curl.waitNextUrl+pipeliningEnabled = Curl.pipeliningEnabled++#elif defined(HAVE_HTTP)++setDebugHTTP = return ()+requestUrl = HTTP.requestUrl+waitNextUrl' = HTTP.waitNextUrl+pipeliningEnabled = return False++#else++setDebugHTTP = debugMessage "URL.setDebugHttp works only with libcurl"+requestUrl _ _ _ = debugFail "URL.requestUrl: there is no libcurl!"+waitNextUrl' = debugFail "URL.waitNextUrl': there is no libcurl!"+pipeliningEnabled = return False++#endif++-- Usage of these environment variables happens in C code, so the+-- closest to "literate" user documentation is here, where the+-- offending function 'curl_request_url' is imported.+environmentHelpProxy :: ([String], [String])+environmentHelpProxy =+ ( [ "HTTP_PROXY", "HTTPS_PROXY", "FTP_PROXY", "ALL_PROXY", "NO_PROXY"]+ , [ "If Darcs was built with libcurl, the environment variables"+ , "HTTP_PROXY, HTTPS_PROXY and FTP_PROXY can be set to the URL of a"+ , "proxy in the form"+ , ""+ , " [protocol://]<host>[:port]"+ , ""+ , "In which case libcurl will use the proxy for the associated protocol"+ , "(HTTP, HTTPS and FTP). The environment variable ALL_PROXY can be used"+ , "to set a single proxy for all libcurl requests."+ , ""+ , "If the environment variable NO_PROXY is a comma-separated list of"+ , "host names, access to those hosts will bypass proxies defined by the"+ , "above variables. For example, it is quite common to avoid proxying"+ , "requests to machines on the local network with"+ , ""+ , " NO_PROXY=localhost,*.localdomain"+ , ""+ , "For compatibility with lynx et al, lowercase equivalents of these"+ , "environment variables (e.g. $http_proxy) are also understood and are"+ , "used in preference to the uppercase versions."+ , ""+ , "If Darcs was not built with libcurl, all these environment variables"+ , "are silently ignored, and there is no way to use a web proxy."+ ]+ )++environmentHelpProxyPassword :: ([String], [String])+environmentHelpProxyPassword =+ ( [ "DARCS_PROXYUSERPWD" ]+ , [ "If Darcs was built with libcurl, and you are using a web proxy that"+ , "requires authentication, you can set the $DARCS_PROXYUSERPWD"+ , "environment variable to the username and password expected by the"+ , "proxy, separated by a colon. This environment variable is silently"+ , "ignored if Darcs was not built with libcurl."+ ]+ )
+ src/Darcs/Util/Download/Curl.hs view
@@ -0,0 +1,80 @@+{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Darcs.Util.Download.Curl where++#ifdef HAVE_CURL++import Control.Exception ( bracket )+import Control.Monad ( when )+import Foreign.C.Types ( CLong(..), CInt(..) )++import Darcs.Util.Progress ( debugMessage )++import Darcs.Util.Download.Request++import Foreign.C.String ( withCString, peekCString, CString )+import Foreign.Ptr+import Foreign.Marshal.Alloc+import Foreign.Storable++setDebugHTTP :: IO ()+setDebugHTTP = curl_enable_debug++requestUrl :: String -> FilePath -> Cachable -> IO String+requestUrl u f cache =+ withCString u $ \ustr ->+ withCString f $ \fstr ->+ bracket malloc free $ \ errorPointer -> do+ e <- curl_request_url ustr fstr (cachableToInt cache) errorPointer >>= peekCString+ errorNum <- peek errorPointer+ when (errorNum == 90 ) $ debugMessage "The environment variable DARCS_CONNECTION_TIMEOUT is not a number"+ return e++waitNextUrl :: IO (String, String, Maybe ConnectionError)+waitNextUrl =+ bracket malloc free $ \ errorPointer ->+ bracket malloc free $ \ httpErrorPointer -> do+ e <- curl_wait_next_url errorPointer httpErrorPointer >>= peekCString+ ce <- do+ errorNum <- peek errorPointer+ if null e then return Nothing+ else return $+ case errorNum of+ 6 -> Just CouldNotResolveHost+ 7 -> Just CouldNotConnectToServer+ 28 -> Just OperationTimeout+ _ -> Nothing+ u <- curl_last_url >>= peekCString+ httpErrorCode <- peek httpErrorPointer+ let detailedErrorMessage = if httpErrorCode > 0+ then e ++ " " ++ show httpErrorCode+ else e+ return (u, detailedErrorMessage, ce)++pipeliningEnabled :: IO Bool+pipeliningEnabled = do+ r <- curl_pipelining_enabled+ return $ r /= 0++cachableToInt :: Cachable -> CInt+cachableToInt Cachable = -1+cachableToInt Uncachable = 0+cachableToInt (MaxAge n) = n++foreign import ccall "hscurl.h curl_request_url"+ curl_request_url :: CString -> CString -> CInt -> Ptr CInt -> IO CString++foreign import ccall "hscurl.h curl_wait_next_url"+ curl_wait_next_url :: Ptr CInt -> Ptr CLong-> IO CString++foreign import ccall "hscurl.h curl_last_url"+ curl_last_url :: IO CString++foreign import ccall "hscurl.h curl_enable_debug"+ curl_enable_debug :: IO ()++foreign import ccall "hscurl.h curl_pipelining_enabled"+ curl_pipelining_enabled :: IO CInt++#endif
+ src/Darcs/Util/Download/HTTP.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE CPP #-}++module Darcs.Util.Download.HTTP+ ( fetchUrl, postUrl, requestUrl, waitNextUrl+ ) where++import Prelude hiding ( catch )++import Darcs.Util.Global ( debugFail )++import Darcs.Util.Download.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 )+import Network.URI+import System.IO.Error ( ioeGetErrorString )+import System.IO.Unsafe ( unsafePerformIO )+import Darcs.Util.Global ( debugMessage )+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Version ( version )+#endif++fetchUrl :: String -> IO String+postUrl+ :: String -- ^ url+ -> String -- ^ body+ -> String -- ^ mime type+ -> IO () -- ^ result++requestUrl :: String -> FilePath -> a -> IO String+waitNextUrl :: IO (String, String, Maybe ConnectionError)++#ifdef HAVE_HTTP++headers :: [Header]+headers = [Header HdrUserAgent $ "darcs-HTTP/" ++ version]++fetchUrl url = case parseURI url of+ Nothing -> fail $ "Invalid URI: " ++ url+ Just uri -> do debugMessage $ "Fetching over HTTP: "++url+ resp <- catch (browse $ do+ setCheckForProxy True+ setOutHandler debugMessage+ setErrHandler debugMessage+ request Request { rqURI = uri,+ rqMethod = GET,+ rqHeaders = headers,+ rqBody = "" })+ (\(err :: IOException) -> debugFail $ show err)+ case resp of+ (_, res@Response { rspCode = (2,0,0) }) -> return (rspBody res)+ (_, Response { rspCode = (x,y,z) }) ->+ debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error getting " ++ show uri++postUrl url body mime = case parseURI url of+ Nothing -> fail $ "Invalid URI: " ++ url+ Just uri -> do debugMessage $ "Posting to HTTP: "++url+ resp <- catch (browse $ do+ setCheckForProxy True+ setOutHandler debugMessage+ setErrHandler debugMessage+ request Request { rqURI = uri,+ rqMethod = POST,+ rqHeaders = headers ++ [Header HdrContentType mime,+ Header HdrAccept "text/plain",+ Header HdrContentLength+ (show $ length body) ],+ rqBody = body })+ (\(err :: IOException) -> debugFail $ show err)+ case resp of+ (_, res@Response { rspCode = (2,y,z) }) -> do+ putStrLn $ "Success 2" ++ show y ++ show z+ putStrLn (rspBody res)+ return ()+ (_, res@Response { rspCode = (x,y,z) }) -> do+ putStrLn $ rspBody res+ debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error posting to " ++ show uri++requestedUrl :: IORef (String, FilePath)+requestedUrl = unsafePerformIO $ newIORef ("", "")++requestUrl u f _ = do+ (u', _) <- readIORef requestedUrl+ if null u'+ then do writeIORef requestedUrl (u, f)+ return ""+ else return "URL already requested"++waitNextUrl = do+ (u, f) <- readIORef requestedUrl+ if null u+ then return ("", "No URL requested", Nothing)+ else do writeIORef requestedUrl ("", "")+ e <- (fetchUrl u >>= \s -> B.writeFile f (BC.pack s) >> return "") `catch` h+ let ce = case e of+ "timeout" -> Just OperationTimeout+ _ -> Nothing+ return (u, e, ce)+ where h = return . ioeGetErrorString++#else++fetchUrl _ = debugFail "Network.HTTP does not exist"+postUrl _ _ _ = debugFail "Cannot use http POST because darcs was not compiled with Network.HTTP."++requestUrl _ _ _ = debugFail "Network.HTTP does not exist"+waitNextUrl = debugFail "Network.HTTP does not exist"++#endif
+ src/Darcs/Util/Download/Request.hs view
@@ -0,0 +1,107 @@+module Darcs.Util.Download.Request+ ( UrlRequest(..)+ , Cachable(..)+ , UrlState(..)+ , Q(..)+ , readQ+ , insertQ+ , pushQ+ , addUsingPriority+ , deleteQ+ , elemQ+ , emptyQ+ , nullQ+ , Priority(..)+ , ConnectionError(..)+ ) where++import Data.List ( delete )+import Data.Map ( Map )+import Foreign.C.Types ( CInt )++data Priority = High+ | Low+ deriving Eq++data Cachable = Cachable+ | Uncachable+ | MaxAge !CInt+ deriving (Show, Eq)++-- | A UrlRequest object contains a url to get, the file into which the+-- contents at the given url should be written, the cachability of this request+-- and the request's priority.+data UrlRequest = UrlRequest+ { url :: String+ , file :: FilePath+ , cachable :: Cachable+ , priority :: Priority+ }++type InProgressStatus = ( FilePath -- FilePath to write url contents into+ , [FilePath] -- Extra paths to copy complete file into+ , Cachable -- Cachable status+ )++-- | A UrlState object contains a map of url -> InProgressStatus, a Q of urls+-- waiting to be started, the current pipe length and the unique junk to+-- create unique filenames.+data UrlState = UrlState+ { inProgress :: Map String InProgressStatus+ , waitToStart :: Q String+ , pipeLength :: Int+ , randomJunk :: String+ }++-- |Q represents a prioritised queue, with two-tier priority. The left list+-- contains higher priority items than the right list.+data Q a = Q [a] [a]++-- |'readQ' will try and take an element from the Q, preferring elements from+-- the high priority list.+readQ :: Q a -> Maybe (a, Q a)+readQ (Q (x : xs) ys) = return (x, Q xs ys)+readQ (Q [] ys) = do+ x : xs <- return $ reverse ys+ return (x, Q xs [])++-- | Return a function for adding an element based on the priority.+addUsingPriority :: Priority -> a -> Q a -> Q a+addUsingPriority High = pushQ+addUsingPriority Low = insertQ++-- |'insertQ' inserts a low priority item into a Q.+insertQ :: a -> Q a -> Q a+insertQ y (Q xs ys) = Q xs (y:ys)++-- |'pushQ' inserts a high priority item into a Q.+pushQ :: a -> Q a -> Q a+pushQ x (Q xs ys) = Q (x:xs) ys++-- |'deleteQ' removes any instances of a given element from the Q.+deleteQ :: Eq a => a -> Q a -> Q a+deleteQ x (Q xs ys) = Q (delete x xs) (delete x ys)++-- |'deleteQ' checks for membership in a Q.+elemQ :: Eq a => a -> Q a -> Bool+elemQ x (Q xs ys) = x `elem` xs || x `elem` ys++-- |'emptyQ' is an empty Q.+emptyQ :: Q a+emptyQ = Q [] []++-- |'nullQ' checks if the Q contains no items.+nullQ :: Q a -> Bool+nullQ (Q [] []) = True+nullQ _ = False++-- | Data type to represent a connection error.+-- The following are the codes from libcurl+-- which map to each of the constructors:+-- * 6 -> CouldNotResolveHost : The remote host was not resolved.+-- * 7 -> CouldNotConnectToServer : Failed to connect() to host or proxy.+-- * 28 -> OperationTimeout: the specified time-out period was reached.+data ConnectionError = CouldNotResolveHost+ | CouldNotConnectToServer+ | OperationTimeout+ deriving (Eq, Read, Show)
+ src/Darcs/Util/Encoding.hs view
@@ -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 Darcs.Util.Encoding+ ( encode,decode+ ) where++import Data.ByteString ( ByteString )++#ifdef WIN32+import qualified Darcs.Util.Encoding.Win32 as Backend ( encode, decode )+#else+import qualified Darcs.Util.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
+ src/Darcs/Util/Encoding/IConv.hsc view
@@ -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 Darcs.Util.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 <locale.h>+#include <langinfo.h>+#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 "darcs_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 "& darcs_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ())++foreign import ccall "darcs_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)+
+ src/Darcs/Util/Encoding/Win32.hs view
@@ -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 Darcs.Util.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+
+ src/Darcs/Util/English.hs view
@@ -0,0 +1,97 @@+-- Copyright (C) 2008 Eric Kow+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Copyright : 2008 Eric Kow+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable+--+-- This modules provides rudimentary natural language generation+-- (NLG) utilities. That is, generating natural language from a+-- machine representation. Initially, only English is supported at+-- all. Representations are implemented for:+--+-- * countable nouns (plurality); and+-- * lists of clauses (foo, bar and/or baz).++module Darcs.Util.English where++import Data.List (isSuffixOf, intercalate)++-- | > englishNum 0 (Noun "watch") "" == "watches"+-- > englishNum 1 (Noun "watch") "" == "watch"+-- > englishNum 2 (Noun "watch") "" == "watches"+englishNum :: Countable n => Int -> n -> ShowS+englishNum x = if x == 1 then singular else plural++-- | Things that have a plural and singular spelling+class Countable a where+ plural :: a -> ShowS+ singular :: a -> ShowS++-- | This only distinguishes between nouns with a final -ch,+-- and nouns which do not.+-- More irregular nouns will just need to have their own type+--+-- > plural (Noun "batch") "" == "batches"+-- > plural (Noun "bat") "" == "bats"+-- > plural (Noun "mouse") "" == "mouses" -- :-(+newtype Noun = Noun String+data Pronoun = It++instance Countable Noun where+ -- more irregular nouns will just need to have their own type+ plural (Noun s) | "ch" `isSuffixOf` s = showString s . showString "es"+ plural (Noun s) | "y" `isSuffixOf` s+ && length s > 1+ && last (init s) `notElem` "aeiou" =+ showString (init s) . showString "ies"+ plural (Noun s) = showString s . showChar 's'+ singular (Noun s) = showString s++instance Countable Pronoun where+ plural It = showString "them"+ singular It = showString "it"++-- | > singular This (Noun "batch") "" == "this batch"+-- > plural This (Noun "batch") "" == "these batches"+data This = This Noun++instance Countable This where+ plural (This s) = showString "these " . plural s+ singular (This s) = showString "this " . singular s++-- | Given a list of things, combine them thusly:+--+-- > orClauses ["foo", "bar", "baz"] == "foo, bar or baz"+andClauses, orClauses :: [String] -> String+andClauses = intersperseLast ", " " and "+orClauses = intersperseLast ", " " or "++-- | As 'intersperse', with a different separator for the last+-- | interspersal.+intersperseLast :: String -> String -> [String] -> String+intersperseLast _ _ [] = ""+intersperseLast _ _ [clause] = clause+intersperseLast sep sepLast clauses =+ intercalate sep (init clauses) ++ sepLast ++ last clauses++presentParticiple :: String -> String+presentParticiple v | last v == 'e' = init v ++ "ing"+ | otherwise = v ++ "ing"
+ src/Darcs/Util/Environment.hs view
@@ -0,0 +1,15 @@+module Darcs.Util.Environment+ (+ maybeGetEnv+ ) where+++import Prelude hiding ( catch )++import System.Environment ( getEnv )++import Darcs.Util.Exception ( catchall )++maybeGetEnv :: String+ -> IO (Maybe String)+maybeGetEnv s = fmap Just (getEnv s) `catchall` return Nothing -- err can only be isDoesNotExist
+ src/Darcs/Util/Exception.hs view
@@ -0,0 +1,64 @@+{-# Language MultiParamTypeClasses, DeriveDataTypeable #-}+module Darcs.Util.Exception+ ( firstJustIO+ , catchall+ , clarifyErrors+ , prettyException+ , prettyError+ ) where+++import Prelude hiding ( catch )++import Control.Exception ( SomeException, Exception(fromException), catch )+import Data.Maybe ( isJust )++import System.IO.Error ( isUserError, ioeGetErrorString+ , isDoesNotExistError, ioeGetFileName )++import Darcs.Util.SignalHandler ( catchNonSignal )++catchall :: IO a+ -> IO a+ -> IO a+a `catchall` b = a `catchNonSignal` (\_ -> b)++-- | The firstJustM returns the first Just entry in a list of monadic+-- operations. This is close to `listToMaybe `fmap` sequence`, but the sequence+-- operator evaluates all monadic members of the list before passing it along+-- (i.e. sequence is strict). The firstJustM is lazy in that list member monads+-- are only evaluated up to the point where the first Just entry is obtained.+firstJustM :: Monad m+ => [m (Maybe a)]+ -> m (Maybe a)+firstJustM [] = return Nothing+firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es)+++-- | The firstJustIO is a slight modification to firstJustM: the entries in the+-- list must be IO monad operations and the firstJustIO will silently turn any+-- monad call that throws an exception into Nothing, basically causing it to be+-- ignored.+firstJustIO :: [IO (Maybe a)]+ -> IO (Maybe a)+firstJustIO = firstJustM . map (`catchall` return Nothing)+++clarifyErrors :: IO a+ -> String+ -> IO a+clarifyErrors a e = a `catch` (\x -> fail $ unlines [prettyException x,e])++prettyException :: SomeException+ -> String+prettyException e | Just ioe <- fromException e, isUserError ioe = ioeGetErrorString ioe+prettyException e | Just ioe <- fromException e, isDoesNotExistError ioe =+ case ioeGetFileName ioe of+ Just f -> f ++ " does not exist"+ Nothing -> show e+prettyException e = show e+++prettyError :: IOError -> String+prettyError e | isUserError e = ioeGetErrorString e+ | otherwise = show e
+ src/Darcs/Util/Exec.hs view
@@ -0,0 +1,251 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, DeriveDataTypeable #-}++-- |+-- Module : Darcs.Util.Exec+-- Copyright : 2003 David Roundy+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++module Darcs.Util.Exec+ (+ exec+ , execInteractive+ , readInteractiveProcess+ , renderExecException+ , withoutNonBlock+ , Redirects+ , Redirect(..)+ , ExecException(..)+ ) where++#ifndef WIN32+import Control.Exception ( bracket )+import System.Posix.Env ( setEnv, getEnv, unsetEnv )+import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput )+#else+import Control.Exception ( catchJust, IOException )+import Data.List ( isInfixOf )+#endif++import GHC.IO.Handle ( hDuplicate )++import Control.Concurrent ( forkIO )+import Control.Concurrent.MVar ( newEmptyMVar, takeMVar, putMVar )+import Control.Exception+ ( evaluate, bracketOnError, Exception(..), SomeException(..) )+import Data.Typeable ( Typeable, cast )+import System.Process ( system )+import qualified System.Process as P+import System.Exit ( ExitCode (..) )+import System.IO ( IOMode(..), openBinaryFile, stdin, stdout, hGetContents, hClose )+import System.Process ( runProcess, terminateProcess, waitForProcess )++import Darcs.Util.Global ( whenDebugMode )+import Darcs.Util.Progress ( withoutProgress )++{-+ A redirection is a three-tuple of values (in, out, err).+ The most common values are:++ AsIs don't change it+ Null /dev/null on Unix, NUL on Windows+ File open a file for reading or writing++ There is also the value Stdout, which is only meaningful for+ redirection of errors, and is performed AFTER stdout is+ redirected so that output and errors mix together. StdIn and+ StdErr could be added as well if they are useful.++ NOTE: Lots of care must be taken when redirecting stdin, stdout+ and stderr to one of EACH OTHER, since the ORDER in which they+ are changed have a significant effect on the result.+-}++type Redirects = (Redirect, Redirect, Redirect)++data Redirect = AsIs+ | Null+ | File FilePath+ | Stdout+ deriving Show++{-+ ExecException is thrown by exec if any system call fails,+ for example because the executable we're trying to run+ doesn't exist.+-}+-- ExecException cmd args redirecs errorDesc+data ExecException = ExecException+ String -- cmd+ [String] -- args+ Redirects -- redirects+ String -- errorDesc+ deriving (Typeable)++instance Exception ExecException where+ toException = SomeException+ fromException (SomeException e) = cast e++renderExecException :: ExecException -> String+renderExecException (ExecException cmd args _ msg) =+ concat [+ "The program \"", unwords (cmd:args),+ "\" failed with error: \"",msg,"\"."]++instance Show ExecException where+ show = renderExecException++_devNull :: FilePath+#ifdef WIN32+_devNull = "NUL"+#else+_devNull = "/dev/null"+#endif++{-+ We use System.Process, which does the necessary quoting+ and redirection for us behind the scenes.+-}+exec :: String -> [String] -> Redirects -> IO ExitCode+exec cmd args (inp,out,err) = withoutProgress $ do+ h_stdin <- redirect inp ReadMode+ h_stdout <- redirect out WriteMode+ h_stderr <- redirect err WriteMode+ withExit127 $ bracketOnError+ (do doOptionalDebug+ runProcess cmd args Nothing Nothing h_stdin h_stdout h_stderr)+ terminateProcess+ waitForProcess+ where+ doOptionalDebug = whenDebugMode . putStrLn . unwords $+ cmd : args ++ ["; #"] ++ map show [inp, out, err]+ redirect AsIs _ = return Nothing+ redirect Null mode = Just `fmap` openBinaryFile _devNull mode+ redirect (File "/dev/null") mode = redirect Null mode+ redirect (File f) mode = Just `fmap` openBinaryFile f mode+ -- hDuplicate stdout rather than passing stdout itself,+ -- because runProcess closes the Handles we pass it.+ redirect Stdout _ = Just `fmap` hDuplicate stdout++execInteractive :: String -> String -> IO ExitCode+#ifndef WIN32+{-+This should handle arbitrary commands interpreted by the shell on Unix since+that's what people expect. But we don't want to allow the shell to interpret+the argument in any way, so we set an environment variable and call+cmd "$DARCS_ARGUMENT"+-}+execInteractive cmd arg = withoutProgress $ do+ let var = "DARCS_ARGUMENT"+ stdin `seq` return ()+ withoutNonBlock $ bracket+ (do oldval <- getEnv var+ setEnv var arg True+ return oldval)+ (\oldval ->+ case oldval of+ Nothing -> unsetEnv var+ Just val -> setEnv var val True)+ (\_ -> withExit127 $ system $ cmd++" \"$"++var++"\"")++#else+-- The `system' function passes commands to execute via cmd.exe (or+-- command.com) it's return value is equivalent to the one returned by the+-- shell. For regular applications - this works correctly resulting in the+-- exit code of the program. However in case of a command/file which can't be+-- found - cmd.exe will return 1 instead of propagating the ExitFailure 9009+-- which on windows is equivalent to ExitFailure 127 from *nix machines.+--+-- Here we force return the exit code of the last cmd.exe action by appending+-- & exit !errorlevel! to the command being executed that way chaining with+-- ortryrunning works correctly.+--+-- SETLOCAL EnableDelayedExpansion makes sure that !variable! expansion is done+-- correctly on systems where that function is not enabled by default.+--+execInteractive cmd arg = withoutProgress $+ withExit127 $ system $ "SETLOCAL EnableDelayedExpansion & " +++ cmd ++ " " ++ arg +++ " & exit !errorlevel!"+#endif++withoutNonBlock :: IO a -> IO a+#ifndef WIN32+{-+Do IO without NonBlockingRead on stdInput.++This is needed when running unsuspecting external commands with interactive+mode - if read from terminal is non-blocking also write to terminal is+non-blocking.+-}+withoutNonBlock x =+ do nb <- queryFdOption stdInput NonBlockingRead+ if nb+ then bracket+ (setFdOption stdInput NonBlockingRead False)+ (\_ -> setFdOption stdInput NonBlockingRead True)+ (\_ -> x)+ else x+#else+withoutNonBlock x = x+#endif++readInteractiveProcess+ :: FilePath -- ^ command to run+ -> [String] -- ^ any arguments+ -> IO (ExitCode,String) -- ^ exitcode, stderr+readInteractiveProcess cmd args = do+ inh' <- hDuplicate stdin+ outh <- hDuplicate stdout+ (_, _, Just errh, pid) <-+ P.createProcess (P.proc cmd args){+ P.std_in = P.UseHandle inh',+ P.std_out = P.UseHandle outh,+ P.std_err = P.CreatePipe }+ errMVar <- newEmptyMVar++ errors <- hGetContents errh+ _ <- forkIO $ do+ _ <- evaluate (length errors)+ putMVar errMVar errors++ err <- takeMVar errMVar+ hClose errh++ ex <- waitForProcess pid++ return (ex, err)+ +{-+Ensure that we exit 127 if the thing we are trying to run does not exist+(Only needed under Windows)+-}+withExit127 :: IO ExitCode -> IO ExitCode+#ifdef WIN32+withExit127 a = catchJust notFoundError a (const $ return $ ExitFailure 127)++notFoundError :: IOException -> Maybe ()+notFoundError e | "runProcess: does not exist" `isInfixOf` show e = Just ()+notFoundError _ = Nothing+#else+withExit127 = id+#endif
+ src/Darcs/Util/File.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE CPP #-}+module Darcs.Util.File+ (+ -- * Files and directories+ getFileStatus+ , withCurrentDirectory+ , doesDirectoryReallyExist+ , removeFileMayNotExist+ -- * OS-dependent special directories+ , xdgCacheDir+ , osxCacheDir+ , getDirectoryContents+ , getRecursiveContents+ , getRecursiveContentsFullPath+ ) where++import Prelude hiding ( catch )++import Control.Exception ( catch, bracket )+import Control.Monad ( when, unless, forM )++import System.Environment ( getEnvironment )+import System.Directory ( removeFile, getHomeDirectory,+ getAppUserDataDirectory, doesDirectoryExist,+ createDirectory, getDirectoryContents )+import System.IO.Error ( isDoesNotExistError )+import System.Posix.Files( getSymbolicLinkStatus, FileStatus, isDirectory+#ifndef WIN32+ , setFileMode, ownerModes+#endif+ )+import System.FilePath.Posix ( (</>) )++import Darcs.Util.Exception ( catchall )+import Darcs.Util.Path( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )++withCurrentDirectory :: FilePathLike p+ => p+ -> IO a+ -> IO a+withCurrentDirectory name m =+ bracket+ (do cwd <- getCurrentDirectory+ when (toFilePath name /= "") (setCurrentDirectory name)+ return cwd)+ (\oldwd -> setCurrentDirectory oldwd `catchall` return ())+ (const m)++getFileStatus :: FilePath+ -> IO (Maybe FileStatus)+getFileStatus f =+ Just `fmap` getSymbolicLinkStatus f `catchall` return Nothing++doesDirectoryReallyExist :: FilePath -> IO Bool+doesDirectoryReallyExist f =+ catchNonExistence (isDirectory `fmap` getSymbolicLinkStatus f) False++removeFileMayNotExist :: FilePathLike p => p -> IO ()+removeFileMayNotExist f = catchNonExistence (removeFile $ toFilePath f) ()++catchNonExistence :: IO a -> a -> IO a+catchNonExistence job nonexistval =+ catch job $+ \e -> if isDoesNotExistError e then return nonexistval+ else ioError e++-- |osxCacheDir assumes @~/Library/Caches/@ exists.+osxCacheDir :: IO (Maybe FilePath)+osxCacheDir = do+ home <- getHomeDirectory+ return $ Just $ home </> "Library" </> "Caches"+ `catchall` return Nothing++-- |xdgCacheDir returns the $XDG_CACHE_HOME environment variable,+-- or @~/.cache@ if undefined. See the FreeDesktop specification:+-- http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html+xdgCacheDir :: IO (Maybe FilePath)+xdgCacheDir = do+ env <- getEnvironment+ d <- case lookup "XDG_CACHE_HOME" env of+ Just d -> return d+ Nothing -> getAppUserDataDirectory "cache"+ exists <- doesDirectoryExist d++ -- If directory does not exist, create it with permissions 0700+ -- as specified by the FreeDesktop standard.+ unless exists $ do createDirectory d+#ifndef WIN32+ -- see http://bugs.darcs.net/issue2334+ setFileMode d ownerModes+#endif+ return $ Just d+ `catchall` return Nothing++-- |getRecursiveContents returns all files under topdir that aren't+-- directories.+getRecursiveContents :: FilePath -> IO [FilePath]+getRecursiveContents topdir = do+ names <- getDirectoryContents topdir+ let properNames = filter (`notElem` [".", ".."]) names+ paths <- forM properNames $ \name -> do+ let path = topdir </> name+ isDir <- doesDirectoryExist path+ if isDir+ then getRecursiveContents path+ else return [name]+ return (concat paths)++-- |getRecursiveContentsFullPath returns all files under topdir+-- that aren't directories.+-- Unlike getRecursiveContents this function returns the full path.+getRecursiveContentsFullPath :: FilePath -> IO [FilePath]+getRecursiveContentsFullPath topdir = do+ names <- getDirectoryContents topdir+ let properNames = filter (`notElem` [".", ".."]) names+ paths <- forM properNames $ \name -> do+ let path = topdir </> name+ isDir <- doesDirectoryExist path+ if isDir+ then getRecursiveContentsFullPath path+ else return [path]+ return (concat paths)
+ src/Darcs/Util/Global.hs view
@@ -0,0 +1,184 @@+-- Copyright (C) 2005 Tomasz Zielonka+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++-- |+-- Module : Darcs.Util.Global+-- Copyright : 2005 Tomasz Zielonka+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable+--+-- This was originally Tomasz Zielonka's AtExit module, slightly generalised+-- to include global variables. Here, we attempt to cover broad, global+-- features, such as exit handlers. These features slightly break the Haskellian+-- purity of darcs, in favour of programming convenience.++module Darcs.Util.Global+ (+ timingsMode+ , setTimingsMode+ , whenDebugMode+ , withDebugMode+ , setDebugMode+ , debugMessage+ , debugFail+ , putTiming+ , addCRCWarning+ , getCRCWarnings+ , resetCRCWarnings+ , addBadSource+ , getBadSourcesList+ , isBadSource+ , darcsdir+ , darcsLastMessage+ , darcsSendMessage+ , darcsSendMessageFinal+ , isReachableSource+ , addReachableSource+ ) where+++import Control.Monad ( when )+import Data.IORef ( modifyIORef, IORef, newIORef, readIORef, writeIORef )+import System.IO.Unsafe (unsafePerformIO)+import System.IO ( hPutStrLn, hPutStr, stderr )+import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )+import System.FilePath.Posix ( combine, (<.>) )+import Prelude hiding (catch)+++-- Write-once-read-many global variables make it easier to implement flags, such+-- as --no-ssh-cm. Using global variables reduces the number of parameters that+-- we have to pass around, but it is rather unsafe and should be used sparingly.+++_debugMode :: IORef Bool+_debugMode = unsafePerformIO $ newIORef False+{-# NOINLINE _debugMode #-}+++setDebugMode :: IO ()+setDebugMode = writeIORef _debugMode True+++whenDebugMode :: IO () -> IO ()+whenDebugMode j = do b <- readIORef _debugMode+ when b j+++withDebugMode :: (Bool -> IO a) -> IO a+withDebugMode j = readIORef _debugMode >>= j+++debugMessage :: String -> IO ()+debugMessage m = whenDebugMode $ do putTiming; hPutStrLn stderr m+++debugFail :: String -> IO a+debugFail m = debugMessage m >> fail m+++putTiming :: IO ()+putTiming = when timingsMode $ do+ t <- getClockTime >>= toCalendarTime+ hPutStr stderr (calendarTimeToString t++": ")+++_timingsMode :: IORef Bool+_timingsMode = unsafePerformIO $ newIORef False+{-# NOINLINE _timingsMode #-}+++setTimingsMode :: IO ()+setTimingsMode = writeIORef _timingsMode True+++timingsMode :: Bool+timingsMode = unsafePerformIO $ readIORef _timingsMode+{-# NOINLINE timingsMode #-}+++type CRCWarningList = [FilePath]+_crcWarningList :: IORef CRCWarningList+_crcWarningList = unsafePerformIO $ newIORef []+{-# NOINLINE _crcWarningList #-}+++addCRCWarning :: FilePath -> IO ()+addCRCWarning fp = modifyIORef _crcWarningList (fp:)+++getCRCWarnings :: IO [FilePath]+getCRCWarnings = readIORef _crcWarningList+++resetCRCWarnings :: IO ()+resetCRCWarnings = writeIORef _crcWarningList []+++_badSourcesList :: IORef [String]+_badSourcesList = unsafePerformIO $ newIORef []+{-# NOINLINE _badSourcesList #-}+++addBadSource :: String -> IO ()+addBadSource cache = modifyIORef _badSourcesList (cache:)+++getBadSourcesList :: IO [String]+getBadSourcesList = readIORef _badSourcesList+++isBadSource :: IO (String -> Bool)+isBadSource = do+ badSources <- getBadSourcesList+ return (`elem` badSources)+++_reachableSourcesList :: IORef [String]+_reachableSourcesList = unsafePerformIO $ newIORef []+{-# NOINLINE _reachableSourcesList #-}+++addReachableSource :: String -> IO ()+addReachableSource src = modifyIORef _reachableSourcesList (src:)+++getReachableSources :: IO [String]+getReachableSources = readIORef _reachableSourcesList+++isReachableSource :: IO (String -> Bool)+isReachableSource = do+ reachableSources <- getReachableSources+ return (`elem` reachableSources)+++darcsdir :: String+darcsdir = "_darcs"++darcsLastMessage :: String+darcsLastMessage = combine darcsdir "patch_description.txt"++darcsSendMessage :: String +darcsSendMessage = combine darcsdir "darcs-send"++darcsSendMessageFinal :: String+darcsSendMessageFinal = darcsSendMessage <.> "final"
+ src/Darcs/Util/IsoDate.hs view
@@ -0,0 +1,880 @@+-- Copyright (C) 2003 Peter Simons+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Module : Darcs.Util.IsoDate+-- Copyright : 2003 Peter Simons+-- 2003 David Roundy+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++module Darcs.Util.IsoDate+ ( getIsoDateTime, readUTCDate+ , parseDate, getLocalTz+ , englishDateTime, englishInterval, englishLast+ , iso8601Interval, iso8601Duration+ , cleanLocalDate, resetCalendar+ , MCalendarTime(..), subtractFromMCal, addToMCal+ , toMCalendarTime, unsafeToCalendarTime+ , unsetTime, TimeInterval+ ) where++import Text.ParserCombinators.Parsec+import System.Time+import System.IO.Unsafe ( unsafePerformIO )+import Data.Char ( toUpper, isDigit )+import Data.Maybe ( fromMaybe )+import Control.Monad ( liftM, liftM2 )+import qualified Data.ByteString.Char8 as B++type TimeInterval = (Maybe CalendarTime, Maybe CalendarTime)++-- | Read/interpret a date string, assuming UTC if timezone+-- is not specified in the string (see 'readDate')+-- Warning! This errors out if we fail to interpret the+-- date+readUTCDate :: String -> CalendarTime+readUTCDate = readDate 0++-- | Convert a date string into ISO 8601 format (yyyymmdd variant)+-- assuming local timezone if not specified in the string+-- Warning! This errors out if we fail to interpret the date+cleanLocalDate :: String -> IO String+cleanLocalDate str =+ do tz <- getLocalTz+ return . showIsoDateTime . resetCalendar . readDate tz $ str++-- | Return the local timezone offset from UTC in seconds+getLocalTz :: IO Int+getLocalTz = ctTZ `liftM` (getClockTime >>= toCalendarTime)++-- | Parse a date string with 'parseDate'+-- Warning! This errors out if we fail to interpret the date+-- Uses its first argument as the default time zone.+readDate :: Int -> String -> CalendarTime+readDate tz d =+ case parseDate tz d of+ Left e -> error $ "bad date: "++d++" - "++show e+ Right ct -> resetCalendar $ unsafeToCalendarTime ct++-- | Parse a date string, assuming a default timezone if+-- the date string does not specify one. The date formats+-- understood are those of 'showIsoDateTime' and 'dateTime'+parseDate :: Int -> String -> Either ParseError MCalendarTime+parseDate tz d =+ if length d >= 14 && B.all isDigit bd+ then Right $ toMCalendarTime $+ CalendarTime (readI $ B.take 4 bd)+ (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd)+ (readI $ B.take 2 $ B.drop 6 bd) -- Day+ (readI $ B.take 2 $ B.drop 8 bd) -- Hour+ (readI $ B.take 2 $ B.drop 10 bd) -- Minute+ (readI $ B.take 2 $ B.drop 12 bd) -- Second+ 0 Sunday 0 -- Picosecond, weekday and day of year unknown+ "GMT" 0 False+ else let dt = do { x <- dateTime tz; eof; return x }+ in parse dt "" d+ where bd = B.pack (take 14 d)+ readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s)++-- | Display a 'CalendarTime' in the ISO 8601 format without any+-- separators, e.g. 20080825142503+showIsoDateTime :: CalendarTime -> String+showIsoDateTime ct = concat [ show $ ctYear ct+ , twoDigit . show . (+1) . fromEnum $ ctMonth ct+ , twoDigit . show $ ctDay ct+ , twoDigit . show $ ctHour ct+ , twoDigit . show $ ctMin ct+ , twoDigit . show $ ctSec ct+ ]+ where twoDigit [] = undefined+ twoDigit x@(_:[]) = '0' : x+ twoDigit x@(_:_:[]) = x+ twoDigit _ = undefined++-- | The current time in the format returned by 'showIsoDateTime'+getIsoDateTime :: IO String+getIsoDateTime = (showIsoDateTime . toUTCTime) `liftM` getClockTime++----- Parser Combinators ---------------------------------------------++-- | Case-insensitive variant of Parsec's 'char' function.+caseChar :: Char -> GenParser Char a Char+caseChar c = satisfy (\x -> toUpper x == toUpper c)++-- | Case-insensitive variant of Parsec's 'string' function.+caseString :: String -> GenParser Char a ()+caseString cs = mapM_ caseChar cs <?> cs++-- [x,y] => x <|> y+caseStrings :: [String] -> GenParser Char a ()+caseStrings xs = foldl1 (<|>) $ map caseString xs++-- | Match a parser at least @n@ times.+manyN :: Int -> GenParser a b c -> GenParser a b [c]+manyN n p+ | n <= 0 = return []+ | otherwise = liftM2 (++) (count n p) (many p)++-- | Match a parser at least @n@ times, but no more than @m@ times.+manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c]+manyNtoM n m p+ | n < 0 = return []+ | n > m = return []+ | n == m = count n p+ | n == 0 = foldr ((<|>) . (\x -> try $ count x p)) (return []) (reverse [1..m])+ | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)+++----- Date/Time Parser -----------------------------------------------++-- | Try each of these date parsers in the following order+--+-- (1) 'cvsDateTime'+--+-- (2) 'iso8601DateTime'+--+-- (3) 'oldDateTime'+--+-- (4) 'rfc2822DateTime'+dateTime :: Int -> CharParser a MCalendarTime+dateTime tz =+ choice [try $ toMCalendarTime `fmap` cvsDateTime tz,+ try $ iso8601DateTime tz,+ try $ toMCalendarTime `fmap` oldDateTime,+ toMCalendarTime `fmap` rfc2822DateTime]++parseDHMS :: CharParser a (Int, Int, Int, Int)+parseDHMS = do+ d <- day+ _ <- mySpaces+ (h, m, s) <- parseHMS+ return (d, h, m, s)++parseHMS :: CharParser a (Int, Int, Int)+parseHMS = do+ h <- hour+ _ <- char ':'+ m <- minute+ _ <- char ':'+ s <- second+ return (h, m, s)++parseSpacesMonthName :: CharParser a Month+parseSpacesMonthName = do+ _ <- mySpaces+ mon <- monthName+ _ <- mySpaces+ return mon++-- | CVS-style date/times, e.g.+-- 2007/08/25 14:25:39 GMT+-- Note that time-zones are optional here.+cvsDateTime :: Int -> CharParser a CalendarTime+cvsDateTime tz =+ do y <- year+ _ <- char '/'+ mon <- monthNum+ _ <- char '/'+ (d, h, m, s) <- parseDHMS+ z <- option tz $ mySpaces >> zone+ return (CalendarTime y mon d h m s 0 Monday 0 "" z False)++-- | \"Old\"-style dates, e.g.+-- Tue Jan 3 14:08:07 EST 1999+-- darcs-doc: Question (what does the "old" stand for really?)+oldDateTime :: CharParser a CalendarTime+oldDateTime = do wd <- dayName+ mon <- parseSpacesMonthName+ (d, h, m , s) <- parseDHMS+ _ <- mySpaces+ z <- zone+ _ <- mySpaces+ y <- year+ return (CalendarTime y mon d h m s 0 wd 0 "" z False)++rfc2822DateTime :: CharParser a CalendarTime+rfc2822DateTime = do wd <- dayName+ _ <- char ','+ _ <- mySpaces+ d <- day+ mon <- parseSpacesMonthName+ y <- year+ _ <- mySpaces+ (h, m, s) <- parseHMS+ _ <- mySpaces+ z <- zone+ return (CalendarTime y mon d h m s 0 wd 0 "" z False)++-- | ISO 8601 dates and times. Please note the following flaws:+--+-- I am reluctant to implement:+--+-- * years > 9999+--+-- * truncated representations with implied century (89 for 1989)+--+-- I have not implemented:+--+-- * repeated durations (not relevant)+--+-- * lowest order component fractions in intervals+--+-- * negative dates (BC)+--+-- I have not verified or have left too relaxed:+--+-- * the difference between 24h and 0h+--+-- * allows stuff like 2005-1212; either you use the hyphen all the way+-- (2005-12-12) or you don't use it at all (20051212), but you don't use+-- it halfway, likewise with time+--+-- * No bounds checking whatsoever on intervals!+-- (next action: read iso doc to see if bounds-checking required?) -}+iso8601DateTime :: Int -> CharParser a MCalendarTime+iso8601DateTime localTz = try $+ do d <- iso8601Date+ t <- option id $ try $ do optional $ oneOf " T"+ iso8601Time+ return $ t $ d { mctTZ = Just localTz }++-- | Three types of ISO 8601 date:+--+-- * calendar date, e.g., 1997-07-17, 1997-07, 199707, 1997+--+-- * week+day in year, e.g., 1997-W32-4+--+-- * day in year, e.g, 1997-273+iso8601Date :: CharParser a MCalendarTime+iso8601Date =+ do d <- calendar_date <|> week_date <|> ordinal_date+ return $ foldr ($) nullMCalendar d+ where+ calendar_date = -- yyyy-mm-dd+ try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]+ -- allow other variants to be parsed correctly+ notFollowedBy (digit <|> char 'W')+ return d+ week_date = --yyyy-Www-d+ try $ do yfn <- year_+ optional dash+ _ <- char 'W'+ -- offset human 'week 1' -> computer 'week 0'+ w' <- (\x -> x-1) `liftM` twoDigits+ mwd <- option Nothing $ do { optional dash; Just `fmap` nDigits 1 }+ let y = resetCalendar . unsafeToCalendarTime . yfn $ nullMCalendar { mctDay = Just 1 }+ firstDay = ctWDay y+ -- things that make this complicated+ -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday+ -- 2. the first week is the one that contains at least Thursday+ -- if the year starts after Thursday, then some days of the year+ -- will have already passed before the first week+ let afterThursday = firstDay == Sunday || firstDay > Thursday+ w = if afterThursday then w'+1 else w'+ yday = (7 * w) + fromMaybe 1 mwd+ diff c = c { mctWeek = True+ , mctWDay = toEnum `fmap` mwd+ , mctDay = Just yday }+ return [diff.yfn]+ ordinal_date = -- yyyy-ddd+ try $ optchain year_ [ (dash, yearDay_) ]+ --+ year_ = try $ do y <- fourDigits <?> "year (0000-9999)"+ return $ \c -> c { mctYear = Just y }+ month_ = try $ do m <- twoDigits <?> "month (1 to 12)"+ return $ \c -> c { mctMonth = Just $ intToMonth m }+ day_ = try $ do d <- twoDigits <?> "day in month (1 to 31)"+ return $ \c -> c { mctDay = Just d }+ yearDay_ = try $ do d <- nDigits 3 <?> "day in year (001 to 366)"+ return $ \c -> c { mctDay = Just d+ , mctYDay = Just (d - 1) }+ dash = char '-'++-- | Note that this returns a function which sets the time on+-- another calendar (see 'iso8601DateTime' for a list of+-- flaws+iso8601Time :: CharParser a (MCalendarTime -> MCalendarTime)+iso8601Time = try $+ do ts <- optchain hour_ [ (colon , min_)+ , (colon , sec_)+ , (oneOf ",.", pico_) ]+ z <- option id $ choice [ zulu , offset ]+ return $ foldr (.) id (z:ts)+ where+ hour_ = do h <- twoDigits+ return $ \c -> c { mctHour = Just h }+ min_ = do m <- twoDigits+ return $ \c -> c { mctMin = Just m }+ sec_ = do s <- twoDigits+ return $ \c -> c { mctSec = Just s }+ pico_ = do digs <- many digit+ let picoExp = 12+ digsExp = length digs+ let frac | null digs = 0+ | digsExp > picoExp = read $ take picoExp digs+ | otherwise = 10 ^ (picoExp - digsExp) * read digs+ return $ \c -> c { mctPicosec = Just frac }+ zulu = do { _ <- char 'Z'; return (\c -> c { mctTZ = Just 0 }) }+ offset = do sign <- choice [ char '+' >> return 1+ , char '-' >> return (-1) ]+ h <- twoDigits+ m <- option 0 $ do { optional colon; twoDigits }+ return $ \c -> c { mctTZ = Just $ sign * 60 * ((h*60)+m) }+ colon = char ':'++-- | Intervals in ISO 8601, e.g.,+--+-- * 2008-09/2012-08-17T16:30+--+-- * 2008-09/P2Y11MT16H30M+--+-- * P2Y11MT16H30M/2012-08-17T16:30+--+-- See 'iso8601Duration'+iso8601Interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime))+iso8601Interval localTz = leftDur <|> rightDur where+ leftDur =+ do dur <- iso8601Duration+ end <- option Nothing $ do { _ <- char '/'; Just `liftM` isoDt }+ return $ case end of+ Nothing -> Left dur+ Just e -> Right (dur `subtractFromMCal` e, e)+ rightDur =+ do start <- isoDt+ _ <- char '/'+ durOrEnd <- Left `liftM` iso8601Duration <|> Right `liftM` isoDt+ return $ case durOrEnd of+ Left dur -> Right (start, dur `addToMCal` start)+ Right end -> Right (start, end)+ isoDt = iso8601DateTime localTz++-- | Durations in ISO 8601, e.g.,+--+-- * P4Y (four years)+--+-- * P5M (five months)+--+-- * P4Y5M (four years and five months)+--+-- * P4YT3H6S (four years, three hours and six seconds)+iso8601Duration :: CharParser a TimeDiff+iso8601Duration =+ do _ <- char 'P'+ y <- block 0 'Y'+ mon <- block 0 'M'+ d <- block 0 'D'+ (h,m,s) <- option (0,0,0) $+ do _ <- char 'T'+ h' <- block (-1) 'H'+ m' <- block (-1) 'M'+ s' <- block (-1) 'S'+ let unset = (== (-1))+ if all unset [h',m',s']+ then fail "T should be omitted if time is unspecified"+ else let clear x = if unset x then 0 else x+ in return (clear h', clear m', clear s')+ --+ return $ TimeDiff y mon d h m s 0+ where block d c = option d $ try $+ do n <- many1 digit+ _ <- char c+ return $ read n++-- | 'optchain' @p xs@ parses a string with the obligatory+-- parser @p@. If this suceeds, it continues on to the+-- rest of the input using the next parsers down the+-- chain. Each part of the chain consists of a parser+-- for a separator and for the content itself. The+-- separator is optional.+--+-- A good use of this function is to help in parsing ISO+-- ISO 8601 dates and times. For example, the parser+-- @optchain year [(dash, month), (dash, day)]@ accepts+-- dates like 2007 (only the year is used), 2007-07 (only+-- the year and month), 200707 (only the year and month+-- with no separator), 2007-07-19 (year, month and day).+optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]+optchain p next = try $+ do r1 <- p+ r2 <- case next of+ [] -> return []+ ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }+ return (r1:r2)++nDigits :: Int -> CharParser a Int+nDigits n = read `liftM` count n digit++twoDigits, fourDigits :: CharParser a Int+twoDigits = nDigits 2+fourDigits = nDigits 4++-- | One or more space.+-- WARNING! This only matches on the space character, not on+-- whitespace in general+mySpaces :: CharParser a String+mySpaces = manyN 1 $ char ' '++-- | English three-letter day abbreviations (e.g. Mon, Tue, Wed)+dayName :: CharParser a Day+dayName = choice+ [ caseString "Mon" >> return Monday+ , try (caseString "Tue") >> return Tuesday+ , caseString "Wed" >> return Wednesday+ , caseString "Thu" >> return Thursday+ , caseString "Fri" >> return Friday+ , try (caseString "Sat") >> return Saturday+ , caseString "Sun" >> return Sunday+ ]++-- | Four-digit year+year :: CharParser a Int+year = fourDigits++-- | One or two digit month (e.g. 3 for March, 11 for November)+monthNum :: CharParser a Month+monthNum = do mn <- manyNtoM 1 2 digit+ return $ intToMonth (read mn :: Int)++-- | January is 1, February is 2, etc+intToMonth :: Int -> Month+intToMonth 1 = January+intToMonth 2 = February+intToMonth 3 = March+intToMonth 4 = April+intToMonth 5 = May+intToMonth 6 = June+intToMonth 7 = July+intToMonth 8 = August+intToMonth 9 = September+intToMonth 10 = October+intToMonth 11 = November+intToMonth 12 = December+intToMonth _ = error "invalid month!"++-- | English three-letter month abbreviations (e.g. Jan, Feb, Mar)+monthName :: CharParser a Month+monthName = choice+ [ try (caseString "Jan") >> return January+ , caseString "Feb" >> return February+ , try (caseString "Mar") >> return March+ , try (caseString "Apr") >> return April+ , caseString "May" >> return May+ , try (caseString "Jun") >> return June+ , caseString "Jul" >> return July+ , caseString "Aug" >> return August+ , caseString "Sep" >> return September+ , caseString "Oct" >> return October+ , caseString "Nov" >> return November+ , caseString "Dec" >> return December+ ]++-- | day in one or two digit notation+day :: CharParser a Int+day = do d <- manyNtoM 1 2 digit+ return (read d :: Int)++-- | hour in two-digit notation+hour :: CharParser a Int+hour = twoDigits++-- | minute in two-digit notation+minute :: CharParser a Int+minute = twoDigits++-- | second in two-digit notation+second :: CharParser a Int+second = twoDigits++-- | limited timezone support+--+-- * +HHMM or -HHMM+--+-- * Universal timezones: UTC, UT+--+-- * Zones from GNU coreutils/lib/getdate.y, less half-hour ones --+-- sorry Newfies.+--+-- * any sequence of alphabetic characters (WARNING! treated as 0!)+zone :: CharParser a Int+zone = choice+ [ do { _ <- char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }+ , do { _ <- char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }+ , mkZone "UTC" 0+ , mkZone "UT" 0+ , mkZone "GMT" 0+ , mkZone "WET" 0+ , mkZone "WEST" 1+ , mkZone "BST" 1+ , mkZone "ART" (-3)+ , mkZone "BRT" (-3)+ , mkZone "BRST" (-2)+ , mkZone "AST" (-4)+ , mkZone "ADT" (-3)+ , mkZone "CLT" (-4)+ , mkZone "CLST" (-3)+ , mkZone "EST" (-5)+ , mkZone "EDT" (-4)+ , mkZone "CST" (-6)+ , mkZone "CDT" (-5)+ , mkZone "MST" (-7)+ , mkZone "MDT" (-6)+ , mkZone "PST" (-8)+ , mkZone "PDT" (-7)+ , mkZone "AKST" (-9)+ , mkZone "AKDT" (-8)+ , mkZone "HST" (-10)+ , mkZone "HAST" (-10)+ , mkZone "HADT" (-9)+ , mkZone "SST" (-12)+ , mkZone "WAT" 1+ , mkZone "CET" 1+ , mkZone "CEST" 2+ , mkZone "MET" 1+ , mkZone "MEZ" 1+ , mkZone "MEST" 2+ , mkZone "MESZ" 2+ , mkZone "EET" 2+ , mkZone "EEST" 3+ , mkZone "CAT" 2+ , mkZone "SAST" 2+ , mkZone "EAT" 3+ , mkZone "MSK" 3+ , mkZone "MSD" 4+ , mkZone "SGT" 8+ , mkZone "KST" 9+ , mkZone "JST" 9+ , mkZone "GST" 10+ , mkZone "NZST" 12+ , mkZone "NZDT" 13+ -- if we don't understand it, just give a GMT answer...+ , do { _ <- manyTill (oneOf $ ' ' : ['a'..'z']++['A'..'Z'])+ (lookAhead space_digit);+ return 0 }+ ]+ where mkZone n o = try $ do { caseString n; return (o*60*60) }+ space_digit = try $ do { _ <- char ' '; oneOf ['0'..'9'] }++----- English dates and intervals -----------------------------------------------++-- | In English, either a date followed by a time, or vice-versa, e.g,+--+-- * yesterday at noon+--+-- * yesterday tea time+--+-- * 12:00 yesterday+--+-- See 'englishDate' and 'englishTime'+-- Uses its first argument as "now", i.e. the time relative to which+-- "yesterday", "today" etc are to be interpreted+englishDateTime :: CalendarTime -> CharParser a CalendarTime+englishDateTime now =+ try $ dateMaybeAtTime <|> timeThenDate+ where+ -- yesterday (at) noon+ dateMaybeAtTime = try $+ do ed <- englishDate now+ t <- option Nothing $ try $+ do { _ <- space; optional $ caseString "at "; Just `liftM` englishTime }+ return $ fromMaybe id t ed+ -- tea time 2005-12-04+ timeThenDate = try $+ do t <- englishTime+ optional $ char ','+ _ <- space+ ed <- englishDate now+ return $ t $ unsetTime ed++-- | Specific dates in English as specific points of time, e.g,+--+-- * today+--+-- * yesterday+--+-- * last week (i.e. the beginning of that interval)+--+-- * 4 months ago (via 'englishAgo')+--+-- The first argument is "now".+englishDate :: CalendarTime -> CharParser a CalendarTime+englishDate now = try $+ (caseString "today" >> return (resetCalendar now))+ <|> (caseString "yesterday" >> return (oneDay `subtractFromCal` now))+ <|> fst `fmap` englishLast now+ <|> englishAgo now+ where oneDay = TimeDiff 0 0 1 0 0 0 0++-- | English expressions for points in the past, e.g.+--+-- * 4 months ago+--+-- * 1 day ago+--+-- * day before yesterday+--+-- See 'englishDuration'+englishAgo :: CalendarTime -> CharParser a CalendarTime+englishAgo now =+ try $ do p <- englishDuration+ _ <- try space+ (m,ref) <- try (caseString "ago" >> return (-1, now))+ <|> do m <- beforeMod <|> afterMod+ _ <- space+ d <- englishDate now+ <|> fst `fmap` englishLast now+ <|> unsafeToCalendarTime `fmap` iso8601DateTime (ctTZ now)+ return (m,d)+ return $ multiplyDiff m p `addToCal` ref+ where+ beforeMod = try $ caseString "before" >> return (-1)+ afterMod = try $ caseStrings ["after","since"] >> return 1++-- | English expressions for intervals of time,+--+-- * before tea time (i.e. from the beginning of time)+--+-- * after 14:00 last month (i.e. till now)+--+-- * between last year and last month+--+-- * in the last three months (i.e. from then till now)+--+-- * 4 months ago (i.e. till now; see 'englishAgo')+englishInterval :: CalendarTime -> CharParser a TimeInterval+englishInterval now = twixt <|> before <|> after <|> inTheLast <|> lastetc+ where+ englishDT = unsafeToCalendarTime `fmap` iso8601DateTime (ctTZ now)+ <|> englishDateTime now+ before = try $+ do caseString "before"+ _ <- space+ end <- englishDT+ return (Just theBeginning, Just end)+ after = try $+ do caseStrings ["after","since"]+ _ <- space+ start <- englishDT+ return (Just start, Nothing)+ twixt = try $+ do caseString "between"+ _ <- space+ start <- englishDT+ _ <- space+ caseString "and"+ _ <- space+ end <- englishDT+ return (Just start, Just end)+ inTheLast = try $+ do caseString "in the last"+ _ <- space+ dur <- englishDuration+ return (Just $ dur `subtractFromCal` now, Just now)+ lastetc =+ do l <- englishAgo now+ return (Just l, Just now)++-- | Durations in English that begin with the word \"last\",+-- E.g. \"last 4 months\" is treated as the duration between+-- 4 months ago and now+englishLast :: CalendarTime -> CharParser a (CalendarTime, CalendarTime)+englishLast now =+ -- last year, last week, last 3 years, etc+ try $ do caseString "last"+ _ <- space+ d <- englishDuration+ return (d `subtractFromCal` now, now)++-- | Either an 'iso8601Time' or one of several common+-- English time expressions like 'noon' or 'tea time'+englishTime :: CharParser a (CalendarTime->CalendarTime)+englishTime = try $+ choice [ wrapM `fmap` iso8601Time+ , namedTime "noon" 12 0+ , namedTime "midnight" 0 0+ , namedTime "tea time" 16 30+ , namedTime "bed time" 2 30+ , namedTime "proper bed time" 21 30 ]+ where namedTime name h m = try $+ do caseString name+ return $ \c -> c { ctHour = h, ctMin = m }+ wrapM f = unsafeToCalendarTime . f . toMCalendarTime++-- | Some English durations, e.g.+--+-- * day+--+-- * 4 score+--+-- * 7 years+--+-- * 12 months+--+-- This is not particularly strict about what it accepts.+-- For example, "7 yeares", "4 scores" or "1 days" are+-- just fine.+englishDuration :: CharParser a TimeDiff+englishDuration = try $+ do n <- option 1 $ do x <- many1 digit+ _ <- space+ return $ read x+ b <- base+ optional (caseStrings ["es","s"])+ let current = multiplyDiff n b+ next <- option noTimeDiff $ try $ do+ { optional space; _ <- char ',' ; optional space ; englishDuration }+ return $ addDiff current next+ where+ base = choice+ [ try $ caseString "score" >> return (TimeDiff 20 0 0 0 0 0 0) -- why not?+ , caseString "year" >> return (TimeDiff 1 0 0 0 0 0 0)+ , try $ caseString "month" >> return (TimeDiff 0 1 0 0 0 0 0)+ , caseString "fortnight" >> return (TimeDiff 0 0 14 0 0 0 0)+ , caseString "week" >> return (TimeDiff 0 0 7 0 0 0 0)+ , caseString "day" >> return (TimeDiff 0 0 1 0 0 0 0)+ , caseString "hour" >> return (TimeDiff 0 0 0 1 0 0 0)+ , caseString "minute" >> return (TimeDiff 0 0 0 0 1 0 0)+ , caseString "second" >> return (TimeDiff 0 0 0 0 0 1 0) ]++----- Calendar and TimeDiff manipulation ---------------------------------------------++-- | The very beginning of time, i.e. 1970-01-01+theBeginning :: CalendarTime+theBeginning = unsafePerformIO $ toCalendarTime $ TOD 0 0++-- | An 'MCalenderTime' is an underspecified 'CalendarTime'+-- It is used for parsing dates. For example, if you want to parse+-- the date '4 January', it may be useful to underspecify the year+-- by setting it to 'Nothing'. This uses almost the same fields as+-- 'System.Time.CalendarTime', a notable exception being that we+-- introduce 'mctWeek' to indicate if a weekday was specified or not+data MCalendarTime = MCalendarTime+ { mctYear :: Maybe Int+ , mctMonth :: Maybe Month+ , mctDay :: Maybe Int+ , mctHour :: Maybe Int+ , mctMin :: Maybe Int+ , mctSec :: Maybe Int+ , mctPicosec :: Maybe Integer+ , mctWDay :: Maybe Day+ , mctYDay :: Maybe Int+ , mctTZName :: Maybe String+ , mctTZ :: Maybe Int+ , mctIsDST :: Maybe Bool+ , mctWeek :: Bool -- is set or not+} deriving Show++-- | Trivially convert a 'CalendarTime' to a fully specified+-- 'MCalendarTime' (note that this sets the 'mctWeek' flag to+-- @False@+toMCalendarTime :: CalendarTime -> MCalendarTime+toMCalendarTime (CalendarTime a b c d e f g h i j k l) =+ MCalendarTime (Just a) (Just b) (Just c) (Just d) (Just e) (Just f)+ (Just g) (Just h) (Just i) (Just j) (Just k) (Just l)+ False++-- | Returns the first 'CalendarTime' that falls within a 'MCalendarTime'+-- This is only unsafe in the sense that it plugs in default values+-- for fields that have not been set, e.g. @January@ for the month+-- or @0@ for the seconds field.+-- Maybe we should rename it something happier.+-- See also 'resetCalendar'+unsafeToCalendarTime :: MCalendarTime -> CalendarTime+unsafeToCalendarTime m =+ CalendarTime+ { ctYear = fromMaybe 0 $ mctYear m+ , ctMonth = fromMaybe January $ mctMonth m+ , ctDay = fromMaybe 1 $ mctDay m+ , ctHour = fromMaybe 0 $ mctHour m+ , ctMin = fromMaybe 0 $ mctMin m+ , ctSec = fromMaybe 0 $ mctSec m+ , ctPicosec = fromMaybe 0 $ mctPicosec m+ , ctWDay = fromMaybe Sunday $ mctWDay m+ , ctYDay = fromMaybe 0 $ mctYDay m+ , ctTZName = fromMaybe "" $ mctTZName m+ , ctTZ = fromMaybe 0 $ mctTZ m+ , ctIsDST = fromMaybe False $ mctIsDST m+ }++addToCal :: TimeDiff -> CalendarTime -> CalendarTime+addToCal td = toUTCTime . addToClockTime td . toClockTime++subtractFromCal :: TimeDiff -> CalendarTime -> CalendarTime+subtractFromCal = addToCal . multiplyDiff (-1)++addToMCal :: TimeDiff -> MCalendarTime -> MCalendarTime+addToMCal td mc =+ copyCalendar (addToCal td $ unsafeToCalendarTime mc) mc++subtractFromMCal :: TimeDiff -> MCalendarTime -> MCalendarTime+subtractFromMCal = addToMCal . multiplyDiff (-1)++-- surely there is a more concise way to express these+addDiff :: TimeDiff -> TimeDiff -> TimeDiff+addDiff (TimeDiff a1 a2 a3 a4 a5 a6 a7) (TimeDiff b1 b2 b3 b4 b5 b6 b7) =+ TimeDiff (a1+b1) (a2+b2) (a3+b3) (a4+b4) (a5+b5) (a6+b6) (a7 + b7)++-- | 'multiplyDiff' @i d@ multiplies every field in @d@ with @i@+--+-- FIXME; this seems like a terrible idea! it seems like+-- we should get rid of it if at all possible, maybe adding an+-- invertDiff function+multiplyDiff :: Int -> TimeDiff -> TimeDiff+multiplyDiff m (TimeDiff a1 a2 a3 a4 a5 a6 a7) =+ TimeDiff (a1*m) (a2*m) (a3*m) (a4*m) (a5*m) (a6*m) (a7 * toInteger m)++nullMCalendar :: MCalendarTime+nullMCalendar = MCalendarTime Nothing Nothing Nothing Nothing Nothing Nothing+ Nothing Nothing Nothing Nothing Nothing Nothing+ False++-- | Set a calendar to UTC time any eliminate any inconsistencies within+-- (for example, where the weekday is given as @Thursday@, but this does not+-- match what the numerical date would lead one to expect)+resetCalendar :: CalendarTime -> CalendarTime+resetCalendar = toUTCTime . toClockTime++-- | 'copyCalendar' @c mc@ replaces any field which is+-- specified in @mc@ with the equivalent field in @c@+-- @copyCalendar c nullMCalendar == nullMCalendar@+copyCalendar :: CalendarTime -> MCalendarTime -> MCalendarTime+copyCalendar c mc = mc+ { mctYear = mctYear mc >> Just (ctYear c)+ , mctMonth = mctMonth mc >> Just (ctMonth c)+ , mctDay = mctDay mc >> Just (ctDay c)+ , mctHour = mctHour mc >> Just (ctHour c)+ , mctMin = mctMin mc >> Just (ctMin c)+ , mctSec = mctSec mc >> Just (ctSec c)+ , mctPicosec = mctPicosec mc >> Just (ctPicosec c)+ , mctWDay = mctWDay mc >> Just (ctWDay c)+ , mctYDay = mctYDay mc >> Just (ctYDay c)+ , mctTZName = mctTZName mc >> Just (ctTZName c)+ , mctTZ = mctTZ mc >> Just (ctTZ c)+ , mctIsDST = mctIsDST mc >> Just (ctIsDST c)+ }++-- | Zero the time fields of a 'CalendarTime'+unsetTime :: CalendarTime -> CalendarTime+unsetTime mc = mc+ { ctHour = 0+ , ctMin = 0+ , ctSec = 0+ , ctPicosec = 0+ }
+ src/Darcs/Util/Path.hs view
@@ -0,0 +1,555 @@+-- Copyright (C) 2007 Eric Kow+-- Copyright (C) 2010 Petr Rockai+--+-- 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.++{-# LANGUAGE CPP #-}+module Darcs.Util.Path+ ( module Storage.Hashed.AnchoredPath+ , FileName( )+ , fp2fn+ , fn2fp+ , fn2ps+ , ps2fn+ , niceps2fn+ , fn2niceps+ , breakOnDir+ , normPath+ , ownName+ , superName+ , movedirfilename+ , encodeWhite+ , decodeWhite+ , isParentOrEqOf+ -- * AbsolutePath+ , AbsolutePath+ , makeAbsolute+ , ioAbsolute+ , rootDirectory+ -- * AbsolutePathOrStd+ , AbsolutePathOrStd+ , makeAbsoluteOrStd+ , ioAbsoluteOrStd+ , useAbsoluteOrStd+ , stdOut+ -- * AbsoluteOrRemotePath+ , AbsoluteOrRemotePath+ , ioAbsoluteOrRemote+ , isRemote+ -- * SubPath+ , SubPath+ , makeSubPathOf+ , simpleSubPath+ , isSubPathOf+ , floatSubPath+ -- * Miscellaneous+ , sp2fn+ , FilePathOrURL(..)+ , FilePathLike(toFilePath)+ , getCurrentDirectory+ , setCurrentDirectory+ , getUniquePathName+ , doesPathExist+ -- * Check for malicious paths+ , isMaliciousPath+ , isMaliciousSubPath+ -- * Tree filtering.+ , filterFilePaths+ , filterPaths+ ) where++import Storage.Hashed.AnchoredPath++import Control.Applicative ( (<$>) )+import Data.List+ ( isPrefixOf+ , isSuffixOf+ , stripPrefix+ , intersect+ )+import Data.Char ( isSpace, chr, ord )+import Control.Exception ( tryJust, bracket_ )+import Control.Monad ( when )+import System.IO.Error ( isDoesNotExistError )++import qualified Darcs.Util.Workaround as Workaround ( getCurrentDirectory )+import qualified System.Directory ( setCurrentDirectory )+import System.Directory ( doesDirectoryExist, doesFileExist )+import qualified System.FilePath.Posix as FilePath ( normalise )+import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory )+import System.FilePath ( splitDirectories )+import System.Posix.Files ( isDirectory, getSymbolicLinkStatus )++import Darcs.Util.ByteString ( packStringToUTF8, unpackPSFromUTF8 )+import qualified Data.ByteString.Char8 as BC (unpack, pack)+import qualified Data.ByteString as B (ByteString)+import Data.Binary++import Darcs.Util.Global ( darcsdir )+import Darcs.Util.URL ( isAbsolute, isRelative, isSshNopath )++#include "impossible.h"++-- | FileName is an abstract type intended to facilitate the input and output of+-- unicode filenames.+newtype FileName = FN FilePath deriving ( Eq, Ord )++instance Show FileName where+ showsPrec d (FN fp) = showParen (d > appPrec) $ showString "fp2fn " . showsPrec (appPrec + 1) fp+ where appPrec = 10++instance Binary FileName where+ put (FN h) = put h+ get = FN `fmap` get++{-# INLINE fp2fn #-}+fp2fn :: FilePath -> FileName+fp2fn = FN++{-# INLINE fn2fp #-}+fn2fp :: FileName -> FilePath+fn2fp (FN fp) = fp++{-# INLINE niceps2fn #-}+niceps2fn :: B.ByteString -> FileName+niceps2fn = FN . decodeWhite . BC.unpack++{-# INLINE fn2niceps #-}+fn2niceps :: FileName -> B.ByteString+fn2niceps (FN fp) = BC.pack $ encodeWhite fp++{-# INLINE fn2ps #-}+fn2ps :: FileName -> B.ByteString+fn2ps (FN fp) = packStringToUTF8 $ encodeWhite fp++{-# INLINE ps2fn #-}+ps2fn :: B.ByteString -> FileName+ps2fn ps = FN $ decodeWhite $ unpackPSFromUTF8 ps++{-# INLINE sp2fn #-}+sp2fn :: SubPath -> FileName+sp2fn = fp2fn . toFilePath++-- | 'encodeWhite' translates whitespace in filenames to a darcs-specific+-- format (numerical representation according to 'ord' surrounded by+-- backslashes). Note that backslashes are also escaped since they are used+-- in the encoding.+--+-- > encodeWhite "hello there" == "hello\32\there"+-- > encodeWhite "hello\there" == "hello\92\there"+encodeWhite :: FilePath -> String+encodeWhite (c:cs) | isSpace c || c == '\\' =+ '\\' : show (ord c) ++ "\\" ++ encodeWhite cs+encodeWhite (c:cs) = c : encodeWhite cs+encodeWhite [] = []++-- | 'decodeWhite' interprets the Darcs-specific \"encoded\" filenames+-- produced by 'encodeWhite'+--+-- > decodeWhite "hello\32\there" == "hello there"+-- > decodeWhite "hello\92\there" == "hello\there"+-- > decodeWhite "hello\there" == error "malformed filename"+decodeWhite :: String -> FilePath+decodeWhite cs_ = go cs_ [] False+ where go "" acc True = reverse acc -- if there was a replace, use new string+ go "" _ False = cs_ -- if not, use input string+ go ('\\':cs) acc _ =+ case break (=='\\') cs of+ (theord, '\\':rest) ->+ go rest (chr (read theord) :acc) True+ _ -> error "malformed filename"+ go (c:cs) acc modified = go cs (c:acc) modified++ownName :: FileName -> FileName+ownName (FN f) = case breakLast '/' f of Nothing -> FN f+ Just (_,f') -> FN f'+superName :: FileName -> FileName+superName fn = case normPath fn of+ FN f -> case breakLast '/' f of+ Nothing -> FN "."+ Just (d,_) -> FN d+breakOnDir :: FileName -> Maybe (FileName,FileName)+breakOnDir (FN p) = case breakFirst '/' p of+ Nothing -> Nothing+ Just (d,f) | d == "." -> breakOnDir $ FN f+ | otherwise -> Just (FN d, FN f)++-- | convert a path string into a sequence of directories strings+-- "/", "." and ".." are generally interpreted as expected.+-- Behaviour with too many '..' is to leave them.+--+-- Examples:+-- Splitting:+-- "aa/bb/cc" -> ["aa","bb","cc"]+-- Ignoring "." and extra "/":+-- "aa/./bb" -> ["aa","bb"]+-- "aa//bb" -> ["aa","bb"]+-- "/aa/bb/" -> ["aa","bb"]+-- Handling "..":+-- "aa/../bb/cc" -> ["bb","cc"]+-- "aa/bb/../../cc" -> ["cc"]+-- "aa/../bb/../cc" -> ["cc"]+-- "../cc" -> ["..","cc"]+normPath :: FileName -> FileName+normPath (FN p) = FN $ norm p++norm :: String -> String+norm ('.':'/':s) = norm s+norm ('/':s) = norm s+norm "." = ""+norm s = go s [] False+ where go "" _ False = s -- no modification+ go "" acc True = reverse acc+ go ('/':r) acc _ | sep r = go r acc True+ go ('/':'.':r) acc _ | sep r = go r acc True+ go ('/':'.':'.':r) acc _ | sep r = go r (doDotDot acc) True+ go (c:s') acc changed = go s' (c:acc) changed+ -- remove last path or add "/.." if impossible+ doDotDot "" = ".."+ doDotDot acc@('.':'.':r) | sep r = '.':'.':'/':acc+ doDotDot acc = let a' = dropWhile (/='/') acc in -- eat dir+ if null a' then "" else tail a'+ -- check if is a path separator+ sep ('/':_) = True+ sep [] = True -- end of string is considered separator+ sep _ = False++breakFirst :: Char -> String -> Maybe (String,String)+breakFirst c = bf []+ where bf a (r:rs) | r == c = Just (reverse a,rs)+ | otherwise = bf (r:a) rs+ bf _ [] = Nothing+breakLast :: Char -> String -> Maybe (String,String)+breakLast c l = case breakFirst c (reverse l) of+ Nothing -> Nothing+ Just (a,b) -> Just (reverse b, reverse a)++isParentOrEqOf :: FileName -> FileName -> Bool+isParentOrEqOf fn1 fn2 = case stripPrefix (fn2fp fn1) (fn2fp fn2) of+ Just ('/' : _) -> True+ Just [] -> True+ _ -> False++movedirfilename :: FileName -> FileName -> FileName -> FileName+movedirfilename old new name =+ if name' == old'+ then new+ else case stripPrefix old' name' of+ Just rest@('/':_) -> fp2fn $ "./" ++ new' ++ rest+ _ -> name+ where old' = fn2fp $ normPath old+ new' = fn2fp $ normPath new+ name' = fn2fp $ normPath name+++class FilePathOrURL a where+ toPath :: a -> String++class FilePathOrURL a => FilePathLike a where+ toFilePath :: a -> FilePath++-- | Paths which are relative to the local darcs repository and normalized.+-- Note: These are understood not to have the dot in front.+newtype SubPath = SubPath FilePath deriving (Eq, Ord)++newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord)++-- | This is for situations where a string (e.g. a command line argument)+-- may take the value \"-\" to mean stdin or stdout (which one depends on+-- context) instead of a normal file path.+data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (Eq, Ord)+data AbsoluteOrRemotePath = AbsP AbsolutePath | RmtP String deriving (Eq, Ord)++instance FilePathOrURL AbsolutePath where+ toPath (AbsolutePath x) = x+instance FilePathOrURL SubPath where+ toPath (SubPath x) = x+instance CharLike c => FilePathOrURL [c] where+ toPath = toFilePath++instance FilePathOrURL AbsoluteOrRemotePath where+ toPath (AbsP a) = toPath a+ toPath (RmtP r) = r++instance FilePathOrURL FileName where+ toPath = fn2fp+instance FilePathLike FileName where+ toFilePath = fn2fp++instance FilePathLike AbsolutePath where+ toFilePath (AbsolutePath x) = x+instance FilePathLike SubPath where+ toFilePath (SubPath x) = x++class CharLike c where+ toChar :: c -> Char+ fromChar :: Char -> c+instance CharLike Char where+ toChar = id+ fromChar = id++instance CharLike c => FilePathLike [c] where+ toFilePath = map toChar++-- | Make the second path relative to the first, if possible+makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath+makeSubPathOf (AbsolutePath p1) (AbsolutePath p2) =+ -- The slash prevents "foobar" from being treated as relative to "foo"+ if p1 == p2 || (p1 ++ "/") `isPrefixOf` p2+ then Just $ SubPath $ drop (length p1 + 1) p2+ else Nothing++simpleSubPath :: FilePath -> Maybe SubPath+simpleSubPath x | null x = bug "simpleSubPath called with empty path"+ | isRelative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x+ | otherwise = Nothing++isSubPathOf :: SubPath -> SubPath -> Bool+isSubPathOf (SubPath p1) (SubPath p2) =+ p1 == "" || p1 == p2 || (p1 ++ "/") `isPrefixOf` p2++-- | Ensure directory exists and is not a symbolic link.+doesDirectoryReallyExist :: FilePath -> IO Bool+doesDirectoryReallyExist f = do+ x <- tryJust (\x -> if isDoesNotExistError x then Just () else Nothing) $+ isDirectory <$> getSymbolicLinkStatus f+ return $ case x of+ Left () -> False+ Right y -> y++doesPathExist :: FilePath -> IO Bool+doesPathExist p = do+ dir_exists <- doesDirectoryExist p+ file_exists <- doesFileExist p+ return $ dir_exists || file_exists++-- | Interpret a possibly relative path wrt the current working directory.+ioAbsolute :: FilePath -> IO AbsolutePath+ioAbsolute dir =+ do isdir <- doesDirectoryReallyExist dir+ here <- getCurrentDirectory+ if isdir+ then bracket_ (setCurrentDirectory dir)+ (setCurrentDirectory $ toFilePath here)+ getCurrentDirectory+ else let super_dir = case NativeFilePath.takeDirectory dir of+ "" -> "."+ d -> d+ file = NativeFilePath.takeFileName dir+ in do abs_dir <- if dir == super_dir+ then return $ AbsolutePath dir+ else ioAbsolute super_dir+ return $ makeAbsolute abs_dir file++-- | Take an absolute path and a string representing a (possibly relative)+-- path and combine them into an absolute path. If the second argument is+-- already absolute, then the first argument gets ignored. This function also+-- takes care that the result is converted to Posix convention and+-- normalized. Also, parent directories (\"..\") at the front of the string+-- argument get canceled out against trailing directory parts of the+-- absolute path argument.+--+-- Regarding the last point, someone more familiar with how these functions+-- are used should verify that this is indeed necessary or at least useful.+makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath+makeAbsolute a dir = if not (null dir) && isAbsolute dir+ then AbsolutePath (normSlashes dir')+ else ma a dir'+ where+ dir' = FilePath.normalise $ pathToPosix dir+ -- Why do we care to reduce ".." here?+ -- Why not do this throughout the whole path, i.e. "x/y/../z" -> "x/z" ?+ ma here ('.':'.':'/':r) = ma (takeDirectory here) r+ ma here ".." = takeDirectory here+ ma here "." = here+ ma here "" = here+ ma here r = here /- ('/':r)++(/-) :: AbsolutePath -> String -> AbsolutePath+x /- ('/':r) = x /- r+(AbsolutePath "/") /- r = AbsolutePath ('/':simpleClean r)+(AbsolutePath x) /- r = AbsolutePath (x++'/':simpleClean r)++-- | Convert to posix, remove trailing slashes, and (under Posix)+-- reduce multiple leading slashes to one.+simpleClean :: String -> String+simpleClean = normSlashes . reverse . dropWhile (=='/') . reverse . pathToPosix++-- | The root directory as an absolute path.+rootDirectory :: AbsolutePath+rootDirectory = AbsolutePath "/"++makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd+makeAbsoluteOrStd _ "-" = APStd+makeAbsoluteOrStd a p = AP $ makeAbsolute a p++stdOut :: AbsolutePathOrStd+stdOut = APStd++ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd+ioAbsoluteOrStd "-" = return APStd+ioAbsoluteOrStd p = AP `fmap` ioAbsolute p++-- | Execute either the first or the second argument action, depending on+-- whether the given path is an 'AbsolutePath' or stdin/stdout.+useAbsoluteOrStd :: (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a+useAbsoluteOrStd _ f APStd = f+useAbsoluteOrStd f _ (AP x) = f x++ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath+ioAbsoluteOrRemote p = do+ isdir <- doesDirectoryExist p+ if not isdir+ then return $ RmtP $+ case () of _ | isSshNopath p -> p++"."+ | "/" `isSuffixOf` p -> init p+ | otherwise -> p+ else AbsP `fmap` ioAbsolute p++isRemote :: AbsoluteOrRemotePath -> Bool+isRemote (RmtP _) = True+isRemote _ = False++takeDirectory :: AbsolutePath -> AbsolutePath+takeDirectory (AbsolutePath x) =+ case reverse $ drop 1 $ dropWhile (/='/') $ reverse x of+ "" -> AbsolutePath "/"+ x' -> AbsolutePath x'++instance Show AbsolutePath where+ show = show . toFilePath+instance Show SubPath where+ show = show . toFilePath+instance Show AbsolutePathOrStd where+ show (AP a) = show a+ show APStd = "standard input/output"+instance Show AbsoluteOrRemotePath where+ show (AbsP a) = show a+ show (RmtP r) = show r++-- | Normalize the path separator to Posix style (slash, not backslash).+-- This only affects Windows systems.+pathToPosix :: FilePath -> FilePath+pathToPosix = map convert where+#ifdef WIN32+ convert '\\' = '/'+#endif+ convert c = c++-- | Reduce multiple leading slashes to one. This only affects Posix systems.+normSlashes :: FilePath -> FilePath+#ifndef WIN32+-- multiple slashes in front are ignored under Posix+normSlashes ('/':p) = '/' : dropWhile (== '/') p+#endif+normSlashes p = p++getCurrentDirectory :: IO AbsolutePath+getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory++setCurrentDirectory :: FilePathLike p => p -> IO ()+setCurrentDirectory = System.Directory.setCurrentDirectory . toFilePath++{-|+ What is a malicious path?++ A spoofed path is a malicious path.++ 1. Darcs only creates explicitly relative paths (beginning with @\".\/\"@),+ so any not explicitly relative path is surely spoofed.++ 2. Darcs normalizes paths so they never contain @\"\/..\/\"@, so paths with+ @\"\/..\/\"@ are surely spoofed.++ A path to a darcs repository's meta data can modify \"trusted\" patches or+ change safety defaults in that repository, so we check for paths+ containing @\"\/_darcs\/\"@ which is the entry to darcs meta data.++ To do?++ * How about get repositories?++ * Would it be worth adding a --semi-safe-paths option for allowing+ changes to certain preference files (_darcs\/prefs\/) in sub+ repositories'?+-}+isMaliciousPath :: String -> Bool+isMaliciousPath fp =+ not (isExplicitlyRelative fp) || isGenerallyMalicious fp++-- | Warning : this is less rigorous than isMaliciousPath+-- but it's to allow for subpath representations that+-- don't start with ./+isMaliciousSubPath :: String -> Bool+isMaliciousSubPath fp =+ not (isRelative fp) || isGenerallyMalicious fp++isGenerallyMalicious :: String -> Bool+isGenerallyMalicious fp =+ splitDirectories fp `contains_any` [ "..", darcsdir ]+ where+ contains_any a b = not . null $ intersect a b+++isExplicitlyRelative :: String -> Bool+isExplicitlyRelative ('.':'/':_) = True -- begins with "./"+isExplicitlyRelative _ = False++-- | Construct a filter from a list of AnchoredPaths, that will accept any path+-- that is either a parent or a child of any of the listed paths, and discard+-- everything else.+filterPaths :: [AnchoredPath]+ -> AnchoredPath+ -> t+ -> Bool+filterPaths files p _ = any (\x -> x `isPrefix` p || p `isPrefix` x) files+++-- | Same as 'filterPath', but for ordinary 'FilePath's (as opposed to+-- AnchoredPath).+filterFilePaths :: [FilePath]+ -> AnchoredPath+ -> t+ -> Bool+filterFilePaths = filterPaths . map floatPath++-- | Iteratively tries find first non-existing path generated by+-- buildName, it feeds to buildName the number starting with -1. When+-- it generates non-existing path and it isn't first, it displays the+-- message created with buildMsg. Usually used for generation of the+-- name like <path>_<number> when <path> already exist+-- (e.g. darcs.net_0).+getUniquePathName :: Bool -> (FilePath -> String) -> (Int -> FilePath) -> IO FilePath+getUniquePathName talkative buildMsg buildName = go (-1)+ where+ go :: Int -> IO FilePath+ go i = do+ exists <- doesPathExist thename+ if not exists+ then do when (i /= -1 && talkative) $ putStrLn $ buildMsg thename+ return thename+ else go $ i+1+ where thename = buildName i++-- | Transform a SubPath into an AnchoredPath.+floatSubPath :: SubPath -> AnchoredPath+floatSubPath = floatPath . fn2fp . sp2fn+
+ src/Darcs/Util/Printer.hs view
@@ -0,0 +1,476 @@+-- | A 'Document' is at heart 'ShowS' from the prelude+--+-- Essentially, if you give a Doc a string it'll print out whatever it+-- wants followed by that string. So @text "foo"@ makes the Doc that+-- prints @"foo"@ followed by its argument. The combinator names are taken+-- from 'Text.PrettyPrint.HughesPJ', although the behaviour of the two libraries is+-- slightly different.+--+-- The advantage of Printer over simple string appending/concatenating is+-- that the appends end up associating to the right, e.g.:+--+-- > (text "foo" <> text "bar") <> (text "baz" <> text "quux") ""+-- > = \s -> (text "foo" <> text "bar") ((text "baz" <> text "quux") s) ""+-- > = (text "foo" <> text "bar") ((text "baz" <> text "quux") "")+-- > = (\s -> (text "foo") (text "bar" s)) ((text "baz" <> text "quux") "")+-- > = text "foo" (text "bar" ((text "baz" <> text "quux") ""))+-- > = (\s -> "foo" ++ s) (text "bar" ((text "baz" <> text "quux") ""))+-- > = "foo" ++ (text "bar" ((text "baz" <> text "quux") ""))+-- > = "foo" ++ ("bar" ++ ((text "baz" <> text "quux") ""))+-- > = "foo" ++ ("bar" ++ ((\s -> text "baz" (text "quux" s)) ""))+-- > = "foo" ++ ("bar" ++ (text "baz" (text "quux" "")))+-- > = "foo" ++ ("bar" ++ ("baz" ++ (text "quux" "")))+-- > = "foo" ++ ("bar" ++ ("baz" ++ ("quux" ++ "")))+--+-- The Empty alternative comes in because you want+--+-- > text "a" $$ vcat xs $$ text "b"+--+-- '$$' means above, 'vcat' is the list version of '$$'+-- (to be @\"a\\nb\"@ when @xs@ is @[]@), but without the concept of an+-- Empty Document each @$$@ would add a @'\n'@ and you'd end up with+-- @\"a\\n\\nb\"@.+-- Note that @Empty \/= text \"\"@ (the latter would cause two+-- @'\\n'@).+--+-- This code was made generic in the element type by Juliusz Chroboczek.+module Darcs.Util.Printer+ (+ Printable(..), Doc(Doc,unDoc), Printers, Printers'(..), Printer, Color(..)+ , RenderMode(..)+ , hPutDoc, hPutDocLn, putDoc, putDocLn+ , hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith+ , hPutDocCompr+ , renderString, renderStringWith, renderPS, renderPSWith+ , renderPSs, renderPSsWith, lineColor+ , prefix, insertBeforeLastline, colorText, invisibleText+ , prefixLines+ , hiddenText, hiddenPrefix, userchunk, text+ , printable, wrapText+ , blueText, redText, greenText, magentaText, cyanText+ , unsafeText, unsafeBoth, unsafeBothText, unsafeChar+ , invisiblePS, packedString, unsafePackedString, userchunkPS+ , simplePrinters, invisiblePrinter, simplePrinter+ , doc, empty, (<>), (<?>), (<+>), ($$), vcat, vsep, hcat+ , minus, newline, plus, space, backslash, lparen, rparen+ , parens+ , errorDoc+ ) where++import Data.String ( IsString(..) )+import Data.List (intersperse)+import System.IO (Handle, stdout, hPutStr)+import Darcs.Util.ByteString ( linesPS, encodeLocale, gzWriteHandle )+import qualified Data.ByteString as B (ByteString, hPut, concat)+import qualified Data.ByteString.Char8 as BC (unpack, pack, singleton)++-- | A 'Printable' is either a String, a packed string, or a chunk of+-- text with both representations.+data Printable = S !String+ | PS !B.ByteString+ | Both !String !B.ByteString++-- | 'spaceP' is the 'Printable' representation of a space.+spaceP :: Printable+spaceP = Both " " (BC.singleton ' ')++-- | 'newlineP' is the 'Printable' representation of a newline.+newlineP :: Printable+newlineP = S "\n"++-- | Minimal 'Doc's representing the common characters 'space', 'newline'+-- 'minus', 'plus', and 'backslash'.+space, newline, plus, minus, backslash :: Doc+space = unsafeBoth " " (BC.singleton ' ')+newline = unsafeChar '\n'+minus = unsafeBoth "-" (BC.singleton '-')+plus = unsafeBoth "+" (BC.singleton '+')+backslash = unsafeBoth "\\" (BC.singleton '\\')++-- | 'lparen' is the 'Doc' that represents @\"(\"@+lparen :: Doc+lparen = unsafeBoth "(" (BC.singleton '(')++-- | 'rparen' is the 'Doc' that represents @\")\"@+rparen :: Doc+rparen = unsafeBoth ")" (BC.singleton ')')++-- | @'parens' doc@ returns a 'Doc' with the content of @doc@ put within+-- a pair of parenthesis.+parens :: Doc -> Doc+parens d = lparen <> d <> rparen++errorDoc :: Doc -> a+errorDoc = error . renderStringWith simplePrinters' Encode++-- | 'putDocWith' puts a doc on stdout using the given printer.+putDocWith :: Printers -> Doc -> IO ()+putDocWith prs = hPutDocWith prs Encode stdout++-- | 'putDocLnWith' puts a doc, followed by a newline on stdout using+-- the given printer.+putDocLnWith :: Printers -> Doc -> IO ()+putDocLnWith prs = hPutDocLnWith prs Encode stdout++-- | 'putDoc' puts a doc on stdout using the simple printer 'simplePrinters'.+putDoc :: Doc -> IO ()+putDoc = hPutDoc Encode stdout++-- | 'putDocLn' puts a doc, followed by a newline on stdout using+-- 'simplePrinters'+putDocLn :: Doc -> IO ()+putDocLn = hPutDocLn Encode stdout++-- | 'hputDocWith' puts a doc on the given handle using the given printer.+hPutDocWith :: Printers -> RenderMode -> Handle -> Doc -> IO ()+hPutDocWith prs target h d = hPrintPrintables target h (renderWith (prs h) d)++-- | 'hputDocLnWith' puts a doc, followed by a newline on the given+-- handle using the given printer.+hPutDocLnWith :: Printers -> RenderMode -> Handle -> Doc -> IO ()+hPutDocLnWith prs target h d = hPutDocWith prs target h (d <?> newline)++-- |'hputDoc' puts a doc on the given handle using 'simplePrinters'+hPutDoc :: RenderMode -> Handle -> Doc -> IO ()+hPutDoc = hPutDocWith simplePrinters++-- 'hputDocLn' puts a doc, followed by a newline on the given handle using+-- 'simplePrinters'.+hPutDocLn :: RenderMode -> Handle -> Doc -> IO ()+hPutDocLn = hPutDocLnWith simplePrinters++-- | like 'hPutDoc' but with compress data before writing+hPutDocCompr :: RenderMode -> Handle -> Doc -> IO ()+hPutDocCompr target h = gzWriteHandle h . renderPSs target++-- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle h+hPrintPrintables :: RenderMode -> Handle -> [Printable] -> IO ()+hPrintPrintables target h = mapM_ (hPrintPrintable target h)++-- | @hPrintPrintable h@ prints a 'Printable' to the handle h.+hPrintPrintable :: RenderMode -> Handle -> Printable -> IO ()+hPrintPrintable Standard h (S ps) = hPutStr h ps+hPrintPrintable Encode h (S ps) = B.hPut h (encodeLocale ps)+hPrintPrintable Standard h (PS ps) = B.hPut h ps+hPrintPrintable Encode h (PS ps) = B.hPut h ps+hPrintPrintable Standard h (Both _ ps) = B.hPut h ps+hPrintPrintable Encode h (Both _ ps) = B.hPut h ps++-- | a 'Doc' is a bit of enriched text. 'Doc's get concatanated using+-- '<>', which is right-associative.+newtype Doc = Doc { unDoc :: St -> Document }++instance IsString Doc where+ fromString = text++-- TODO this is a rather ad-hoc hack that further complicates+-- some already confusing code. We should find a more general+-- solution. See the discussion on issue1639.+-- | Used when rendering a 'Doc' to indicate if the result+-- should be encoded to the current locale or left alone.+-- In practice this only affects output when a relevant+-- DARCS_DONT_ESCAPE_XXX option is set (see Darcs.Util.Printer.Color)+-- If in doubt, choose 'Standard'.+data RenderMode =+ Encode -- ^Encode Strings with the current locale.+ -- At present ByteStrings are assumed to be in+ -- UTF8 and are left alone, so will be mis-encoded+ -- in non-UTF8 locales.+ | Standard -- ^Don't encode.++-- | The State associated with a doc. Contains a set of printers for each+-- hanlde, and the current prefix of the document.+data St = St { printers :: !Printers',+ currentPrefix :: !([Printable] -> [Printable]) }+type Printers = Handle -> Printers'++-- | A set of printers to print different types of text to a handle.+data Printers' = Printers {colorP :: !(Color -> Printer),+ invisibleP :: !Printer,+ hiddenP :: !Printer,+ userchunkP :: !Printer,+ defP :: !Printer,+ lineColorT :: !(Color -> Doc -> Doc),+ lineColorS :: !([Printable] -> [Printable])+ }+type Printer = Printable -> St -> Document++data Color = Blue | Red | Green | Cyan | Magenta++-- | 'Document' is a wrapper around '[Printable] -> [Printable]' which allows+-- for empty Documents. The simplest 'Documents' are built from 'String's+-- using 'text'.+data Document = Document ([Printable] -> [Printable])+ | Empty++-- | renders a 'Doc' into a 'String' with control codes for the+-- special features of the doc.+renderString :: RenderMode -> Doc -> String+renderString = renderStringWith simplePrinters'++-- | renders a 'Doc' into a 'String' using a given set of printers.+renderStringWith :: Printers' -> RenderMode -> Doc -> String+renderStringWith prs target d = concatMap (toString target) $ renderWith prs d+ where toString Standard (S s) = s+ toString Encode (S s) = BC.unpack . encodeLocale $ s+ toString Standard (PS ps) = BC.unpack ps+ toString Encode (PS ps) = BC.unpack ps+ toString Standard (Both s _) = s+ toString Encode (Both s _) = BC.unpack . encodeLocale $ s++-- | renders a 'Doc' into 'B.ByteString' with control codes for the+-- special features of the Doc. See also 'readerString'.+renderPS :: RenderMode -> Doc -> B.ByteString+renderPS = renderPSWith simplePrinters'++-- | renders a 'Doc' into a list of 'PackedStrings', one for each line.+renderPSs :: RenderMode -> Doc -> [B.ByteString]+renderPSs = renderPSsWith simplePrinters'++-- | renders a doc into a 'B.ByteString' using a given set of printers.+renderPSWith :: Printers' -> RenderMode -> Doc -> B.ByteString+renderPSWith prs target d = B.concat $ renderPSsWith prs target d++-- | renders a 'Doc' into a list of 'PackedStrings', one for each+-- chunk of text that was added to the doc, using the given set of+-- printers.+renderPSsWith :: Printers' -> RenderMode -> Doc -> [B.ByteString]+renderPSsWith prs target d = map (toPS target) $ renderWith prs d+ where toPS Standard (S s) = BC.pack s+ toPS Encode (S s) = encodeLocale s+ toPS Standard (PS ps) = ps+ toPS Encode (PS ps) = ps+ toPS Standard (Both _ ps) = ps+ toPS Encode (Both _ ps) = ps++-- | renders a 'Doc' into a list of 'Printables' using a set of+-- printers. Each item of the list corresponds to a string that was+-- added to the doc.+renderWith :: Printers' -> Doc -> [Printable]+renderWith ps (Doc d) = case d (initState ps) of+ Empty -> []+ Document f -> f []++initState :: Printers' -> St+initState prs = St { printers = prs, currentPrefix = id }++prefix :: String -> Doc -> Doc+prefix s (Doc d) = Doc $ \st ->+ let p = S s+ st' = st { currentPrefix = currentPrefix st . (p:) } in+ case d st' of+ Document d'' -> Document $ (p:) . d''+ Empty -> Empty++-- TODO try to find another way to do this, it's rather a violation+-- of the Doc abstraction+prefixLines :: Doc -> Doc -> Doc+prefixLines prefixer prefixee =+ vcat $ map (prefixer <+>) $ map packedString $ linesPS $+ -- this will just get round-tripped back into a Doc,+ renderPS Standard prefixee++-- TODO try to find another way to do this, it's rather a violation+-- of the Doc abstraction+insertBeforeLastline :: Doc -> Doc -> Doc+insertBeforeLastline a b =+ -- as this will just get round-tripped back into a Doc,+ -- we use 'Standard' as the Target type so the encoding+ -- is left alone+ case reverse $ map packedString $ linesPS $ renderPS Standard a of+ (ll:ls) -> vcat (reverse ls) $$ b $$ ll+ [] -> error "empty Doc given as first argument of Printer.insert_before_last_line"+++lineColor :: Color -> Doc -> Doc+lineColor c d = Doc $ \st -> case lineColorT (printers st) c d of+ Doc d' -> d' st++hiddenPrefix :: String -> Doc -> Doc+hiddenPrefix s (Doc d) =+ Doc $ \st -> let pr = printers st+ p = S (renderStringWith pr Standard $ hiddenText s)+ st' = st { currentPrefix = currentPrefix st . (p:) }+ in case d st' of+ Document d'' -> Document $ (p:) . d''+ Empty -> Empty++-- | 'unsafeBoth' builds a Doc from a 'String' and a 'B.ByteString' representing+-- the same text, but does not check that they do.+unsafeBoth :: String -> B.ByteString -> Doc+unsafeBoth s ps = Doc $ simplePrinter (Both s ps)++-- | 'unsafeBothText' builds a 'Doc' from a 'String'. The string is stored in the+-- Doc as both a String and a 'B.ByteString'.+unsafeBothText :: String -> Doc+unsafeBothText s = Doc $ simplePrinter (Both s (BC.pack s))++-- | 'packedString' builds a 'Doc' from a 'B.ByteString' using 'printable'+packedString :: B.ByteString -> Doc+packedString = printable . PS++-- | 'unsafePackedString' builds a 'Doc' from a 'B.ByteString' using 'simplePrinter'+unsafePackedString :: B.ByteString -> Doc+unsafePackedString = Doc . simplePrinter . PS++-- | 'invisiblePS' creates a 'Doc' with invisible text from a 'B.ByteString'+invisiblePS :: B.ByteString -> Doc+invisiblePS = invisiblePrintable . PS++-- | 'userchunkPS' creates a 'Doc' representing a user chunk from a 'B.ByteString'.+userchunkPS :: B.ByteString -> Doc+userchunkPS = userchunkPrintable . PS++-- | 'unsafeChar' creates a Doc containing just one character.+unsafeChar :: Char -> Doc+unsafeChar = unsafeText . (:"")++-- | 'text' creates a 'Doc' from a @String@, using 'printable'.+text :: String -> Doc+text = printable . S++-- | 'unsafeText' creates a 'Doc' from a 'String', using 'simplePrinter' directly+unsafeText :: String -> Doc+unsafeText = Doc . simplePrinter . S++-- | 'invisibleText' creates a 'Doc' containing invisible text from a @String@+invisibleText :: String -> Doc+invisibleText = invisiblePrintable . S++-- | 'hiddenText' creates a 'Doc' containing hidden text from a @String@+hiddenText :: String -> Doc+hiddenText = hiddenPrintable . S++-- | 'userchunk' creates a 'Doc' containing a user chunk from a @String@+userchunk :: String -> Doc+userchunk = userchunkPrintable . S++-- | 'blueText' creates a 'Doc' containing blue text from a @String@+blueText, redText, greenText, magentaText, cyanText :: String -> Doc+blueText = colorText Blue+redText = colorText Red+greenText = colorText Green+magentaText = colorText Magenta+cyanText = colorText Cyan++-- | 'colorText' creates a 'Doc' containing colored text from a @String@+colorText :: Color -> String -> Doc+colorText c = mkColorPrintable c . S++-- | @'wrapText' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters+wrapText :: Int -> String -> Doc+wrapText n s =+ vcat . map text . reverse $ "" : foldl add_to_line [] (words s)+ where add_to_line [] a = [a]+ add_to_line ("":d) a = a:d+ add_to_line (l:ls) new | length l + length new > n = new:l:ls+ add_to_line (l:ls) new = (l ++ " " ++ new):ls++-- | 'printable x' creates a 'Doc' from any 'Printable'.+printable, invisiblePrintable, hiddenPrintable, userchunkPrintable :: Printable -> Doc+printable x = Doc $ \st -> defP (printers st) x st++mkColorPrintable :: Color -> Printable -> Doc+mkColorPrintable c x = Doc $ \st -> colorP (printers st) c x st+invisiblePrintable x = Doc $ \st -> invisibleP (printers st) x st+hiddenPrintable x = Doc $ \st -> hiddenP (printers st) x st+userchunkPrintable x = Doc $ \st -> userchunkP (printers st) x st++-- | 'simplePrinters' is a 'Printers' which uses the set 'simplePriners\'' on any+-- handle.+simplePrinters :: Printers+simplePrinters _ = simplePrinters'++-- | A set of default printers suitable for any handle. Does not use color.+simplePrinters' :: Printers'+simplePrinters' = Printers { colorP = const simplePrinter,+ invisibleP = simplePrinter,+ hiddenP = invisiblePrinter,+ userchunkP = simplePrinter,+ defP = simplePrinter,+ lineColorT = const id,+ lineColorS = id+ }++-- | 'simplePrinter' is the simplest 'Printer': it just concatenates together+-- the pieces of the 'Doc'+simplePrinter :: Printer+simplePrinter x = unDoc $ doc (\s -> x:s)++-- | 'invisiblePrinter' is the 'Printer' for hidden text. It just replaces+-- the document with 'empty'. It's useful to have a printer that doesn't+-- actually do anything because this allows you to have tunable policies,+-- for example, only printing some text if it's to the terminal, but not+-- if it's to a file or vice-versa.+invisiblePrinter :: Printer+invisiblePrinter _ = unDoc empty++infixr 6 <>+infixr 6 <+>+infixr 5 $$++-- | The empty 'Doc'.+empty :: Doc+empty = Doc $ const Empty+doc :: ([Printable] -> [Printable]) -> Doc+doc f = Doc $ const $ Document f++-- | '(<>)' is the concatenation operator for 'Doc's+(<>) :: Doc -> Doc -> Doc+-- | @a '<?>' b@ is @a <> b@ if @a@ is not empty, else empty.+(<?>) :: Doc -> Doc -> Doc+-- | @a '<+>' b@ is @a@ followed by a space, then @b@.+(<+>) :: Doc -> Doc -> Doc+-- | @a '$$' b@ is @a@ above @b@.+($$) :: Doc -> Doc -> Doc+-- a then b+Doc a <> Doc b =+ Doc $ \st -> case a st of+ Empty -> b st+ Document af ->+ Document (\s -> af $ case b st of+ Empty -> s+ Document bf -> bf s)++-- empty if a empty, else a then b+Doc a <?> Doc b =+ Doc $ \st -> case a st of+ Empty -> Empty+ Document af -> Document (\s -> af $ case b st of+ Empty -> s+ Document bf -> bf s)++-- a then space then b+Doc a <+> Doc b =+ Doc $ \st -> case a st of+ Empty -> b st+ Document af -> Document (\s -> af $ case b st of+ Empty -> s+ Document bf ->+ spaceP:bf s)++-- a above b+Doc a $$ Doc b =+ Doc $ \st -> case a st of+ Empty -> b st+ Document af ->+ Document (\s -> af $ case b st of+ Empty -> s+ Document bf -> sf (newlineP:pf (bf s)))+ where pf = currentPrefix st+ sf = lineColorS $ printers st++-- | 'vcat' piles vertically a list of 'Doc's.+vcat :: [Doc] -> Doc+vcat [] = empty+vcat ds = foldr1 ($$) ds++-- | 'vsep' piles vertically a list of 'Doc's leaving a blank line between each.+vsep :: [Doc] -> Doc+vsep [] = empty+vsep ds = foldr1 ($$) $ intersperse (text "") ds++-- | 'hcat' concatenates (horizontally) a list of 'Doc's+hcat :: [Doc] -> Doc+hcat [] = empty+hcat ds = foldr1 (<>) ds
+ src/Darcs/Util/Printer/Color.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE CPP #-}+module Darcs.Util.Printer.Color+ ( showDoc, errorDoc, traceDoc, assertDoc, fancyPrinters+ , environmentHelpColor, environmentHelpEscape, environmentHelpEscapeWhite+ ) where++import Darcs.Util.Printer+ ( Printer, Printers, Printers'(..), Printable(..), Color(..), RenderMode(..)+ , invisiblePrinter, (<>), (<?>), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat+ , unsafeText, unsafePackedString+ , renderStringWith, prefix+ )++import Prelude hiding ( catch )+import Control.Monad ( liftM )+import Control.Exception ( catch, IOException )+import Debug.Trace ( trace )+import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr )+import Data.Bits ( bit, xor )+import System.Environment ( getEnv )+import qualified Data.ByteString.Char8 as BC (unpack, any, last, spanEnd)+import qualified Data.ByteString as B (null, init)+import System.IO.Unsafe ( unsafePerformIO )+import System.IO ( stderr, hIsTerminalDevice, Handle )+import Text.Printf ( printf )+#ifdef HAVE_TERMINFO+import System.Console.Terminfo( tiGetNum, setupTermFromEnv, getCapability )+import Data.Maybe ( fromMaybe )+#endif++dollar, cr :: Doc+dollar = unsafeBothText "$"+cr = unsafeBothText "\r"++errorDoc :: Doc -> a+errorDoc = error . showDoc Encode++traceDoc :: Doc -> a -> a+traceDoc d = trace (showDoc Encode d)++assertDoc :: Maybe Doc -> a -> a+assertDoc Nothing x = x+assertDoc (Just e) _ = errorDoc e++showDoc :: RenderMode -> Doc -> String+showDoc = renderStringWith (fancyPrinters stderr)++-- policy+-- | the 'Policy' type is a record containing the variables which control+-- how 'Doc's will be rendered on some output.+data Policy = Policy { poColor :: Bool -- ^ overall use of color+ , poEscape :: Bool -- ^ overall use of escaping+ , poLineColor :: Bool -- ^ overall use of colored lines (only hunks for now)+ , poAltColor :: Bool -- ^ alternative to color (bold, inverse)+ , poIsprint :: Bool -- ^ don't escape isprints+ , po8bit :: Bool -- ^ don't escape 8-bit chars+ , poNoEscX :: String -- ^ extra chars to never escape+ , poEscX :: String -- ^ extra chars to always escape+ , poTrailing :: Bool -- ^ escape trailing spaces+ , poCR :: Bool -- ^ ignore \r at end of lines+ , poSpace :: Bool -- ^ escape spaces (used with poTrailing)+ }++{-# NOINLINE getPolicy #-}+-- | 'getPolicy' returns a suitable policy for a given handle.+-- The policy is chosen according to environment variables, and to the+-- type of terminal which the handle represents+getPolicy :: Handle -> Policy+getPolicy handle = unsafePerformIO $+ do isTerminal <- hIsTerminalDevice handle+ nColors <- if isTerminal then getTermNColors else return 0++ envDontEscapeAnything <- getEnvBool "DARCS_DONT_ESCAPE_ANYTHING"+ envDontEscapeIsprint <- getEnvBool "DARCS_DONT_ESCAPE_ISPRINT"+ envUseIsprint <- getEnvBool "DARCS_USE_ISPRINT" -- for backwards-compatibility+ envDontEscape8bit <- getEnvBool "DARCS_DONT_ESCAPE_8BIT"++ envDontEscapeExtra <- getEnvString "DARCS_DONT_ESCAPE_EXTRA"+ envEscapeExtra <- getEnvString "DARCS_ESCAPE_EXTRA"++ envDontEscapeTrailingSpace <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_SPACES"+ envDontEscapeTrailingCR <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_CR"++ envDontColor <- getEnvBool "DARCS_DONT_COLOR"+ envAlwaysColor <- getEnvBool "DARCS_ALWAYS_COLOR"+ envAlternativeColor <- getEnvBool "DARCS_ALTERNATIVE_COLOR"+ envDoColorLines <- getEnvBool "DARCS_DO_COLOR_LINES"++ let haveColor = envAlwaysColor || (isTerminal && (nColors > 4))+ doColor = not envDontColor && haveColor++ return Policy { poColor = doColor,+ poEscape = not envDontEscapeAnything,+ poLineColor= doColor && envDoColorLines,+ poIsprint = envDontEscapeIsprint || envUseIsprint,+ po8bit = envDontEscape8bit,+ poNoEscX = envDontEscapeExtra,+ poEscX = envEscapeExtra,+ poTrailing = not envDontEscapeTrailingSpace,+ poCR = envDontEscapeTrailingCR,+ poAltColor = haveColor && envAlternativeColor,++ poSpace = False+ }+ where+ getEnvBool s = (/= "0") `liftM` safeGetEnv s+ safeGetEnv s = getEnv s `catch` \(_ :: IOException) -> return "0"+ getEnvString s = getEnv s `catch` \(_ :: IOException) -> return ""+++{-+ - This function returns number of colors supported by current terminal+ - or -1 if color output not supported or error occured.+ - Terminal type determined by TERM env. variable.+ -}+getTermNColors :: IO Int+#ifdef HAVE_TERMINFO+getTermNColors = do+ t <- setupTermFromEnv+ return . fromMaybe (-1) . getCapability t . tiGetNum $ "colors"+#else+getTermNColors = return (-1)+#endif++++-- printers++-- | @'fancyPrinters' h@ returns a set of printers suitable for outputting+-- to @h@+fancyPrinters :: Printers+fancyPrinters h = let policy = getPolicy h in+ Printers { colorP = colorPrinter policy,+ invisibleP = invisiblePrinter,+ hiddenP = colorPrinter policy Green,+ userchunkP = userchunkPrinter policy,+ defP = escapePrinter policy,+ lineColorT = lineColorTrans policy,+ lineColorS = lineColorSuffix policy+ }++-- | @'lineColorTrans' policy@ tries to color a Doc, according to policy po.+-- That is, if @policy@ has @poLineColor@ set, then colors the line, otherwise+-- does nothing.+lineColorTrans :: Policy -> Color -> Doc -> Doc+lineColorTrans po | poLineColor po = \c d -> prefix (setColor c) d <?> unsafeBothText resetColor+ | otherwise = const id++lineColorSuffix :: Policy -> [Printable] -> [Printable]+lineColorSuffix po | poLineColor po = \d -> S resetColor : d+ | otherwise = id++colorPrinter :: Policy -> Color -> Printer+colorPrinter po | poColor po = \c -> unDoc . color po c . Doc . escapePrinter po{poColor=False}+ | otherwise = const $ escapePrinter po++userchunkPrinter :: Policy -> Printer+userchunkPrinter po p+ | not (poEscape po) = simplePrinter p+ | not (poTrailing po) = escapePrinter po p+ | otherwise = unDoc $ pr p+ where+ pr (S s) = prString s+ pr (Both _ ps) = prPS ps+ pr (PS ps) = prPS ps++ prPS ps = let (leadPS, trailPS) = BC.spanEnd isSpace ps+ in if B.null trailPS+ then Doc $ escapePrinter po p+ else Doc (escapePrinter po (PS leadPS))+ <> Doc (escapePrinter po{poSpace=True} (PS trailPS))+ <> markEscape po dollar++ prString s = let (trail',lead') = span isSpace (reverse s)+ lead = reverse lead'+ trail = reverse trail'+ in if (not.null) trail+ then Doc (escapePrinter po (S lead))+ <> Doc (escapePrinter po{poSpace=True} (S trail))+ <> markEscape po dollar+ else Doc (escapePrinter po p)++escapePrinter :: Policy -> Printer+escapePrinter po+ | (not.poEscape) po = simplePrinter+ | otherwise = unDoc . crepr+ where+ crepr p | poCR po && isEndCR p = epr (initPR p) <> cr+ | otherwise = epr p++ epr (S s) = escape po s+ epr (PS ps) = if BC.any (not.noEscape po) ps+ then escape po (BC.unpack ps)+ else unsafePackedString ps+ epr (Both s _) = escape po s++ isEndCR (S s) = not (null s) && last s == '\r'+ isEndCR (PS ps) = not (B.null ps) && BC.last ps == '\r'+ isEndCR (Both _ ps) = not (B.null ps) && BC.last ps == '\r'++ initPR (S s) = S $ init s+ initPR (PS ps) = PS $ B.init ps+ initPR (Both s ps) = Both (init s) (B.init ps)+++-- | @'escape' policy string@ escapes @string@ according to the rules+-- defined in 'policy', turning it into a 'Doc'.+escape :: Policy -> String -> Doc+escape _ "" = unsafeText ""+escape po s = hcat $ escape' s+ where+ escape' "" = []+ escape' s'@(c:_) | mundane c =+ let (printables, rest) = span mundane s' in+ unsafeText printables:escape' rest+ escape' (c:rest) = (emph . unsafeText $ quoteChar c):escape' rest+ mundane c = noEscape po c || c == ' '+ emph = markEscape po+++-- | @'noEscape' policy c@ tells wether @c@ will be left as-is+-- when escaping according to @policy@+noEscape :: Policy -> Char -> Bool+noEscape po c | poSpace po && isSpace c = False+noEscape po c | c `elem` poEscX po = False+noEscape po c | c `elem` poNoEscX po = True+noEscape _ '\t' = True -- tabs will likely be converted to spaces+noEscape _ '\n' = True+noEscape po c = if poIsprint po then isPrint c+ else isPrintableAscii c+ || c >= '\x80' && po8bit po++-- | 'isPrintableAscii' tells wether a character is a printable character+-- of the ascii range.+isPrintableAscii :: Char -> Bool+isPrintableAscii c = isAscii c && isPrint c+++-- | 'quoteChar' represents a special character as a string.+-- * @quoteChar '^c'@ (where @^c@ is a control character) is @"^c"@+-- * Otherwise, @quoteChar@ returns "\hex", where 'hex' is the+-- hexadecimal number of the character.+quoteChar :: Char -> String+quoteChar c+ | isControl c && isPrintableAscii cHat = ['^', cHat]+ | otherwise = sHex+ where+ cHat = chr $ (bit 6 `xor`) $ ord c+ sHex = "<U+" ++ printf "%04X" c ++ ">"+++-- make colors and highlightings++-- | @'markEscape' policy doc@ marks @doc@ with the appropriate+-- marking for escaped characters according to @policy@+markEscape :: Policy -> Doc -> Doc+markEscape po | poAltColor po = makeInvert+ | poColor po = makeColor Red+ | otherwise = makeAsciiart++-- | @'color' policy color doc@ colors @doc@ with color @color@ if+-- @policy@ is not set to use an alternative to color. In that case,+-- it makes the text bold instead.+color :: Policy -> Color -> Doc -> Doc+color po | poAltColor po = \_ -> makeBold+ | otherwise = makeColor++makeColor, makeColor' :: Color -> Doc -> Doc++makeColor' = withColor . setColor++-- memoized version of makeColor'+makeColor Blue = makeColor' Blue+makeColor Red = makeColor' Red+makeColor Green = makeColor' Green+makeColor Cyan = makeColor' Cyan+makeColor Magenta = makeColor' Magenta++setColor :: Color -> String+setColor Blue = "\x1B[01;34m" -- bold blue+setColor Red = "\x1B[01;31m" -- bold red+setColor Green = "\x1B[01;32m" -- bold green+setColor Cyan = "\x1B[36m" -- light cyan+setColor Magenta = "\x1B[35m" -- light magenta++-- | @'makeAsciiart' doc@ tries to make @doc@ (usually a+-- single escaped char) stand out with the help of only plain+-- ascii, i.e., no color or font style.+makeAsciiart :: Doc -> Doc+makeAsciiart x = unsafeBothText "[_" <> x <> unsafeBothText "_]"++-- | the string to reset the terminal's color.+resetColor :: String+resetColor = "\x1B[00m"++-- | @'withColor' color doc@ returns a colorized version of @doc@.+-- @color@ is a string that represents a color, given by 'setColor'+withColor :: String -> Doc -> Doc+withColor c =+ let c' = unsafeBothText c+ r' = unsafeBothText resetColor+ in \x -> c' <> x <> r'+++-- | 'makeBold' boldens a doc.+makeBold :: Doc -> Doc+-- | 'makeInvert' returns an invert video version of a doc.+makeInvert :: Doc -> Doc+makeBold = withColor "\x1B[01m"+makeInvert = withColor "\x1B[07m"++environmentHelpColor :: ([String], [String])+environmentHelpColor = (["DARCS_DONT_COLOR", "DARCS_ALWAYS_COLOR",+ "DARCS_ALTERNATIVE_COLOR", "DARCS_DO_COLOR_LINES"],[+ "If the terminal understands ANSI color escape sequences, darcs will",+ "highlight certain keywords and delimiters when printing patches. This",+ "can be turned off by setting the environment variable DARCS_DONT_COLOR",+ "to 1. If you use a pager that happens to understand ANSI colors, like",+ "`less -R`, darcs can be forced always to highlight the output by setting",+ "DARCS_ALWAYS_COLOR to 1. If you can't see colors you can set",+ "DARCS_ALTERNATIVE_COLOR to 1, and darcs will use ANSI codes for bold",+ "and reverse video instead of colors. In addition, there is an",+ "extra-colorful mode, which is not enabled by default, which can be",+ "activated with DARCS_DO_COLOR_LINES"])++environmentHelpEscapeWhite :: ([String], [String])+environmentHelpEscapeWhite = ([ "DARCS_DONT_ESCAPE_TRAILING_SPACES",+ "DARCS_DONT_ESCAPE_TRAILING_CR"],[+ "By default darcs will escape (by highlighting if possible) any kind",+ "of spaces at the end of lines when showing patch contents.",+ "If you don't want this you can turn it off by setting",+ "DARCS_DONT_ESCAPE_TRAILING_SPACES to 1. A special case exists",+ "for only carriage returns: DARCS_DONT_ESCAPE_TRAILING_CR"])++environmentHelpEscape :: ([String], [String])+environmentHelpEscape = (["DARCS_DONT_ESCAPE_ANYTHING",+ "DARCS_DONT_ESCAPE_ISPRINT",+ "DARCS_DONT_ESCAPE_8BIT",+ "DARCS_DONT_ESCAPE_EXTRA",+ "DARCS_ESCAPE_EXTRA"],[+ "Darcs needs to escape certain characters when printing patch contents to",+ "a terminal. Characters like backspace can otherwise hide patch content",+ "from the user, and other character sequences can even in some cases",+ "redirect commands to the shell if the terminal allows it.",+ "",+ "By default darcs will only allow printable 7-bit ASCII",+ "characters (including space), and the two control characters tab and",+ "newline. All other octets are printed in quoted form (as `^<control letter>`",+ "or `\\<hex code>`).",+ "",+ "Darcs has some limited support for locales. If the system's locale is a ",+ "single-byte character encoding, like the Latin encodings, you can set the",+ "environment variable DARCS_DONT_ESCAPE_ISPRINT to 1 and darcs will display",+ "all the printables in the current system locale instead of just the ASCII",+ "ones. NOTE: This curently does not work on some architectures if darcs",+ "is compiled with GHC 6.4 or later. Some non-ASCII control characters might",+ "be printed and can possibly spoof the terminal.",+ "",+ "For multi-byte character encodings things are less smooth. UTF-8 will",+ "work if you set DARCS_DONT_ESCAPE_8BIT to 1, but non-printables outside",+ "the 7-bit ASCII range are no longer escaped. E.g., the extra control",+ "characters from Latin-1 might leave your terminal at the mercy of the",+ "patch contents. Space characters outside the 7-bit ASCII range are no",+ "longer recognized and will not be properly escaped at line endings.",+ "",+ "As a last resort you can set DARCS_DONT_ESCAPE_ANYTHING to 1. Then",+ "everything that doesn't flip code sets should work, and so will all the",+ "bells and whistles in your terminal. This environment variable can also",+ "be handy if you pipe the output to a pager or external filter that knows",+ "better than darcs how to handle your encoding. Note that all escaping,",+ "including the special escaping of any line ending spaces, will be turned",+ "off by this setting.",+ "",+ "There are two environment variables you can set to explicitly tell darcs",+ "to not escape or escape octets. They are DARCS_DONT_ESCAPE_EXTRA and",+ "DARCS_ESCAPE_EXTRA. Their values should be strings consisting of the",+ "verbatim octets in question. The do-escapes take precedence over the",+ "dont-escapes. Space characters are still escaped at line endings though.",+ "The special environment variable DARCS_DONT_ESCAPE_TRAILING_CR turns off",+ "escaping of carriage return last on the line (DOS style)."])
+ src/Darcs/Util/Progress.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE CPP #-}+++-- |+-- Module : Darcs.Util.Progress+-- Copyright : 2008 David Roundy+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable+--+-- Utility functions for tracking progress of long-running actions.++module Darcs.Util.Progress+ (+ beginTedious+ , endTedious+ , tediousSize+ , debugMessage+ , debugFail+ , withoutProgress+ , progress+ , progressKeepLatest+ , finishedOne+ , finishedOneIO+ , progressList+ , minlist+ , setProgressMode+ ) where+++import Prelude hiding (lookup)++import Control.Arrow ( second )+import Control.Exception ( bracket )+import Control.Monad ( when, unless, void )+import Control.Concurrent ( forkIO, threadDelay )++import Data.Char ( toLower )+import Data.Map ( Map, empty, adjust, insert, delete, lookup )+import Data.Maybe ( isJust )+import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )++import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn,+ hSetBuffering, hIsTerminalDevice,+ Handle, BufferMode(LineBuffering) )+import System.IO.Unsafe ( unsafePerformIO )++import Darcs.Util.Global ( withDebugMode, debugMessage, putTiming, debugFail )+++data ProgressData = ProgressData+ { sofar :: !Int+ , latest :: !(Maybe String)+ , total :: !(Maybe Int)+ }++handleProgress :: IO ()+handleProgress = do+ threadDelay 1000000+ handleMoreProgress "" 0+++handleMoreProgress :: String -> Int -> IO ()+handleMoreProgress k n = withProgressMode $ \m ->+ if m then do s <- getProgressLast+ mp <- getProgressData s+ case mp of+ Nothing -> do+ threadDelay 1000000+ handleMoreProgress k n+ Just p -> do+ when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p+ threadDelay 1000000+ handleMoreProgress s (sofar p)+ else do threadDelay 1000000+ handleMoreProgress k n+++printProgress :: String+ -> ProgressData+ -> IO ()+printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) =+ myput output output+ where+ output = k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued. " ++ l+printProgress k (ProgressData {latest=Just l}) =+ myput (k ++ " " ++ l) k+printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s =+ myput (k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued")+ (k ++ " " ++ show s)+printProgress k (ProgressData {sofar=s}) =+ myput (k ++ " " ++ show s) k+++myput :: String -> String -> IO ()+myput l s = withDebugMode $ \debugMode ->+ if debugMode+ then putTiming >> hPutStrLn stderr l+ else+ if '\n' `elem` l+ then myput (takeWhile (/= '\n') l) s+ else putTiming >> if length l < 80+ then simpleput l+ else simpleput (take 80 s)+++simpleput :: String -> IO ()+simpleput = unsafePerformIO $ mkhPutCr stderr+{-# NOINLINE simpleput #-}+++-- | @beginTedious k@ starts a tedious process and registers it in+-- '_progressData' with the key @k@. A tedious process is one for which we want+-- a progress indicator.+--+-- Wouldn't it be safer if it had type String -> IO ProgressDataKey, so that we+-- can ensure there is no collision? What happens if you call beginTedious twice+-- with the same string, without calling endTedious in the meantime?+beginTedious :: String -> IO ()+beginTedious k = do+ debugMessage $ "Beginning " ++ map toLower k+ setProgressData k ProgressData+ { sofar = 0+ , latest = Nothing+ , total = Nothing+ }+++-- | @endTedious k@ unregisters the tedious process with key @k@, printing+-- "Done" if such a tedious process exists.+endTedious :: String -> IO ()+endTedious k = whenProgressMode $ do+ p <- getProgressData k+ modifyIORef _progressData (second $ delete k)+ when (isJust p) $ debugMessage $ "Done " ++ map toLower k+++tediousSize :: String+ -> Int+ -> IO ()+tediousSize k s = updateProgressData k uptot+ where+ uptot p = case total p of+ Just t -> seq ts $ p { total = Just ts }+ where ts = t + s+ Nothing -> p { total = Just s }+++-- | XXX: document this constant+minlist :: Int+minlist = 4+++progressList :: String+ -> [a]+ -> [a]+progressList _ [] = []+progressList k (x:xs) = if l < minlist+ then x:xs+ else startit x : pl xs+ where+ l = length (x:xs)++ startit y = unsafePerformIO $ do+ beginTedious k+ tediousSize k l+ return y++ pl [] = []+ pl [y] = unsafePerformIO $ do+ endTedious k+ return [y]+ pl (y:ys) = progress k y : pl ys+++progress :: String+ -> a+ -> a+progress k a = unsafePerformIO $ progressIO k >> return a+++progressIO :: String -> IO ()+progressIO "" = return ()+progressIO k = do+ updateProgressData k $ \p ->+ p { sofar = sofar p + 1, latest = Nothing }+ putDebug k ""+++progressKeepLatest :: String+ -> a+ -> a+progressKeepLatest k a = unsafePerformIO $ progressKeepLatestIO k >> return a+++progressKeepLatestIO :: String -> IO ()+progressKeepLatestIO "" = return ()+progressKeepLatestIO k = do+ updateProgressData k (\p -> p {sofar = sofar p + 1})+ putDebug k ""+++finishedOne :: String -> String -> a -> a+finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a+++finishedOneIO :: String -> String -> IO ()+finishedOneIO "" _ = return ()+finishedOneIO k l = do+ updateProgressData k (\p -> p { sofar = sofar p + 1,+ latest = Just l })+ putDebug k l+++putDebug :: String+ -> String+ -> IO ()+putDebug _ _ = return ()+--putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k+--putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++l+++_progressMode :: IORef Bool+_progressMode = unsafePerformIO $ do+ hSetBuffering stderr LineBuffering+ newIORef True+{-# NOINLINE _progressMode #-}++_progressData :: IORef (String, Map String ProgressData)+_progressData = unsafePerformIO $ do+ _ <- forkIO handleProgress+ newIORef ("", empty)+{-# NOINLINE _progressData #-}++mkhPutCr :: Handle+ -> IO (String -> IO ())+mkhPutCr fe = do+ isTerm <- hIsTerminalDevice fe+ stdoutIsTerm <- hIsTerminalDevice stdout+ return $+ if isTerm+ then \s -> do+ hPutStr fe $ '\r':s ++ "\r"+ hFlush fe+ let spaces = '\r':replicate (length s) ' ' ++ "\r"+ hPutStr fe spaces+ when stdoutIsTerm $ putStr spaces+ else \s -> unless (null s) $ do hPutStrLn fe s+ hFlush fe++setProgressMode :: Bool -> IO ()+setProgressMode = writeIORef _progressMode++withoutProgress :: IO a -> IO a+withoutProgress job = bracket off restore (const job) where+ off = withProgressMode $ \m -> do+ debugMessage "Disabling progress reports..."+ setProgressMode False+ return m+ restore m = do+ if m then debugMessage "Reenabling progress reports."+ else debugMessage "Leaving progress reports off."+ setProgressMode m++updateProgressData :: String+ -> (ProgressData -> ProgressData)+ -> IO ()+updateProgressData k f =+ whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m))++setProgressData :: String+ -> ProgressData+ -> IO ()+setProgressData k p =+ whenProgressMode $ modifyIORef _progressData (second $ insert k p)++getProgressData :: String -> IO (Maybe ProgressData)+getProgressData k = withProgressMode $ \p ->+ if p+ then (lookup k . snd) `fmap` readIORef _progressData+ else return Nothing++getProgressLast :: IO String+getProgressLast = withProgressMode $ \p ->+ if p+ then fst `fmap` readIORef _progressData+ else return ""++whenProgressMode :: IO a -> IO ()+whenProgressMode j = withProgressMode $ const $ void j++withProgressMode :: (Bool -> IO a) -> IO a+withProgressMode job = (readIORef _progressMode) >>= job
+ src/Darcs/Util/Prompt.hs view
@@ -0,0 +1,102 @@+module Darcs.Util.Prompt+ (+ -- * User prompts+ askEnter+ , askUser+ , askUserListItem+ , PromptConfig(..)+ , promptYorn+ , promptChar+ ) where+++import Prelude hiding ( catch )++import Control.Monad ( void )++import Data.Char ( toUpper, toLower, isSpace )++import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine,+ getInputChar, outputStr, outputStrLn )++import Darcs.Util.Progress ( withoutProgress )++-- | Ask the user for a line of input.+askUser :: String -- ^ The prompt to display+ -> IO String -- ^ The string the user entered.+askUser prompt = withoutProgress $ runInputT defaultSettings $+ getInputLine prompt+ >>= maybe (error "askUser: unexpected end of input") return++-- | Ask the user to press Enter+askEnter :: String -- ^ The prompt to display+ -> IO ()+askEnter prompt = void $ askUser prompt++-- | @askUserListItem prompt xs@ enumerates @xs@ on the screen, allowing+-- the user to choose one of the items+askUserListItem :: String+ -> [String]+ -> IO String+askUserListItem prompt xs = withoutProgress $ runInputT defaultSettings $ do+ outputStr . unlines $ zipWith (\n x -> show n ++ ". " ++ x) [1::Int ..] xs+ loop+ where+ loop = do+ answer <- getInputLine prompt+ >>= maybe (error "askUser: unexpected end of input") return+ case maybeRead answer of+ Just n | n > 0 && n <= length xs -> return (xs !! (n-1))+ _ -> outputStrLn "Invalid response, try again!" >> loop+++maybeRead :: Read a+ => String+ -> Maybe a+maybeRead s = case reads s of+ [(x, rest)] | all isSpace rest -> Just x+ _ -> Nothing+++data PromptConfig = PromptConfig { pPrompt :: String+ , pBasicCharacters :: [Char]+ , pAdvancedCharacters :: [Char] -- ^ only shown on help+ , pDefault :: Maybe Char+ , pHelp :: [Char]+ }+++-- | Prompt the user for a yes or no+promptYorn :: String -> IO Bool+promptYorn p = (== 'y') `fmap` promptChar (PromptConfig p "yn" [] Nothing [])+++-- | Prompt the user for a character, among a list of possible ones.+-- Always returns a lowercase character. This is because the default+-- character (ie, the character shown in uppercase, that is automatically+-- selected when the user presses the space bar) is shown as uppercase,+-- hence users may want to enter it as uppercase.+promptChar :: PromptConfig -> IO Char+promptChar (PromptConfig p basic_chs adv_chs md help_chs) =+ withoutProgress $ runInputT defaultSettings loopChar+ where+ chs = basic_chs ++ adv_chs+ loopChar = do+ let chars = setDefault (basic_chs ++ (if null adv_chs then "" else "..."))+ prompt = p ++ " [" ++ chars ++ "]" ++ helpStr+ a <- getInputChar prompt >>= maybe (error "promptChar: unexpected end of input") (return . toLower)+ case () of+ _ | a `elem` chs -> return a+ | a == ' ' -> maybe tryAgain return md+ | a `elem` help_chs -> return a+ | otherwise -> tryAgain+ helpStr = case help_chs of+ [] -> ""+ (h:_) | null adv_chs -> ", or " ++ (h:" for help: ")+ | otherwise -> ", or " ++ (h:" for more options: ")+ tryAgain = do outputStrLn "Invalid response, try again!"+ loopChar+ setDefault s = case md of Nothing -> s+ Just d -> map (setUpper d) s+ setUpper d c = if d == c then toUpper c else c+
+ src/Darcs/Util/Ratified.hs view
@@ -0,0 +1,8 @@+-- | XXX: Perhaps a word of explanation here [WL]+module Darcs.Util.Ratified+ (+ readFile+ , hGetContents+ ) where++import System.IO( hGetContents )
+ src/Darcs/Util/Show.hs view
@@ -0,0 +1,16 @@+module Darcs.Util.Show+ ( appPrec, BSWrapper(..)+ ) where++import qualified Data.ByteString as B++appPrec :: Int+appPrec = 10++newtype BSWrapper = BSWrapper B.ByteString++instance Show BSWrapper where+ showsPrec d (BSWrapper bs) =+ showParen (d > appPrec) $+ showString "Data.ByteString.Char8.pack " .+ showsPrec (appPrec + 1) bs
+ src/Darcs/Util/SignalHandler.hs view
@@ -0,0 +1,142 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP, DeriveDataTypeable #-}++module Darcs.Util.SignalHandler+ ( withSignalsHandled, withSignalsBlocked,+ catchInterrupt, catchNonSignal,+ tryNonSignal, stdoutIsAPipe+ ) where++import Prelude hiding ( catch )++import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName )+import System.Exit ( exitWith, ExitCode ( ExitFailure ) )+import Control.Concurrent ( ThreadId, myThreadId )+import Control.Exception+ ( catch, throw, throwTo, mask,+ Exception(..), SomeException(..), IOException )+import System.Posix.Files ( getFdStatus, isNamedPipe )+import System.Posix.IO ( stdOutput )+import Data.Typeable ( Typeable, cast )+import Data.List ( isPrefixOf )+import System.IO ( hPutStrLn, stderr )+import Control.Monad ( unless )++import Darcs.Util.Workaround+ ( installHandler, raiseSignal, Handler(..), Signal+ , sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE )+#ifdef WIN32+import Darcs.Util.CtrlC ( withCtrlCHandler )+#endif++stdoutIsAPipe :: IO Bool+stdoutIsAPipe+ = catch+ (do stat <- getFdStatus stdOutput+ return (isNamedPipe stat))+ (\(_ :: IOException) -> return False)++withSignalsHandled :: IO a -> IO a+newtype SignalException = SignalException Signal deriving (Show, Typeable)++instance Exception SignalException where+ toException = SomeException+ fromException (SomeException e) = cast e++withSignalsHandled job = do+ thid <- myThreadId+ mapM_ (ih thid) [sigINT, sigHUP, sigABRT, sigTERM, sigPIPE]+ catchUserErrors (job' thid `catchSignal` defaults)+ die_with_string+ where defaults s | s == sigINT = ew s "Interrupted!"+ | s == sigHUP = ew s "HUP"+ | s == sigABRT = ew s "ABRT"+ | s == sigTERM = ew s "TERM"+ | s == sigPIPE = exitWith $ ExitFailure 1+ | otherwise = ew s "Unhandled signal!"+ ew sig s = do hPutStrLn stderr $ "withSignalsHandled: " ++ s+ resethandler sig+ raiseSignal sig -- ensure that our caller knows how we died+ exitWith $ ExitFailure 1+ die_with_string e | "STDOUT" `isPrefixOf` e =+ do is_pipe <- stdoutIsAPipe+ unless is_pipe $+ hPutStrLn stderr $ "\ndarcs failed: "++drop 6 e+ exitWith $ ExitFailure 2+ die_with_string e = do hPutStrLn stderr $ "\ndarcs failed: "++e+ exitWith $ ExitFailure 2+#ifdef WIN32+ job' thid =+ withCtrlCHandler (throwTo thid $ SignalException sigINT) job+#else+ job' _ = job+#endif++resethandler :: Signal -> IO ()+resethandler s = do _ <- installHandler s Default Nothing+ return ()++ih :: ThreadId -> Signal -> IO ()+ih thid s =+ do _ <- installHandler s (Catch $ throwTo thid $ SignalException s) Nothing+ return ()++catchSignal :: IO a -> (Signal -> IO a) -> IO a+catchSignal job handler =+ job `catch` (\(SignalException sig) -> handler sig)++-- | A drop-in replacement for 'Control.Exception.catch', which allows+-- us to catch anything but a signal. Useful for situations where we+-- don't want to inhibit ctrl-C.+catchNonSignal :: IO a -> (SomeException -> IO a) -> IO a+catchNonSignal comp handler = catch comp handler'+ where handler' se =+ case fromException se :: Maybe SignalException of+ Nothing -> handler se+ Just _ -> throw se++catchInterrupt :: IO a -> IO a -> IO a+catchInterrupt job handler =+ job `catchSignal` h+ where h s | s == sigINT = handler+ | otherwise = throw (SignalException s)++tryNonSignal :: IO a -> IO (Either SomeException a)+tryNonSignal j = (Right `fmap` j) `catchNonSignal` \e -> return (Left e)++catchUserErrors :: IO a -> (String -> IO a) -> IO a+catchUserErrors comp handler = catch comp handler'+ where handler' ioe+ | isUserError ioe = handler (ioeGetErrorString ioe)+ | ioeGetFileName ioe == Just "<stdout>" = handler ("STDOUT" ++ ioeGetErrorString ioe)+ | otherwise = throw ioe++withSignalsBlocked :: IO a -> IO a+withSignalsBlocked job = mask (\unmask -> job >>= \r ->+ unmask (return r) `catchSignal` couldnt_do r)+ where couldnt_do r s | s == sigINT = oops "interrupt" r+ | s == sigHUP = oops "HUP" r+ | s == sigABRT = oops "ABRT" r+ | s == sigALRM = oops "ALRM" r+ | s == sigTERM = oops "TERM" r+ | s == sigPIPE = return r+ | otherwise = oops "unknown signal" r+ oops s r = do hPutStrLn stderr $ "Couldn't handle " ++ s +++ " since darcs was in a sensitive job."+ return r
+ src/Darcs/Util/Ssh.hs view
@@ -0,0 +1,91 @@+--+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING. If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Util.Ssh+ (+ SshSettings(..)+ , defaultSsh+ , windows+ ) where+++import Control.Applicative ( (<$>), (<*>) )+import Control.Exception ( catch, catchJust, SomeException )+import Data.IORef ( IORef, newIORef, readIORef )+import Data.List ( isPrefixOf )+import System.Info ( os )+import System.IO.Unsafe (unsafePerformIO)+import System.IO.Error ( ioeGetErrorType, isDoesNotExistErrorType )+import System.Process ( readProcessWithExitCode )+import System.Environment ( getEnv )+import Prelude hiding (catch)++import Darcs.Util.Global ( whenDebugMode )++windows :: Bool+windows = "mingw" `isPrefixOf` os++data SshSettings = SshSettings+ { ssh :: String+ , scp :: String+ , sftp :: String+ } deriving (Show, Eq)+++_defaultSsh :: IORef SshSettings+_defaultSsh = unsafePerformIO $ newIORef =<< detectSsh+++-- | Expected properties:+--+-- * only ever runs once in the lifetime of the program+-- * environment variables override all+-- * tries Putty first on Windows+-- * falls back to plain old ssh+detectSsh :: IO SshSettings+detectSsh = do+ whenDebugMode (putStrLn "Detecting SSH settings")+ vanilla <- if windows+ then do+ plinkStr <- (snd3 <$> readProcessWithExitCode "plink" [] "")+ `catch` \(e :: SomeException) -> return (show e)+ whenDebugMode $ putStrLn $+ "SSH settings (plink): " +++ (concat . take 1 . lines $ plinkStr)+ if "PuTTY" `isPrefixOf` plinkStr+ then return (SshSettings "plink" "pscp -q" "psftp")+ else return rawVanilla+ else return rawVanilla+ settings <- SshSettings <$> fromEnv (ssh vanilla) "DARCS_SSH"+ <*> fromEnv (scp vanilla) "DARCS_SCP"+ <*> fromEnv (sftp vanilla) "DARCS_SFTP"+ whenDebugMode (putStrLn $ "SSH settings: " ++ show settings)+ return settings+ where+ snd3 (_, x, _) = x+ rawVanilla = SshSettings "ssh" "scp -q" "sftp"+ fromEnv :: String -> String -> IO String+ fromEnv d v = catchJust notFound+ (getEnv v)+ (const (return d))+ notFound e = if isDoesNotExistErrorType (ioeGetErrorType e)+ then Just ()+ else Nothing+++defaultSsh :: SshSettings+defaultSsh = unsafePerformIO $ readIORef _defaultSsh
+ src/Darcs/Util/Text.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++module Darcs.Util.Text+ (+ -- * Text construction.+ sentence+ -- * Text formatting.+ , formatText+ , formatParas+ , formatPara+ , chompTrailingNewline+ -- * Text processing+ , breakCommand+ ) where++import Control.Arrow ( first )+import Data.List ( intercalate )++import Darcs.Util.Printer ( Doc, (<>) )++sentence :: Doc -> Doc+sentence = (<> ".")++-- |Take a list of paragraphs and format them to the given line length, with+-- a blank line between paragraphs.+formatText :: Int -> [String] -> String+formatText linelen = unlines . formatParas linelen++formatParas :: Int -> [String] -> [String]+formatParas linelen = intercalate [""] .+ map (map unwords . formatPara linelen . words)++-- |Take a list of words and split it up so that each chunk fits into the specified width+-- when spaces are included. Any words longer than the specified width end up in a chunk+-- of their own.+formatPara :: Int -> [[a]] -> [[[a]]]+formatPara w = para'+ where para' [] = []+ para' xs = uncurry (:) $ para'' w xs+ para'' r (x:xs) | w == r || length x < r = first (x:) $ para'' (r - length x - 1) xs+ para'' _ xs = ([], para' xs)++breakCommand :: String -> (String, [String])+breakCommand s = case words s of+ (arg0:args) -> (arg0,args)+ [] -> (s,[])++chompTrailingNewline :: String -> String+chompTrailingNewline "" = ""+chompTrailingNewline s = if last s == '\n' then init s else s
+ src/Darcs/Util/URL.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}++{-+Copyright (C) 2004 David Roundy++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING. If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}++{-|++ Path resolving:++ * An http URL contains the sequence @\"http(s):\/\/\"@.++ * A local filepath does not contain colons, except+ as second character (windows drives) when this+ filepath is meant to be used as repository name++ * A path that is neither an http URL nor a local file+ is an ssh-path.++ Examples:++ > /usr/repo/foo -- local file+ > c:/src/darcs -- local file+ > http://darcs.net/ -- URL+ > peter@host:/path -- ssh+ > droundy@host: -- ssh+ > host:/path -- ssh++ This means that single-letter hosts in ssh-paths do not work,+ unless a username is provided.++ Perhaps ssh-paths should use @\"ssh:\/\/user\@host\/path\"@-syntax instead?+-}++module Darcs.Util.URL (+ isValidLocalPath, isHttpUrl, isSshUrl, isRelative, isAbsolute,+ isSshNopath, SshFilePath, sshRepo, sshUhost, sshFile, urlOf, splitSshUrl+ ) where++import Darcs.Util.Global(darcsdir)+import Data.List ( isPrefixOf, isInfixOf )+import Data.Char ( isSpace )+import qualified System.FilePath as FP (isRelative, isAbsolute, isValid)++#include "impossible.h"++isRelative :: String -> Bool+isRelative "" = bug "Empty filename in isRelative"+isRelative f = FP.isRelative f++isAbsolute :: String -> Bool+isAbsolute "" = bug "isAbsolute called with empty filename"+isAbsolute f = FP.isAbsolute f++isValidLocalPath :: String -> Bool+isValidLocalPath f@(_:_:fou) = ':' `notElem` fou && FP.isValid f+isValidLocalPath f = FP.isValid f++isHttpUrl :: String -> Bool+isHttpUrl u =+ let u' = dropWhile isSpace u in+ ("http://" `isPrefixOf` u') || ("https://" `isPrefixOf` u')+++isSshUrl :: String -> Bool+isSshUrl s = isu' (dropWhile isSpace s)+ where+ isu' s'+ | "ssh://" `isPrefixOf` s' = True+ | "://" `isInfixOf` s' = False+ | isValidLocalPath s' = False+ | otherwise = ":" `isInfixOf` s'++isSshNopath :: String -> Bool+isSshNopath s = case reverse s of+ ':':x@(_:_:_) -> ':' `notElem` x+ _ -> False++-- | Gives the (user, host, dir) out of an ssh url+splitSshUrl :: String -> SshFilePath+splitSshUrl s | "ssh://" `isPrefixOf` s =+ let s' = drop (length "ssh://") $ dropWhile isSpace s+ (dir, file) = cleanrepodir '/' s'+ in+ SshFP { sshUhost = takeWhile (/= '/') s'+ , sshRepo = dir+ , sshFile = file }+splitSshUrl s =+ let (dir, file) = cleanrepodir ':' s in+ SshFP { sshUhost = dropWhile isSpace $ takeWhile (/= ':') s+ , sshRepo = dir+ , sshFile = file }+++cleanrepourl :: String -> (String, String)+cleanrepourl zzz | dd `isPrefixOf` zzz = ([], drop (length dd) zzz)+ where dd = darcsdir++"/"+cleanrepourl (z:zs) =+ let (repo',file) = cleanrepourl zs in+ (z : repo', file)+cleanrepourl "" = ([],[])++cleanrepodir :: Char -> String -> (String, String)+cleanrepodir sep = cleanrepourl . drop 1 . dropWhile (/= sep)++data SshFilePath = SshFP { sshUhost :: String+ , sshRepo :: String+ , sshFile :: String}++urlOf :: SshFilePath -> String+urlOf (SshFP uhost dir file) = uhost ++ ":" ++ dir ++ "/" ++ darcsdir ++ "/" ++ file
+ src/Darcs/Util/Workaround.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}++-- |+-- Module : Darcs.Util.Workaround+-- Copyright : 2008 David Roundy <droundy@darcs.net>+-- License : GPL+-- Maintainer : darcs-devel@darcs.net+-- Stability : experimental+-- Portability : portable++module Darcs.Util.Workaround+ (+ renameFile+ , setExecutable+ , getCurrentDirectory+ , installHandler+ , raiseSignal+ , Handler(..)+ , Signal+ , sigINT+ , sigHUP+ , sigABRT+ , sigALRM+ , sigTERM+ , sigPIPE+ ) where++import Prelude hiding ( catch )++#ifdef WIN32++import Control.Monad ( unless )+import qualified System.Directory ( renameFile, getCurrentDirectory, removeFile )+import Control.Exception ( catch, IOException )+import qualified Control.Exception ( mask )+import qualified System.IO.Error ( isDoesNotExistError, ioError )++#else++import System.Posix.Signals(installHandler, raiseSignal, Handler(..), Signal,+ sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE)+import System.Directory ( renameFile, getCurrentDirectory )+import System.Posix.Files (fileMode,getFileStatus, setFileMode,+ setFileCreationMask,+ ownerReadMode, ownerWriteMode, ownerExecuteMode,+ groupReadMode, groupWriteMode, groupExecuteMode,+ otherReadMode, otherWriteMode, otherExecuteMode)+import Data.Bits ( (.&.), (.|.), complement )++#endif++#ifdef WIN32+-- Dummy implementation of POSIX signals+data Handler = Default+ | Ignore+ | Catch (IO ())++type Signal = Int++installHandler :: Signal+ -> Handler+ -> Maybe ()+ -> IO ()+installHandler _ _ _ = return ()+++raiseSignal :: Signal -> IO ()+raiseSignal _ = return ()+++sigINT :: Signal+sigINT = 0++-- not used: sigKILL = 0++sigHUP :: Signal+sigHUP = 0++-- not used: sigQUIT = 0++sigABRT :: Signal+sigABRT = 0++sigTERM :: Signal+sigTERM = 0++sigPIPE :: Signal+sigPIPE = 0++sigALRM :: Signal+sigALRM = 0+++-- | System.Directory.renameFile incorrectly fails when the new file already+-- exists. This code works around that bug at the cost of losing atomic+-- writes.+renameFile :: FilePath+ -> FilePath+ -> IO ()+renameFile old new = Control.Exception.mask $ \_ ->+ System.Directory.renameFile old new+ `catch` \(_ :: IOException) ->+ do System.Directory.removeFile new+ `catch`+ (\e -> unless (System.IO.Error.isDoesNotExistError e) $+ System.IO.Error.ioError e)+ System.Directory.renameFile old new+++setExecutable :: FilePath+ -> Bool+ -> IO ()+setExecutable _ _ = return ()+++-- | System.Directory.getCurrentDirectory returns a path with backslashes in it+-- under windows, and some of the code gets confused by that, so we override+-- getCurrentDirectory and translates '\\' to '/'+getCurrentDirectory :: IO FilePath+getCurrentDirectory = do+ d <- System.Directory.getCurrentDirectory+ return $ map rb d+ where+ rb '\\' = '/'+ rb c = c++#else+++setExecutable :: FilePath+ -> Bool+ -> IO ()+setExecutable f ex = do+ st <- getFileStatus f+ umask <- setFileCreationMask 0+ _ <- setFileCreationMask umask+ let rw = fileMode st .&.+ (ownerReadMode .|. ownerWriteMode .|.+ groupReadMode .|. groupWriteMode .|.+ otherReadMode .|. otherWriteMode)+ total = if ex then rw .|.+ ((ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode)+ .&. complement umask)+ else rw+ setFileMode f total++#endif
− src/Darcs/Utils.hs
@@ -1,528 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2-{-# LANGUAGE CPP, ForeignFunctionInterface #-}---- |--- Module : Exec--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable------ Various utility functions that do not belong anywhere else.--module Darcs.Utils- (- ortryrunning- , nubsort- , breakCommand- , showHexLen- , maybeGetEnv- , formatPath- -- * Monads- , firstJustIO- -- * User prompts- , askEnter- , askUser- , askUserListItem- , PromptConfig(..)- , promptYorn- , promptChar- -- * Text- , getViewer- , editFile- , runEditor- , stripCr- -- * Help- , environmentHelpEditor- , environmentHelpPager- -- * Errors and exceptions- , catchall- , clarifyErrors- , prettyException- , prettyError- , addToErrorLoc- -- * Files and directories- , getFileStatus- , withCurrentDirectory- , withUMask- -- * Locales- , setDarcsEncodings- , getSystemEncoding- , isUTF8Locale- -- * Tree filtering.- , filterFilePaths- , filterPaths- -- * Tree lookup.- , treeHas- , treeHasDir- , treeHasFile- , treeHasAnycase- ) where---import Prelude hiding ( catch )--import Control.Exception.Extensible- ( bracket, bracket_, catch, try,- IOException, SomeException, Exception(fromException) )-import Control.Monad ( when, forM )-import Control.Monad.Error( MonadError )-import Control.Monad.State.Strict( gets )--import qualified Data.ByteString as B ( readFile )-import qualified Data.ByteString.Char8 as BSC--import Data.Char ( toUpper, toLower, isSpace )-import Data.List ( group, sort )-import Data.Maybe ( isJust )--import Foreign.C.String ( CString, withCString, peekCString )-import Foreign.C.Error ( throwErrno )-import Foreign.C.Types ( CInt(..) )--#ifdef FORCE_CHAR8_ENCODING-import GHC.IO.Encoding ( setFileSystemEncoding, setForeignEncoding, char8 )-#endif--import Storage.Hashed.AnchoredPath( AnchoredPath(..), Name(..), isPrefix, floatPath )-import Storage.Hashed.Monad( withDirectory, fileExists, directoryExists- , virtualTreeMonad, currentDirectory- , TreeMonad )-import qualified Storage.Hashed.Monad as HS ( exists, tree )--import Storage.Hashed.Tree( Tree, listImmediate, findTree )--import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine,- getInputChar, outputStr, outputStrLn )-import System.Directory ( doesFileExist )-import System.Environment ( getEnv )-import System.Exit ( ExitCode(..) )-import System.IO.Error ( annotateIOError, isUserError, ioeGetErrorString- , isDoesNotExistError, ioeGetFileName )-import System.Posix.Files( getSymbolicLinkStatus, FileStatus )--import Text.Regex--import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )-import Darcs.SignalHandler ( catchNonSignal )--import Exec ( execInteractive )-import Numeric ( showHex )-import Progress ( withoutProgress )---showHexLen :: (Integral a, Show a)- => Int- -> a- -> String-showHexLen n x = let s = showHex x ""- in replicate (n - length s) ' ' ++ s---addToErrorLoc :: IOException- -> String- -> IOException-addToErrorLoc ioe s = annotateIOError ioe s Nothing Nothing---catchall :: IO a- -> IO a- -> IO a-a `catchall` b = a `catchNonSignal` (\_ -> b)---maybeGetEnv :: String- -> IO (Maybe String)-maybeGetEnv s = fmap Just (getEnv s) `catchall` return Nothing -- err can only be isDoesNotExist----- | The firstJustM returns the first Just entry in a list of monadic--- operations. This is close to `listToMaybe `fmap` sequence`, but the sequence--- operator evaluates all monadic members of the list before passing it along--- (i.e. sequence is strict). The firstJustM is lazy in that list member monads--- are only evaluated up to the point where the first Just entry is obtained.-firstJustM :: Monad m- => [m (Maybe a)]- -> m (Maybe a)-firstJustM [] = return Nothing-firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es)----- | The firstJustIO is a slight modification to firstJustM: the entries in the--- list must be IO monad operations and the firstJustIO will silently turn any--- monad call that throws an exception into Nothing, basically causing it to be--- ignored.-firstJustIO :: [IO (Maybe a)]- -> IO (Maybe a)-firstJustIO = firstJustM . map (`catchall` return Nothing)---clarifyErrors :: IO a- -> String- -> IO a-clarifyErrors a e = a `catch` (\x -> fail $ unlines [prettyException x,e])---prettyException :: SomeException- -> String-prettyException e | Just ioe <- fromException e, isUserError ioe = ioeGetErrorString ioe-prettyException e | Just ioe <- fromException e, isDoesNotExistError ioe =- case ioeGetFileName ioe of- Just f -> f ++ " does not exist"- Nothing -> show e-prettyException e = show e---prettyError :: IOError -> String-prettyError e | isUserError e = ioeGetErrorString e- | otherwise = show e----- | Given two shell commands as arguments, execute the former. The--- latter is then executed if the former failed because the executable--- wasn't found (code 127), wasn't executable (code 126) or some other--- exception occurred. Other failures (such as the user holding ^C)--- do not cause the second command to be tried.-ortryrunning :: IO ExitCode- -> IO ExitCode- -> IO ExitCode-a `ortryrunning` b = do- ret <- try a- case ret of- (Right (ExitFailure 126)) -> b -- command not executable- (Right (ExitFailure 127)) -> b -- command not found-#ifdef WIN32- (Right (ExitFailure 9009)) -> b -- command not found by cmd.exe on Windows-#endif- (Right x) -> return x -- legitimate success/failure- (Left (_ :: SomeException)) -> b -- an exception---withCurrentDirectory :: FilePathLike p- => p- -> IO a- -> IO a-withCurrentDirectory name m =- bracket- (do cwd <- getCurrentDirectory- when (toFilePath name /= "") (setCurrentDirectory name)- return cwd)- (\oldwd -> setCurrentDirectory oldwd `catchall` return ())- (const m)---foreign import ccall unsafe "umask.h set_umask" set_umask- :: CString -> IO CInt-foreign import ccall unsafe "umask.h reset_umask" reset_umask- :: CInt -> IO CInt---withUMask :: String- -> IO a- -> IO a-withUMask umask job =- do rc <- withCString umask set_umask- when (rc < 0) (throwErrno "Couldn't set umask")- bracket_- (return ())- (reset_umask rc)- job----- | Ask the user for a line of input.-askUser :: String -- ^ The prompt to display- -> IO String -- ^ The string the user entered.-askUser prompt = withoutProgress $ runInputT defaultSettings $- getInputLine prompt- >>= maybe (error "askUser: unexpected end of input") return---- | Ask the user to press Enter-askEnter :: String -- ^ The prompt to display- -> IO ()-askEnter prompt = askUser prompt >> return ()---- | @askUserListItem prompt xs@ enumerates @xs@ on the screen, allowing--- the user to choose one of the items-askUserListItem :: String- -> [String]- -> IO String-askUserListItem prompt xs = withoutProgress $ runInputT defaultSettings $ do- outputStr . unlines $ zipWith (\n x -> show n ++ ". " ++ x) [1::Int ..] xs- loop- where- loop = do- answer <- getInputLine prompt- >>= maybe (error "askUser: unexpected end of input") return- case maybeRead answer of- Just n | n > 0 && n <= length xs -> return (xs !! (n-1))- _ -> outputStrLn "Invalid response, try again!" >> loop---maybeRead :: Read a- => String- -> Maybe a-maybeRead s = case reads s of- [(x, rest)] | all isSpace rest -> Just x- _ -> Nothing---stripCr :: String- -> String-stripCr "" = ""-stripCr "\r" = ""-stripCr (c:cs) = c : stripCr cs----- | Format a path for screen output, so that the user sees where the path--- begins and ends. Could (should?) also warn about unprintable characters here.-formatPath :: String- -> String-formatPath path = "\"" ++ quote path ++ "\""- where quote "" = ""- quote (c:cs) = if c `elem` ['\\', '"']- then '\\':c:quote cs- else c:quote cs---breakCommand :: String -> (String, [String])-breakCommand s = case words s of- (arg0:args) -> (arg0,args)- [] -> (s,[])---nubsort :: Ord a- => [a]- -> [a]-nubsort = map head . group . sort----- | @editFile f@ lets the user edit a file which could but does not need to--- already exist. This function returns the exit code from the text editor and a--- flag indicating if the user made any changes.-editFile :: FilePathLike p- => p- -> IO (ExitCode, Bool)-editFile ff = do- old_content <- file_content- ec <- runEditor f- new_content <- file_content- return (ec, new_content /= old_content)- where- f = toFilePath ff- file_content = do- exists <- doesFileExist f- if exists then do content <- B.readFile f- return $ Just content- else return Nothing---runEditor :: FilePath- -> IO ExitCode-runEditor f = do- ed <- getEditor- execInteractive ed f- `ortryrunning` execInteractive "emacs" f- `ortryrunning` execInteractive "emacs -nw" f- `ortryrunning` execInteractive "nano" f-#ifdef WIN32- `ortryrunning` execInteractive "edit" f-#endif---getEditor :: IO String-getEditor = getEnv "DARCS_EDITOR" `catchall`- getEnv "DARCSEDITOR" `catchall`- getEnv "VISUAL" `catchall`- getEnv "EDITOR" `catchall` return "vi"---environmentHelpEditor :: ([String], [String])-environmentHelpEditor = (["DARCS_EDITOR", "DARCSEDITOR", "VISUAL", "EDITOR"],[- "To edit a patch description of email comment, Darcs will invoke an",- "external editor. Your preferred editor can be set as any of the",- "environment variables $DARCS_EDITOR, $DARCSEDITOR, $VISUAL or $EDITOR.",- "If none of these are set, vi(1) is used. If vi crashes or is not",- "found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are",- "each tried in turn."])---getViewer :: IO String-getViewer = getEnv "DARCS_PAGER" `catchall`- getEnv "PAGER" `catchall` return "less"--environmentHelpPager :: ([String], [String])-environmentHelpPager = (["DARCS_PAGER", "PAGER"],[- "Darcs will sometimes invoke a pager if it deems output to be too long",- "to fit onscreen. Darcs will use the pager specified by $DARCS_PAGER",- "or $PAGER. If neither are set, `less' will be used."])--data PromptConfig = PromptConfig { pPrompt :: String- , pBasicCharacters :: [Char]- , pAdvancedCharacters :: [Char] -- ^ only shown on help- , pDefault :: Maybe Char- , pHelp :: [Char]- }----- | Prompt the user for a yes or no-promptYorn :: [Char] -> IO Bool-promptYorn p = (== 'y') `fmap` promptChar (PromptConfig p "yn" [] Nothing [])---promptChar :: PromptConfig -> IO Char-promptChar (PromptConfig p basic_chs adv_chs md help_chs) =- withoutProgress $ runInputT defaultSettings loopChar- where- chs = basic_chs ++ adv_chs- loopChar = do- let chars = setDefault (basic_chs ++ (if null adv_chs then "" else "..."))- prompt = p ++ " [" ++ chars ++ "]" ++ helpStr- a <- getInputChar prompt >>= maybe (error "promptChar: unexpected end of input")- return- case () of- _ | a `elem` chs -> return a- | a == ' ' -> maybe tryAgain return md- | a `elem` help_chs -> return a- | otherwise -> tryAgain- helpStr = case help_chs of- [] -> ""- (h:_) | null adv_chs -> ", or " ++ (h:" for help: ")- | otherwise -> ", or " ++ (h:" for more options: ")- tryAgain = do outputStrLn "Invalid response, try again!"- loopChar- setDefault s = case md of Nothing -> s- Just d -> map (setUpper d) s- setUpper d c = if d == c then toUpper c else c----- | Construct a filter from a list of AnchoredPaths, that will accept any path--- that is either a parent or a child of any of the listed paths, and discard--- everything else.-filterPaths :: [AnchoredPath]- -> AnchoredPath- -> t- -> Bool-filterPaths files p _ = any (\x -> x `isPrefix` p || p `isPrefix` x) files----- | Same as 'filterPath', but for ordinary 'FilePath's (as opposed to--- AnchoredPath).-filterFilePaths :: [FilePath]- -> AnchoredPath- -> t- -> Bool-filterFilePaths = filterPaths . map floatPath---getFileStatus :: FilePath- -> IO (Maybe FileStatus)-getFileStatus f =- Just `fmap` getSymbolicLinkStatus f `catchall` return Nothing---treeHasAnycase :: (MonadError e m, Functor m, Monad m)- => Tree m- -> FilePath- -> m Bool-treeHasAnycase tree path =- fst `fmap` virtualTreeMonad (existsAnycase $ floatPath path) tree---existsAnycase :: (MonadError e m, Functor m, Monad m)- => AnchoredPath- -> TreeMonad m Bool-existsAnycase (AnchoredPath []) = return True-existsAnycase (AnchoredPath (Name x:xs)) = do- do wd <- currentDirectory- Just tree <- gets (flip findTree wd . HS.tree)- let subs = [ AnchoredPath [Name n] | (Name n, _) <- listImmediate tree,- BSC.map toLower n == BSC.map toLower x ]- or `fmap` forM subs (\path -> do- file <- fileExists path- if file then return True- else withDirectory path (existsAnycase $ AnchoredPath xs))---treeHas :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool-treeHas tree path = fst `fmap` virtualTreeMonad (HS.exists $ floatPath path) tree--treeHasDir :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool-treeHasDir tree path = fst `fmap` virtualTreeMonad (directoryExists $ floatPath path) tree--treeHasFile :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool-treeHasFile tree path = fst `fmap` virtualTreeMonad (fileExists $ floatPath path) tree---- | In some environments, darcs requires that certain global GHC library variables that--- control the encoding used in internal translations are set to specific values.------ @setDarcsEncoding@ enforces those settings, and should be called before the--- first time any darcs operation is run, and again if anything else might have--- set those encodings to different values.------ Note that it isn't thread-safe and has a global effect on your program.------ The current behaviour of this function is as follows, though this may--- change in future:------ Encodings are only set on GHC 7.4 and up, on any non-Windows platform.------ Two encodings are set, both to @GHC.IO.Encoding.char8@:--- @GHC.IO.Encoding.setFileSystemEncoding@ and @GHC.IO.Encoding.setForeignEncoding@.----setDarcsEncodings :: IO ()-setDarcsEncodings = do-#ifdef FORCE_CHAR8_ENCODING---- This is needed for appropriate behaviour from getArgs and from general--- filesystem calls (e.g. getDirectoryContents, readFile, ...)- setFileSystemEncoding char8---- This ensures that foreign calls made by hashed-storage to stat--- filenames returned from getDirectoryContents are translated appropriately- setForeignEncoding char8--#endif- return ()---- The following functions are copied from the encoding package (BSD3--- licence, by Henning Günther).---- | @getSystemEncoding@ fetches the current encoding from locale-foreign import ccall "system_encoding.h get_system_encoding"- get_system_encoding :: IO CString---getSystemEncoding :: IO String-getSystemEncoding = do- enc <- get_system_encoding- peekCString enc----- | @isUTF8@ checks if an encoding is UTF-8 (or ascii, since it is a--- subset of UTF-8).-isUTF8Locale :: String -> Bool-isUTF8Locale codeName = case (normalizeEncoding codeName) of- -- ASCII- "ascii" -> True- "646" -> True- "ansi_x3_4_1968" -> True- "ansi_x3.4_1986" -> True- "cp367" -> True- "csascii" -> True- "ibm367" -> True- "iso646_us" -> True- "iso_646.irv_1991" -> True- "iso_ir_6" -> True- "us" -> True- "us_ascii" -> True- -- UTF-8- "utf_8" -> True- "u8" -> True- "utf" -> True- "utf8" -> True- "utf8_ucs2" -> True- "utf8_ucs4" -> True- -- Everything else- _ -> False- where- normalizeEncoding s = map toLower $ subRegex sep s "_"- sep = mkRegex "[^0-9A-Za-z]+"
− src/Darcs/Witnesses/Eq.hs
@@ -1,54 +0,0 @@-#include "gadts.h"-module Darcs.Witnesses.Eq (- EqCheck(..), MyEq(..), isIsEq-) where--import Darcs.Witnesses.Unsafe ( unsafeCoerceP )---- |'EqCheck' is used to pass around evidence (or lack thereof) of--- two witness types being equal.-data EqCheck C(a b) where- IsEq :: EqCheck C(a a)- NotEq :: EqCheck C(a b)--instance Eq (EqCheck C(a b)) where- IsEq == IsEq = True- NotEq == NotEq = True- _ == _ = False--instance Show (EqCheck C(a b)) where- show IsEq = "IsEq"- show NotEq = "NotEq"---- |An witness aware equality class.--- A minimal definition defines any one of 'unsafeCompare', '=\/=' and '=/\='.-class MyEq p where- -- |It is unsafe to define a class instance via this method, because- -- if it returns True then the default implementations of '=\/=' and '=/\='- -- will coerce the equality of two witnesses.- --- -- Calling this method is safe, although '=\/=' or '=/\=' would be better- -- choices as it is not usually meaningul to compare two patches that- -- don't share either a starting or an ending context- unsafeCompare :: p C(a b) -> p C(c d) -> Bool- unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b)-- -- |Compare two things with the same starting witness. If the things- -- compare equal, evidence of the ending witnesses being equal will- -- be returned.- (=\/=) :: p C(a b) -> p C(a c) -> EqCheck C(b c)- a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq- | otherwise = NotEq-- -- |Compare two things with the same ending witness. If the things- -- compare equal, evidence of the starting witnesses being equal will- -- be returned.- (=/\=) :: p C(a c) -> p C(b c) -> EqCheck C(a b)- a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq- | otherwise = NotEq--infix 4 =\/=, =/\=--isIsEq :: EqCheck C(a b) -> Bool-isIsEq IsEq = True-isIsEq NotEq = False
− src/Darcs/Witnesses/Ordered.hs
@@ -1,301 +0,0 @@--- Copyright (C) 2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Witnesses.Ordered ( (:>)(..), (:<)(..), (:\/:)(..), (:/\:)(..), (:||:)(..),- FL(..), RL(..),- lengthFL, mapFL, mapFL_FL, spanFL, foldlFL, allFL, anyFL,- filterFL,- splitAtFL, splitAtRL, bunchFL, foldlRL,- lengthRL, isShorterThanRL, mapRL, mapRL_RL, zipWithFL,- filterFLFL,- filterRL,- reverseFL, reverseRL, (+>+), (+<+),- nullFL, concatFL, concatRL,- consRLSealed, nullRL, toFL,- dropWhileFL, dropWhileRL,- spanFL_M,- eqFL, eqFLRev, eqFLUnsafe- ) where--#include "impossible.h"-import Darcs.Witnesses.Show-import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal, Sealed(..), FreeLeft, unFreeLeft, Sealed2(..),- seal )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )--data (a1 :> a2) C(x y) = FORALL(z) (a1 C(x z)) :> (a2 C(z y))-infixr 1 :>-data (a1 :< a2) C(x y) = FORALL(z) (a1 C(z y)) :< (a2 C(x z))-infix 1 :<-infix 1 :/\:, :\/:, :||:-data (a1 :\/: a2) C(x y) = FORALL(z) (a1 C(z x)) :\/: (a2 C(z y))-data (a1 :/\: a2) C(x y) = FORALL(z) (a1 C(x z)) :/\: (a2 C(y z))-data (a1 :||: a2) C(x y) = (a1 C(x y)) :||: (a2 C(x y))--instance (Show2 a, Show2 b) => Show ( (a :> b) C(x y) ) where- showsPrec d (x :> y) = showOp2 1 ":>" d x y--instance (MyEq a, MyEq b) => MyEq (a :> b) where- (a1 :> b1) =\/= (a2 :> b2) | IsEq <- a1 =\/= a2 = b1 =\/= b2- | otherwise = NotEq--instance (MyEq a, MyEq b) => Eq ((a :> b) C(x y)) where- (==) = unsafeCompare--instance (MyEq a, MyEq b) => MyEq (a :< b) where- (a1 :< b1) =\/= (a2 :< b2) | IsEq <- b1 =\/= b2 = a1 =\/= a2- | otherwise = NotEq--instance (MyEq a, MyEq b) => Eq ((a :< b) C(x y)) where- (==) = unsafeCompare--instance (Show2 a, Show2 b) => Show2 (a :> b) where- showDict2 = ShowDictClass--instance (Show2 a, Show2 b) => Show ( (a :\/: b) C(x y) ) where- showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y--instance (Show2 a, Show2 b) => Show2 (a :\/: b) where- showDict2 = ShowDictClass--infixr 5 :>:, :<:, +>+, +<+---- forward list-data FL a C(x z) where- (:>:) :: a C(x y) -> FL a C(y z) -> FL a C(x z)- NilFL :: FL a C(x x)--instance Show2 a => Show (FL a C(x z)) where- showsPrec _ NilFL = showString "NilFL"- showsPrec d (x :>: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x .- showString " :>: " . showsPrec (prec + 1) xs- where prec = 5--instance Show2 a => Show1 (FL a C(x)) where- showDict1 = ShowDictClass--instance Show2 a => Show2 (FL a) where- showDict2 = ShowDictClass--instance Show2 a => Show (RL a C(x z)) where- showsPrec _ NilRL = showString "NilRL"- showsPrec d (x :<: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x .- showString " :<: " . showsPrec (prec + 1) xs- where prec = 5--instance Show2 a => Show1 (RL a C(x)) where- showDict1 = ShowDictClass--instance Show2 a => Show2 (RL a) where- showDict2 = ShowDictClass--instance (Show2 a, Show2 b) => Show1 ((a :> b) C(x)) where- showDict1 = ShowDictClass---- reverse list-data RL a C(x z) where- (:<:) :: a C(y z) -> RL a C(x y) -> RL a C(x z)- NilRL :: RL a C(x x)--nullFL :: FL a C(x z) -> Bool-nullFL NilFL = True-nullFL _ = False--nullRL :: RL a C(x z) -> Bool-nullRL NilRL = True-nullRL _ = False--filterFLFL :: (FORALL(x y) p C(x y) -> EqCheck C(x y)) -> FL p C(w z) -> FL p C(w z)-filterFLFL _ NilFL = NilFL-filterFLFL f (x:>:xs) | IsEq <- f x = filterFLFL f xs- | otherwise = x :>: filterFLFL f xs--filterRL :: (FORALL(x y) p C(x y) -> Bool) -> RL p C(a b) -> [Sealed2 p]-filterRL _ NilRL = []-filterRL f (x :<: xs) | f x = Sealed2 x : (filterRL f xs)- | otherwise = filterRL f xs--(+>+) :: FL a C(x y) -> FL a C(y z) -> FL a C(x z)-NilFL +>+ ys = ys-(x:>:xs) +>+ ys = x :>: xs +>+ ys--(+<+) :: RL a C(y z) -> RL a C(x y) -> RL a C(x z)-NilRL +<+ ys = ys-(x:<:xs) +<+ ys = x :<: xs +<+ ys--reverseFL :: FL a C(x z) -> RL a C(x z)-reverseFL xs = r NilRL xs- where r :: RL a C(l m) -> FL a C(m o) -> RL a C(l o)- r ls NilFL = ls- r ls (a:>:as) = r (a:<:ls) as--reverseRL :: RL a C(x z) -> FL a C(x z)-reverseRL xs = r NilFL xs -- r (xs :> NilFL)- where r :: FL a C(m o) -> RL a C(l m) -> FL a C(l o)- r ls NilRL = ls- r ls (a:<:as) = r (a:>:ls) as--concatFL :: FL (FL a) C(x z) -> FL a C(x z)-concatFL NilFL = NilFL-concatFL (a:>:as) = a +>+ concatFL as--concatRL :: RL (RL a) C(x z) -> RL a C(x z)-concatRL NilRL = NilRL-concatRL (a:<:as) = a +<+ concatRL as--spanFL :: (FORALL(w y) a C(w y) -> Bool) -> FL a C(x z) -> (FL a :> FL a) C(x z)-spanFL f (x:>:xs) | f x = case spanFL f xs of- ys :> zs -> (x:>:ys) :> zs-spanFL _ xs = NilFL :> xs--spanFL_M :: forall a m C(x z). Monad m =>- (FORALL(w y) a C(w y) -> m Bool) -> FL a C(x z)- -> m ((FL a :> FL a) C(x z))-spanFL_M f (x:>:xs) =- do- continue <- f x- if continue- then do (ys :> zs) <- spanFL_M f xs- return $ (x :>: ys) :> zs- else return $ NilFL :> (x :>: xs)--spanFL_M _ (NilFL) = return $ NilFL :> NilFL--splitAtFL :: Int -> FL a C(x z) -> (FL a :> FL a) C(x z)-splitAtFL 0 xs = NilFL :> xs-splitAtFL _ NilFL = NilFL :> NilFL-splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of- (xs':>xs'') -> (x:>:xs' :> xs'')--splitAtRL :: Int -> RL a C(x z) -> (RL a :< RL a) C(x z)-splitAtRL 0 xs = NilRL :< xs-splitAtRL _ NilRL = NilRL :< NilRL-splitAtRL n (x:<:xs) = case splitAtRL (n-1) xs of- (xs':<xs'') -> (x:<:xs' :< xs'')---- 'bunchFL n' groups patches into batches of n, except that it always puts--- the first patch in its own group, this being a recognition that the--- first patch is often *very* large.--bunchFL :: Int -> FL a C(x y) -> FL (FL a) C(x y)-bunchFL _ NilFL = NilFL-bunchFL n (x:>:xs) = (x :>: NilFL) :>: bFL xs- where bFL :: FL a C(x y) -> FL (FL a) C(x y)- bFL NilFL = NilFL- bFL bs = case splitAtFL n bs of- a :> b -> a :>: bFL b---allFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool-allFL f xs = and $ mapFL f xs--anyFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool-anyFL f xs = or $ mapFL f xs--foldlFL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> FL b C(x z) -> a-foldlFL _ x NilFL = x-foldlFL f x (y:>:ys) = foldlFL f (f x y) ys--foldlRL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> RL b C(x z) -> a-foldlRL _ x NilRL = x-foldlRL f x (y:<:ys) = foldlRL f (f x y) ys--mapFL_FL :: (FORALL(w y) a C(w y) -> b C(w y)) -> FL a C(x z) -> FL b C(x z)-mapFL_FL _ NilFL = NilFL-mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as--zipWithFL :: (FORALL(x y) a -> p C(x y) -> q C(x y))- -> [a] -> FL p C(w z) -> FL q C(w z)-zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys-zipWithFL _ _ NilFL = NilFL-zipWithFL _ [] (_:>:_) = bug "zipWithFL called with too short a list"--mapRL_RL :: (FORALL(w y) a C(w y) -> b C(w y)) -> RL a C(x z) -> RL b C(x z)-mapRL_RL _ NilRL = NilRL-mapRL_RL f (a:<:as) = f a :<: mapRL_RL f as--mapFL :: (FORALL(w z) a C(w z) -> b) -> FL a C(x y) -> [b]-mapFL _ NilFL = []-mapFL f (a :>: b) = f a : mapFL f b--filterFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> [Sealed2 a]-filterFL _ NilFL = []-filterFL f (a :>: b) = if f a- then (Sealed2 a):(filterFL f b)- else filterFL f b--mapRL :: (FORALL(w z) a C(w z) -> b) -> RL a C(x y) -> [b]-mapRL _ NilRL = []-mapRL f (a :<: b) = f a : mapRL f b--lengthFL :: FL a C(x z) -> Int-lengthFL xs = l xs 0- where l :: FL a C(x z) -> Int -> Int- l NilFL n = n- l (_:>:as) n = l as $! n+1--lengthRL :: RL a C(x z) -> Int-lengthRL xs = l xs 0- where l :: RL a C(x z) -> Int -> Int- l NilRL n = n- l (_:<:as) n = l as $! n+1--isShorterThanRL :: RL a C(x y) -> Int -> Bool-isShorterThanRL _ n | n <= 0 = False-isShorterThanRL NilRL _ = True-isShorterThanRL (_:<:xs) n = isShorterThanRL xs (n-1)--consRLSealed :: a C(y z) -> FlippedSeal (RL a) C(y) -> FlippedSeal (RL a) C(z)-consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as--toFL :: [FreeLeft a] -> Sealed (FL a C(x))-toFL [] = Sealed NilFL-toFL (x:xs) = case unFreeLeft x of Sealed y -> case toFL xs of Sealed ys -> Sealed (y :>: ys)--dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v)-dropWhileFL _ NilFL = flipSeal NilFL-dropWhileFL p xs@(x:>:xs')- | p x = dropWhileFL p xs'- | otherwise = flipSeal xs--dropWhileRL :: (FORALL(x y) a C(x y) -> Bool) -> RL a C(r v) -> Sealed (RL a C(r))-dropWhileRL _ NilRL = seal NilRL-dropWhileRL p xs@(x:<:xs')- | p x = dropWhileRL p xs'- | otherwise = seal xs---- |Check that two 'FL's are equal element by element.--- This differs from the 'MyEq' instance for 'FL' which--- uses commutation.-eqFL :: MyEq a => FL a C(x y) -> FL a C(x z) -> EqCheck C(y z)-eqFL NilFL NilFL = IsEq-eqFL (x:>:xs) (y:>:ys) | IsEq <- x =\/= y, IsEq <- eqFL xs ys = IsEq-eqFL _ _ = NotEq--eqFLRev :: MyEq a => FL a C(x z) -> FL a C(y z) -> EqCheck C(x y)-eqFLRev NilFL NilFL = IsEq-eqFLRev (x:>:xs) (y:>:ys) | IsEq <- eqFLRev xs ys, IsEq <- x =/\= y = IsEq-eqFLRev _ _ = NotEq--eqFLUnsafe :: MyEq a => FL a C(x y) -> FL a C(z w) -> Bool-eqFLUnsafe NilFL NilFL = True-eqFLUnsafe (x:>:xs) (y:>:ys) = unsafeCompare x y && eqFLUnsafe xs ys-eqFLUnsafe _ _ = False
− src/Darcs/Witnesses/Sealed.hs
@@ -1,153 +0,0 @@--- Copyright (C) 2007 David Roundy, 2009 Ganesh Sittampalam------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, FlexibleInstances #-}--#include "gadts.h"--module Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal,- unsafeUnseal, unsafeUnsealFlipped, unsafeUnseal2,- Sealed2(..), seal2, unseal2, mapSeal2,- FlippedSeal(..), flipSeal, unsealFlipped, mapFlipped,- unsealM, liftSM,- Gap(..), FreeLeft, unFreeLeft, FreeRight, unFreeRight- ) where-import Darcs.Witnesses.Eq ( MyEq, EqCheck(..) )-import Darcs.Witnesses.Show-import Darcs.Witnesses.Eq ( (=\/=) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP1, unsafeCoerceP )--data Sealed a where- Sealed :: a C(x ) -> Sealed a--seal :: a C(x ) -> Sealed a-seal = Sealed--instance MyEq a => Eq (Sealed (a C(x ))) where- Sealed x == Sealed y | IsEq <- x =\/= y = True- | otherwise = False--data Sealed2 a where- Sealed2 :: !(a C(x y )) -> Sealed2 a--seal2 :: a C(x y ) -> Sealed2 a-seal2 = Sealed2--data FlippedSeal a C(y) where- FlippedSeal :: !(a C(x y)) -> FlippedSeal a C(y)--flipSeal :: a C(x y) -> FlippedSeal a C(y)-flipSeal = FlippedSeal--unsafeUnseal :: Sealed a -> a C(x)-unsafeUnseal (Sealed a) = unsafeCoerceP1 a--unsafeUnsealFlipped :: FlippedSeal a C(y) -> a C(x y)-unsafeUnsealFlipped (FlippedSeal a) = unsafeCoerceP a--unsafeUnseal2 :: Sealed2 a -> a C(x y)-unsafeUnseal2 (Sealed2 a) = unsafeCoerceP a--unseal :: (FORALL(x) a C(x ) -> b) -> Sealed a -> b-unseal f x = f (unsafeUnseal x)---- laziness property:--- unseal (const True) undefined == True--unsealM :: Monad m => m (Sealed a) -> (FORALL(x) a C(x) -> m b) -> m b-unsealM m1 m2 = do sx <- m1- unseal m2 sx--liftSM :: Monad m => (FORALL(x) a C(x) -> b) -> m (Sealed a) -> m b-liftSM f m = do sx <- m- return (unseal f sx)--mapSeal :: (FORALL(x) a C(x ) -> b C(x )) -> Sealed a -> Sealed b-mapSeal f = unseal (seal . f)--mapFlipped :: (FORALL(x) a C(x y) -> b C(x z)) -> FlippedSeal a C(y) -> FlippedSeal b C(z)-mapFlipped f (FlippedSeal x) = FlippedSeal (f x)--unseal2 :: (FORALL(x y) a C(x y ) -> b) -> Sealed2 a -> b-unseal2 f a = f (unsafeUnseal2 a)--mapSeal2 :: (FORALL(x y) a C(x y ) -> b C(x y )) -> Sealed2 a -> Sealed2 b-mapSeal2 f = unseal2 (seal2 . f)--unsealFlipped :: (FORALL(x y) a C(x y) -> b) -> FlippedSeal a C(z) -> b-unsealFlipped f (FlippedSeal a) = f a--instance Show1 a => Show (Sealed a) where- showsPrec d (Sealed x) = showParen (d > appPrec) $ showString "Sealed " . showsPrec1 (appPrec + 1) x-instance Show2 a => Show (Sealed2 a) where- showsPrec d (Sealed2 x) = showParen (d > appPrec) $ showString "Sealed2 " . showsPrec2 (appPrec + 1) x---- |'Poly' is similar to 'Sealed', but the type argument is--- universally quantified instead of being existentially quantified.-newtype Poly a = Poly { unPoly :: FORALL(x) a C(x) }---- |'Stepped' is a type level composition operator.--- For example, 'Stepped Sealed p' is equivalent to 'lambda x . Sealed (p x)'-newtype Stepped (f :: SEALEDPATCHKIND -> *) a C(x) = Stepped { unStepped :: f (a C(x)) }---- |'FreeLeft p' is '\forall x . \exists y . p x y'--- In other words the caller is free to specify the left witness,--- and then the right witness is an existential.--- Note that the order of the type constructors is important for ensuring--- that 'y' is dependent on the 'x' that is supplied.--- This is why 'Stepped' is needed, rather than writing the more obvious--- 'Sealed (Poly p)' which would notionally have the same quantification--- of the type witnesses.-newtype FreeLeft p = FLInternal (Poly (Stepped Sealed p))---- |'FreeLeft p' is '\forall y . \exists x . p x y'--- In other words the caller is free to specify the right witness,--- and then the left witness is an existential.--- Note that the order of the type constructors is important for ensuring--- that 'x' is dependent on the 'y' that is supplied.-newtype FreeRight p = FRInternal (Poly (FlippedSeal p))---- |Unwrap a 'FreeLeft' value-unFreeLeft :: FreeLeft p -> Sealed (p C(x))-unFreeLeft (FLInternal x) = unStepped (unPoly x)---- |Unwrap a 'FreeRight' value-unFreeRight :: FreeRight p -> FlippedSeal p C(x)-unFreeRight (FRInternal x) = unPoly x---- |'Gap' abstracts over 'FreeLeft' and 'FreeRight' for code constructing these values-class Gap w where- -- |An empty 'Gap', e.g. 'NilFL' or 'NilRL'- emptyGap :: (FORALL(x) p C(x x)) -> w p- -- |A 'Gap' constructed from a completely polymorphic value, for example the constructors- -- for primitive patches- freeGap :: (FORALL(x y) p C(x y)) -> w p-- -- |Compose two 'Gap' values together in series, e.g. 'joinGap (+>+)' or 'joinGap (:>:)'- joinGap :: (FORALL(x y z) p C(x y) -> q C(y z) -> r C(x z)) -> w p -> w q -> w r--instance Gap FreeLeft where- emptyGap e = FLInternal (Poly (Stepped (Sealed e)))- freeGap e = FLInternal (Poly (Stepped (Sealed e)))- joinGap op (FLInternal p) (FLInternal q)- = FLInternal (Poly (case unPoly p of Stepped (Sealed p') -> case unPoly q of Stepped (Sealed q') -> Stepped (Sealed (p' `op` q'))))--instance Gap FreeRight where- emptyGap e = FRInternal (Poly (FlippedSeal e))- freeGap e = FRInternal (Poly (FlippedSeal e))- joinGap op (FRInternal p) (FRInternal q)- = FRInternal (Poly (case unPoly q of FlippedSeal q' -> case unPoly p of FlippedSeal p' -> FlippedSeal (p' `op` q')))
− src/Darcs/Witnesses/Show.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE CPP #-}--module Darcs.Witnesses.Show(ShowDict(..), showD, showListD, showsPrecD,- Show1(..), Show2(..), show1, showsPrec1, show2, showsPrec2, showOp2, appPrec) where--#include "gadts.h"--data ShowDict a where- ShowDictClass :: Show a => ShowDict a- ShowDictRecord :: (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> ShowDict a--showsPrecD :: ShowDict a -> Int -> a -> ShowS-showsPrecD ShowDictClass = showsPrec-showsPrecD (ShowDictRecord showsPrecR _ _) = showsPrecR--showD :: ShowDict a -> a -> String-showD ShowDictClass = show-showD (ShowDictRecord _ showR _) = showR--showListD :: ShowDict a -> [a] -> ShowS-showListD ShowDictClass = showList-showListD (ShowDictRecord _ _ showListR) = showListR--class Show1 a where- showDict1 :: ShowDict (a C(x))--showsPrec1 :: Show1 a => Int -> a C(x) -> ShowS-showsPrec1 = showsPrecD showDict1--show1 :: Show1 a => a C(x) -> String-show1 = showD showDict1--class Show2 a where- showDict2 :: ShowDict (a C(x y))--showsPrec2 :: Show2 a => Int -> a C(x y) -> ShowS-showsPrec2 = showsPrecD showDict2--show2 :: Show2 a => a C(x y) -> String-show2 = showD showDict2--showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a C(w x) -> b C(y z) -> String -> String-showOp2 prec opstr d x y = showParen (d > prec) $ showsPrec2 (prec + 1) x .- showString opstr . showsPrec2 (prec + 1) y--appPrec :: Int-appPrec = 10
− src/Darcs/Witnesses/Unsafe.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE MagicHash #-}-#include "gadts.h"-module Darcs.Witnesses.Unsafe (- unsafeCoerceP, unsafeCoercePStart,- unsafeCoercePEnd, unsafeCoerceP2,- unsafeCoerceP1-) where--import GHC.Base (unsafeCoerce#)--unsafeCoerceP :: a C(x y) -> a C(b c)-unsafeCoerceP = unsafeCoerce#--unsafeCoercePStart :: a C(x1 y) -> a C(x2 y)-unsafeCoercePStart = unsafeCoerce#--unsafeCoercePEnd :: a C(x y1) -> a C(x y2)-unsafeCoercePEnd = unsafeCoerce#--unsafeCoerceP2 :: t C(w x y z) -> t C(a b c d)-unsafeCoerceP2 = unsafeCoerce#--unsafeCoerceP1 :: a C(x) -> a C(y)-unsafeCoerceP1 = unsafeCoerce#
− src/Darcs/Witnesses/WZipper.hs
@@ -1,82 +0,0 @@--- Copyright (C) 2009 Florent Becker------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"-module Darcs.Witnesses.WZipper ( FZipper(..), focus, leftmost, left- , rightmost, right, jokers, clowns- , flToZipper, lengthFZ, nullFZ- , toEnd, toStart- )-where-import Darcs.Witnesses.Ordered ( FL(..), RL(..), nullFL, nullRL- , lengthFL, lengthRL, (+<+)- , reverseFL, reverseRL, (+>+)- )-import Darcs.Witnesses.Sealed(Sealed2(..), Sealed(..), FlippedSeal(..))---- forward zipper-data FZipper a C(x z) where- FZipper :: RL a C(x y) -> FL a C(y z) -> FZipper a C(x z)---- Constructors-flToZipper :: FL a C(x y) -> FZipper a C(x y)-flToZipper l = FZipper NilRL l----destructors-nullFZ :: FZipper a C(x y) -> Bool-nullFZ (FZipper l r) = nullRL l && nullFL r--lengthFZ :: FZipper a C(x y) -> Int-lengthFZ (FZipper l r) = lengthRL l + lengthFL r--focus :: FZipper a C(x y) -> Maybe (Sealed2 a)-focus (FZipper _ (x :>: _)) = Just $ Sealed2 x-focus _ = Nothing---- | \"Clowns to the left of me, jokers to the right. Here I am, stuck--- in the middle of you\"--- <http://en.wikipedia.org/wiki/Stuck_in_the_Middle>-clowns :: FZipper a C(x y) -> Sealed ((RL a) C(x))-clowns (FZipper l _) = Sealed l---- | See 'clowns'-jokers :: FZipper a C(x y) -> FlippedSeal (FL a) C(y)-jokers (FZipper _ r) = FlippedSeal r--rightmost :: FZipper p C(x y) -> Bool-rightmost (FZipper _ NilFL) = True-rightmost _ = False--right :: FZipper p C(x y) -> FZipper p C(x y)-right (FZipper l (b:>:r)) = FZipper (b :<: l) r-right x@(FZipper _ NilFL) = x--leftmost :: FZipper p C(x y) -> Bool-leftmost (FZipper NilRL _) = True-leftmost _ = False--left :: FZipper p C(x y) -> FZipper p C(x y)-left (FZipper (b :<: l) r) = FZipper l (b :>: r)-left x@(FZipper NilRL _) = x--toEnd :: FZipper p C(x y) -> FZipper p C(x y)-toEnd (FZipper l r) = FZipper (reverseFL r +<+ l) NilFL--toStart :: FZipper p C(x y) -> FZipper p C(x y)-toStart (FZipper l r) = FZipper NilRL ((reverseRL l) +>+ r)
− src/DateMatcher.hs
@@ -1,188 +0,0 @@--- Copyright (C) 2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE ExistentialQuantification #-}---- |--- Module : DateMatcher--- Copyright : 2004 David Roundy--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module DateMatcher (- parseDateMatcher- -- for debugging only- , DateMatcher(..)- , getMatchers- ) where--import Control.Exception.Extensible ( catch, throw )-import Data.Maybe ( isJust )-import Prelude hiding ( catch )--import System.IO.Error ( isUserError, ioeGetErrorString )-import System.Time-import Text.ParserCombinators.Parsec ( eof, parse, ParseError )--import IsoDate ( parseDate, englishDateTime, englishInterval, englishLast,- iso8601Interval, resetCalendar, subtractFromMCal, getLocalTz,- MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime,- unsetTime- )---- | 'withinDay' @x y@ is true if @x <= y < (x + one_day)@--- Note that this converts the two dates to @ClockTime@ to avoid--- any timezone-related errors-withinDay :: CalendarTime -> CalendarTime -> Bool-withinDay a b = within (Just $ toClockTime a)- (Just (addToClockTime day $ toClockTime a))- (toClockTime b)- where- day = TimeDiff 0 0 1 0 0 0 0---- | 'dateRange' @x1 x2 y@ is true if @x1 <= y < x2@--- Since @x1@ and @x2@ can be underspecified, we simply assume the--- first date that they could stand for.-dateRange :: Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool-dateRange a b = cDateRange (fmap unsafeToCalendarTime a)- (fmap unsafeToCalendarTime b)---- | 'cDateRange' @x1 x2 y@ is true if @x1 <= y < x2@-cDateRange :: Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool-cDateRange a b c = within (fmap toClockTime a)- (fmap toClockTime b) (toClockTime c)---- | 'within' @x1 x2 y@ is true if @x1 <= y < x2@-within :: Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool-within (Just start) (Just end) time = start <= time && time < end-within Nothing (Just end) time = time < end-within (Just start) Nothing time = start <= time-within _ _ _ = undefined---- | 'samePartialDate' @range exact@ is true if @exact@ falls--- within the a range of dates represented by @range@.--- The purpose of this function is to support matching on partially--- specified dates. That is, if you only specify the date 2007,--- this function should match any dates within that year. On the--- other hand, if you specify 2007-01, this function will match any--- dates within that month. This function only matches up to the--- second.-samePartialDate :: MCalendarTime -> CalendarTime -> Bool-samePartialDate a b_ =- within (Just clockA)- (Just $ addToClockTime interval clockA)- (toClockTime calB)- where- interval- | isJust (mctSec a) = second- | isJust (mctMin a) = minute- | isJust (mctHour a) = hour- | isJust (mctYDay a) = day- | mctWeek a = maybe week (const day) (mctWDay a)- | isJust (mctDay a) = day- | isJust (mctMonth a) = month- | otherwise = year- year = TimeDiff 1 0 0 0 0 0 0- month = TimeDiff 0 1 0 0 0 0 0- week = TimeDiff 0 0 7 0 0 0 0- day = TimeDiff 0 0 1 0 0 0 0- hour = TimeDiff 0 0 0 1 0 0 0- minute = TimeDiff 0 0 0 0 1 0 0- second = TimeDiff 0 0 0 0 0 1 0- clockA = toClockTime $ unsafeToCalendarTime a- calB = resetCalendar b_---- | A 'DateMatcher' combines a potential parse for a date string--- with a "matcher" function that operates on a given date.--- We use an existential type on the matcher to allow--- the date string to either be interpreted as a point in time--- or as an interval.-data DateMatcher = forall d . (Show d) => DM- String -- name- (Either ParseError d) -- parser- (d -> CalendarTime -> Bool) -- matcher---- | 'parseDateMatcher' @s@ return the first matcher in--- 'getMatchers' that can parse 's'-parseDateMatcher :: String -> IO (CalendarTime -> Bool)-parseDateMatcher d = testDateMatcher `catchUserError` handleError- where- catchUserError comp handler = catch comp $ \e ->- if isUserError e then handler (ioeGetErrorString e) else throw e-- -- If the user enters a date > maxint seconds ago, the toClockTime- -- function cannot work.- handleError e = if e == "Time.toClockTime: invalid input"- then error "Can't handle dates that far back!"- else error e-- -- Hack: test the matcher against the current date and discard the results.- -- We just want to make sure it won't throw any exceptions when we use it- -- for real.- testDateMatcher = do- matcher <- tryMatchers `fmap` getMatchers d- matcher `fmap` now >>= (`seq` return matcher)---- | 'getMatchers' @d@ returns the list of matchers that will be--- applied on @d@. If you wish to extend the date parsing code,--- this will likely be the function that you modify to do so.-getMatchers :: String -> IO [DateMatcher]-getMatchers d = do- rightNow <- now- let midnightToday = unsetTime rightNow- mRightNow = toMCalendarTime rightNow- matchIsoInterval (Left dur) =- let durAgo = dur `subtractFromMCal` mRightNow in- dateRange (Just durAgo) (Just mRightNow)- matchIsoInterval (Right (a,b)) = dateRange (Just a) (Just b)- tzNow <- getLocalTz- return- -- note that the order of these is quite important as some matchers can- -- match the same date.- [ DM "from English date"- (parseDateWith $ englishLast midnightToday)- (\(a,_) -> cDateRange (Just a) Nothing)- , DM "specific English date"- (parseDateWith $ englishDateTime midnightToday)- withinDay- , DM "English interval"- (parseDateWith $ englishInterval rightNow)- (uncurry cDateRange)- , DM "ISO 8601 interval"- (parseDateWith $ iso8601Interval tzNow)- matchIsoInterval- , DM "CVS, ISO 8601, or old style date"- (parseDate tzNow d)- samePartialDate- ]- where- tillEof p = do { x <- p; eof; return x }- parseDateWith p = parse (tillEof p) "" d---- | 'tryMatchers' @ms@ returns the first successful match in @ms@--- It is an error if there are no matches-tryMatchers :: [DateMatcher] -> CalendarTime -> Bool-tryMatchers (DM _ parsed matcher : ms) =- case parsed of- Left _ -> tryMatchers ms- Right d -> matcher d-tryMatchers [] = error "Can't support fancy dates."--now :: IO CalendarTime-now = getClockTime >>= toCalendarTime
− src/Encoding.hs
@@ -1,46 +0,0 @@--- 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
− src/Encoding/IConv.hsc
@@ -1,184 +0,0 @@--- 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 <locale.h>-#include <langinfo.h>-#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 "darcs_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 "& darcs_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ())--foreign import ccall "darcs_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)-
− src/Encoding/Win32.hs
@@ -1,80 +0,0 @@--- 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-
− src/English.hs
@@ -1,98 +0,0 @@--- Copyright (C) 2008 Eric Kow------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- |--- Module : English--- Copyright : 2008 Eric Kow--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable------ This modules provides rudimentary natural language generation--- (NLG) utilities. That is, generating natural language from a--- machine representation. Initially, only English is supported at--- all. Representations are implemented for:------ * countable nouns (plurality); and--- * lists of clauses (foo, bar and/or baz).--module English where--import Data.List (isSuffixOf, intercalate)---- | > englishNum 0 (Noun "watch") "" == "watches"--- > englishNum 1 (Noun "watch") "" == "watch"--- > englishNum 2 (Noun "watch") "" == "watches"-englishNum :: Countable n => Int -> n -> ShowS-englishNum x = if x == 1 then singular else plural---- | Things that have a plural and singular spelling-class Countable a where- plural :: a -> ShowS- singular :: a -> ShowS---- | This only distinguishes between nouns with a final -ch,--- and nouns which do not.--- More irregular nouns will just need to have their own type------ > plural (Noun "batch") "" == "batches"--- > plural (Noun "bat") "" == "bats"--- > plural (Noun "mouse") "" == "mouses" -- :-(-newtype Noun = Noun String-data Pronoun = It--instance Countable Noun where- -- more irregular nouns will just need to have their own type- plural (Noun s) | "ch" `isSuffixOf` s = showString s . showString "es"- plural (Noun s) | "y" `isSuffixOf` s- && length s > 1- && last (init s) `notElem` "aeiou" =- showString (init s) . showString "ies"- plural (Noun s) = showString s . showChar 's'- singular (Noun s) = showString s--instance Countable Pronoun where- plural It = showString "them"- singular It = showString "it"---- | > singular This (Noun "batch") "" == "this batch"--- > plural This (Noun "batch") "" == "these batches"-data This = This Noun--instance Countable This where- plural (This s) = showString "these " . plural s- singular (This s) = showString "this " . singular s---- | Given a list of things, combine them thusly:------ > orClauses ["foo", "bar", "baz"] == "foo, bar or baz"-andClauses, orClauses :: [String] -> String-andClauses = intersperseLast ", " " and "-orClauses = intersperseLast ", " " or "---- | As 'intersperse', with a different separator for the last--- | interspersal.-intersperseLast :: String -> String -> [String] -> String-intersperseLast _ _ [] = ""-intersperseLast _ _ [clause] = clause-intersperseLast sep sepLast clauses =- intercalate sep (init clauses) ++ sepLast ++ last clauses--presentParticiple :: String -> String-presentParticiple v | last v == 'e' = init v ++ "ing"- | otherwise = v ++ "ing"
− src/Exec.hs
@@ -1,215 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, ForeignFunctionInterface, DeriveDataTypeable #-}---- |--- Module : Exec--- Copyright : 2003 David Roundy--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module Exec (- exec- , execInteractive- , withoutNonBlock- , Redirects- , Redirect(..)- , ExecException(..)- ) where--#ifndef WIN32-import Control.Exception.Extensible ( bracket )-import System.Posix.Env ( setEnv, getEnv, unsetEnv )-import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput )-import System.IO ( stdin )-#else-import Control.Exception.Extensible ( catchJust, IOException )-import Data.List ( isInfixOf )-#endif--#if __GLASGOW_HASKELL__ >= 612-import GHC.IO.Handle ( hDuplicate )-#else-import GHC.Handle ( hDuplicate )-#endif--import Control.Exception.Extensible ( bracketOnError, Exception(..),- SomeException(..) )-import Data.Typeable ( Typeable, cast )-import System.Cmd ( system )-import System.Exit ( ExitCode (..) )-import System.IO ( IOMode(..), openBinaryFile, stdout )-import System.Process ( runProcess, terminateProcess, waitForProcess )--import Darcs.Global ( whenDebugMode )-import Progress ( withoutProgress )--{-- A redirection is a three-tuple of values (in, out, err).- The most common values are:-- AsIs don't change it- Null /dev/null on Unix, NUL on Windows- File open a file for reading or writing-- There is also the value Stdout, which is only meaningful for- redirection of errors, and is performed AFTER stdout is- redirected so that output and errors mix together. StdIn and- StdErr could be added as well if they are useful.-- NOTE: Lots of care must be taken when redirecting stdin, stdout- and stderr to one of EACH OTHER, since the ORDER in which they- are changed have a significant effect on the result.--}--type Redirects = (Redirect, Redirect, Redirect)--data Redirect = AsIs- | Null- | File FilePath- | Stdout- deriving Show--{-- ExecException is thrown by exec if any system call fails,- for example because the executable we're trying to run- doesn't exist.--}--- ExecException cmd args redirecs errorDesc-data ExecException = ExecException- String -- cmd- [String] -- args- Redirects -- redirects- String -- errorDesc- deriving (Typeable,Show)--instance Exception ExecException where- toException e = SomeException e- fromException (SomeException e) = cast e--_devNull :: FilePath-#ifdef WIN32-_devNull = "NUL"-#else-_devNull = "/dev/null"-#endif--{-- We use System.Process, which does the necessary quoting- and redirection for us behind the scenes.--}-exec :: String -> [String] -> Redirects -> IO ExitCode-exec cmd args (inp,out,err) = withoutProgress $ do- h_stdin <- redirect inp ReadMode- h_stdout <- redirect out WriteMode- h_stderr <- redirect err WriteMode- withExit127 $ bracketOnError- (do doOptionalDebug- runProcess cmd args Nothing Nothing h_stdin h_stdout h_stderr)- (terminateProcess)- (waitForProcess)- where- doOptionalDebug = whenDebugMode . putStrLn . unwords $- cmd : args ++ ["; #"] ++ map show [inp, out, err]- redirect AsIs _ = return Nothing- redirect Null mode = Just `fmap` openBinaryFile _devNull mode- redirect (File "/dev/null") mode = redirect Null mode- redirect (File f) mode = Just `fmap` openBinaryFile f mode- -- hDuplicate stdout rather than passing stdout itself,- -- because runProcess closes the Handles we pass it.- redirect Stdout _ = Just `fmap` hDuplicate stdout--execInteractive :: String -> String -> IO ExitCode-#ifndef WIN32-{--This should handle arbitrary commands interpreted by the shell on Unix since-that's what people expect. But we don't want to allow the shell to interpret-the argument in any way, so we set an environment variable and call-cmd "$DARCS_ARGUMENT"--}-execInteractive cmd arg = withoutProgress $ do- let var = "DARCS_ARGUMENT"- stdin `seq` return ()- withoutNonBlock $ bracket- (do oldval <- getEnv var- setEnv var arg True- return oldval)- (\oldval ->- case oldval of- Nothing -> unsetEnv var- Just val -> setEnv var val True)- (\_ -> withExit127 $ system $ cmd++" \"$"++var++"\"")--#else--- The `system' function passes commands to execute via cmd.exe (or--- command.com) it's return value is equivalent to the one returned by the--- shell. For regular applications - this works correctly resulting in the--- exit code of the program. However in case of a command/file which can't be--- found - cmd.exe will return 1 instead of propagating the ExitFailure 9009--- which on windows is equivalent to ExitFailure 127 from *nix machines.------ Here we force return the exit code of the last cmd.exe action by appending--- & exit !errorlevel! to the command being executed that way chaining with--- ortryrunning works correctly.------ SETLOCAL EnableDelayedExpansion makes sure that !variable! expansion is done--- correctly on systems where that function is not enabled by default.----execInteractive cmd arg = withoutProgress $ do- withExit127 $ system $ "SETLOCAL EnableDelayedExpansion & " ++- cmd ++ " " ++ arg ++- " & exit !errorlevel!"-#endif--withoutNonBlock :: IO a -> IO a-#ifndef WIN32-{--Do IO without NonBlockingRead on stdInput.--This is needed when running unsuspecting external commands with interactive-mode - if read from terminal is non-blocking also write to terminal is-non-blocking.--}-withoutNonBlock x =- do nb <- queryFdOption stdInput NonBlockingRead- if nb- then bracket- (setFdOption stdInput NonBlockingRead False)- (\_ -> setFdOption stdInput NonBlockingRead True)- (\_ -> x)- else x-#else-withoutNonBlock x = do x-#endif--{--Ensure that we exit 127 if the thing we are trying to run does not exist-(Only needed under Windows)--}-withExit127 :: IO ExitCode -> IO ExitCode-#ifdef WIN32-withExit127 a = catchJust notFoundError a (const $ return $ ExitFailure 127)--notFoundError :: IOException -> Maybe ()-notFoundError e | "runProcess: does not exist" `isInfixOf` show e = Just ()-notFoundError _ = Nothing-#else-withExit127 = id-#endif
− src/IsoDate.hs
@@ -1,856 +0,0 @@--- Copyright (C) 2003 Peter Simons--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- |--- Module : IsoDate--- Copyright : 2003 Peter Simons--- 2003 David Roundy--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module IsoDate ( getIsoDateTime, readLocalDate, readUTCDate,- parseDate, getLocalTz,- englishDateTime, englishInterval, englishLast,- iso8601Interval, iso8601Duration,- cleanLocalDate, resetCalendar,- MCalendarTime(..), subtractFromMCal, addToMCal,- toMCalendarTime, unsafeToCalendarTime,- unsetTime, TimeInterval- ) where--import Text.ParserCombinators.Parsec-import System.Time-import System.IO.Unsafe ( unsafePerformIO )-import Data.Char ( toUpper, isDigit )-import Data.Maybe ( fromMaybe )-import Control.Monad ( liftM, liftM2 )-import qualified Data.ByteString.Char8 as B--type TimeInterval = (Maybe CalendarTime, Maybe CalendarTime)---- | Read/interpret a date string, assuming UTC if timezone--- is not specified in the string (see 'readDate')--- Warning! This errors out if we fail to interpret the--- date-readUTCDate :: String -> CalendarTime-readUTCDate = readDate 0---- | Convert a date string into ISO 8601 format (yyyymmdd variant)--- assuming local timezone if not specified in the string--- Warning! This errors out if we fail to interpret the date-cleanLocalDate :: String -> String-cleanLocalDate = showIsoDateTime . resetCalendar- . readDate (unsafePerformIO getLocalTz)---- | Read/interpret a date string, assuming local timezone if not--- specified in the string-readLocalDate :: String -> CalendarTime-readLocalDate = readDate (unsafePerformIO getLocalTz)---- | Return the local timezone offset from UTC in seconds-getLocalTz :: IO Int-getLocalTz = ctTZ `liftM` (getClockTime >>= toCalendarTime)---- | Parse a date string with 'parseDate'--- Warning! This errors out if we fail to interpret the date--- Uses its first argument as the default time zone.-readDate :: Int -> String -> CalendarTime-readDate tz d =- case parseDate tz d of- Left e -> error $ "bad date: "++d++" - "++show e- Right ct -> resetCalendar $ unsafeToCalendarTime ct---- | Parse a date string, assuming a default timezone if--- the date string does not specify one. The date formats--- understood are those of 'showIsoDateTime' and 'dateTime'-parseDate :: Int -> String -> Either ParseError MCalendarTime-parseDate tz d =- if length d >= 14 && B.all isDigit bd- then Right $ toMCalendarTime $- CalendarTime (readI $ B.take 4 bd)- (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd)- (readI $ B.take 2 $ B.drop 6 bd) -- Day- (readI $ B.take 2 $ B.drop 8 bd) -- Hour- (readI $ B.take 2 $ B.drop 10 bd) -- Minute- (readI $ B.take 2 $ B.drop 12 bd) -- Second- 0 Sunday 0 -- Picosecond, weekday and day of year unknown- "GMT" 0 False- else let dt = do { x <- dateTime tz; eof; return x }- in parse dt "" d- where bd = B.pack (take 14 d)- readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s)---- | Display a 'CalendarTime' in the ISO 8601 format without any--- separators, e.g. 20080825142503-showIsoDateTime :: CalendarTime -> String-showIsoDateTime ct = concat [ show $ ctYear ct- , twoDigit . show . (+1) . fromEnum $ ctMonth ct- , twoDigit . show $ ctDay ct- , twoDigit . show $ ctHour ct- , twoDigit . show $ ctMin ct- , twoDigit . show $ ctSec ct- ]- where twoDigit [] = undefined- twoDigit x@(_:[]) = '0' : x- twoDigit x@(_:_:[]) = x- twoDigit _ = undefined---- | The current time in the format returned by 'showIsoDateTime'-getIsoDateTime :: IO String-getIsoDateTime = (showIsoDateTime . toUTCTime) `liftM` getClockTime------- Parser Combinators ------------------------------------------------- | Case-insensitive variant of Parsec's 'char' function.-caseChar :: Char -> GenParser Char a Char-caseChar c = satisfy (\x -> toUpper x == toUpper c)---- | Case-insensitive variant of Parsec's 'string' function.-caseString :: String -> GenParser Char a ()-caseString cs = mapM_ caseChar cs <?> cs---- [x,y] => x <|> y-caseStrings :: [String] -> GenParser Char a ()-caseStrings xs = foldl1 (<|>) $ map caseString xs---- | Match a parser at least @n@ times.-manyN :: Int -> GenParser a b c -> GenParser a b [c]-manyN n p- | n <= 0 = return []- | otherwise = liftM2 (++) (count n p) (many p)---- | Match a parser at least @n@ times, but no more than @m@ times.-manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c]-manyNtoM n m p- | n < 0 = return []- | n > m = return []- | n == m = count n p- | n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))- | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)-------- Date/Time Parser --------------------------------------------------- | Try each of these date parsers in the following order------ (1) 'cvsDateTime'------ (2) 'iso8601DateTime'------ (3) 'oldDateTime-dateTime :: Int -> CharParser a MCalendarTime-dateTime tz =- choice [try $ toMCalendarTime `fmap` cvsDateTime tz,- try $ iso8601DateTime tz,- toMCalendarTime `fmap` oldDateTime]---- | CVS-style date/times, e.g.--- 2007/08/25 14:25:39 GMT--- Note that time-zones are optional here.-cvsDateTime :: Int -> CharParser a CalendarTime-cvsDateTime tz =- do y <- year- _ <- char '/'- mon <- monthNum- _ <- char '/'- d <- day- _ <- mySpaces- h <- hour- _ <- char ':'- m <- minute- _ <- char ':'- s <- second- z <- option tz $ mySpaces >> zone- return (CalendarTime y mon d h m s 0 Monday 0 "" z False)---- | \"Old\"-style dates, e.g.--- Tue Jan 3 14:08:07 EST 1999--- darcs-doc: Question (what does the "old" stand for really?)-oldDateTime :: CharParser a CalendarTime-oldDateTime = do wd <- dayName- _ <- mySpaces- mon <- monthName- _ <- mySpaces- d <- day- _ <- mySpaces- h <- hour- _ <- char ':'- m <- minute- _ <- char ':'- s <- second- _ <- mySpaces- z <- zone- _ <- mySpaces- y <- year- return (CalendarTime y mon d h m s 0 wd 0 "" z False)---- | ISO 8601 dates and times. Please note the following flaws:------ I am reluctant to implement:------ * years > 9999------ * truncated representations with implied century (89 for 1989)------ I have not implemented:------ * repeated durations (not relevant)------ * lowest order component fractions in intervals------ * negative dates (BC)------ I have not verified or have left too relaxed:------ * the difference between 24h and 0h------ * allows stuff like 2005-1212; either you use the hyphen all the way--- (2005-12-12) or you don't use it at all (20051212), but you don't use--- it halfway, likewise with time------ * No bounds checking whatsoever on intervals!--- (next action: read iso doc to see if bounds-checking required?) -}-iso8601DateTime :: Int -> CharParser a MCalendarTime-iso8601DateTime localTz = try $- do d <- iso8601Date- t <- option id $ try $ do optional $ oneOf " T"- iso8601Time- return $ t $ d { mctTZ = Just localTz }---- | Three types of ISO 8601 date:------ * calendar date, e.g., 1997-07-17, 1997-07, 199707, 1997------ * week+day in year, e.g., 1997-W32-4------ * day in year, e.g, 1997-273-iso8601Date :: CharParser a MCalendarTime-iso8601Date =- do d <- calendar_date <|> week_date <|> ordinal_date- return $ foldr ($) nullMCalendar d- where- calendar_date = -- yyyy-mm-dd- try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]- -- allow other variants to be parsed correctly- notFollowedBy (digit <|> char 'W')- return d- week_date = --yyyy-Www-d- try $ do yfn <- year_- optional dash- _ <- char 'W'- -- offset human 'week 1' -> computer 'week 0'- w' <- (\x -> x-1) `liftM` twoDigits- mwd <- option Nothing $ do { optional dash; Just `fmap` nDigits 1 }- let y = resetCalendar . unsafeToCalendarTime . yfn $ nullMCalendar { mctDay = Just 1 }- firstDay = ctWDay y- -- things that make this complicated- -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday- -- 2. the first week is the one that contains at least Thursday- -- if the year starts after Thursday, then some days of the year- -- will have already passed before the first week- let afterThursday = firstDay == Sunday || firstDay > Thursday- w = if afterThursday then w'+1 else w'- yday = (7 * w) + fromMaybe 1 mwd- diff c = c { mctWeek = True- , mctWDay = toEnum `fmap` mwd- , mctDay = Just yday }- return [(diff.yfn)]- ordinal_date = -- yyyy-ddd- try $ optchain year_ [ (dash, yearDay_) ]- --- year_ = try $ do y <- fourDigits <?> "year (0000-9999)"- return $ \c -> c { mctYear = Just y }- month_ = try $ do m <- twoDigits <?> "month (1 to 12)"- return $ \c -> c { mctMonth = Just $ intToMonth m }- day_ = try $ do d <- twoDigits <?> "day in month (1 to 31)"- return $ \c -> c { mctDay = Just d }- yearDay_ = try $ do d <- nDigits 3 <?> "day in year (001 to 366)"- return $ \c -> c { mctDay = Just d- , mctYDay = Just (d - 1) }- dash = char '-'---- | Note that this returns a function which sets the time on--- another calendar (see 'iso8601DateTime' for a list of--- flaws-iso8601Time :: CharParser a (MCalendarTime -> MCalendarTime)-iso8601Time = try $- do ts <- optchain hour_ [ (colon , min_)- , (colon , sec_)- , (oneOf ",.", pico_) ]- z <- option id $ choice [ zulu , offset ]- return $ foldr (.) id (z:ts)- where- hour_ = do h <- twoDigits- return $ \c -> c { mctHour = Just h }- min_ = do m <- twoDigits- return $ \c -> c { mctMin = Just m }- sec_ = do s <- twoDigits- return $ \c -> c { mctSec = Just s }- pico_ = do digs <- many digit- let picoExp = 12- digsExp = length digs- let frac | null digs = 0- | digsExp > picoExp = read $ take picoExp digs- | otherwise = 10 ^ (picoExp - digsExp) * (read digs)- return $ \c -> c { mctPicosec = Just $ frac }- zulu = do { _ <- char 'Z'; return (\c -> c { mctTZ = Just 0 }) }- offset = do sign <- choice [ char '+' >> return 1- , char '-' >> return (-1) ]- h <- twoDigits- m <- option 0 $ do { optional colon; twoDigits }- return $ \c -> c { mctTZ = Just $ sign * 60 * ((h*60)+m) }- colon = char ':'---- | Intervals in ISO 8601, e.g.,------ * 2008-09/2012-08-17T16:30------ * 2008-09/P2Y11MT16H30M------ * P2Y11MT16H30M/2012-08-17T16:30------ See 'iso8601Duration'-iso8601Interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime))-iso8601Interval localTz = leftDur <|> rightDur where- leftDur =- do dur <- iso8601Duration- end <- option Nothing $ do { _ <- char '/'; Just `liftM` isoDt }- return $ case end of- Nothing -> Left dur- Just e -> Right (dur `subtractFromMCal` e, e)- rightDur =- do start <- isoDt- _ <- char '/'- durOrEnd <- Left `liftM` iso8601Duration <|> Right `liftM` isoDt- return $ case durOrEnd of- Left dur -> Right (start, dur `addToMCal` start)- Right end -> Right (start, end)- isoDt = iso8601DateTime localTz---- | Durations in ISO 8601, e.g.,------ * P4Y (four years)------ * P5M (five months)------ * P4Y5M (four years and five months)------ * P4YT3H6S (four years, three hours and six seconds)-iso8601Duration :: CharParser a TimeDiff-iso8601Duration =- do _ <- char 'P'- y <- block 0 'Y'- mon <- block 0 'M'- d <- block 0 'D'- (h,m,s) <- option (0,0,0) $- do _ <- char 'T'- h' <- block (-1) 'H'- m' <- block (-1) 'M'- s' <- block (-1) 'S'- let unset = (== (-1))- if all unset [h',m',s']- then fail "T should be omitted if time is unspecified"- else let clear x = if (unset x) then 0 else x- in return (clear h', clear m', clear s')- --- return $ TimeDiff y mon d h m s 0- where block d c = option d $ try $- do n <- many1 digit- _ <- char c- return $ read n---- | 'optchain' @p xs@ parses a string with the obligatory--- parser @p@. If this suceeds, it continues on to the--- rest of the input using the next parsers down the--- chain. Each part of the chain consists of a parser--- for a separator and for the content itself. The--- separator is optional.------ A good use of this function is to help in parsing ISO--- ISO 8601 dates and times. For example, the parser--- @optchain year [(dash, month), (dash, day)]@ accepts--- dates like 2007 (only the year is used), 2007-07 (only--- the year and month), 200707 (only the year and month--- with no separator), 2007-07-19 (year, month and day).-optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]-optchain p next = try $- do r1 <- p- r2 <- case next of- [] -> return []- ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }- return (r1:r2)--nDigits :: Int -> CharParser a Int-nDigits n = read `liftM` count n digit--twoDigits, fourDigits :: CharParser a Int-twoDigits = nDigits 2-fourDigits = nDigits 4---- | One or more space.--- WARNING! This only matches on the space character, not on--- whitespace in general-mySpaces :: CharParser a String-mySpaces = manyN 1 $ char ' '---- | English three-letter day abbreviations (e.g. Mon, Tue, Wed)-dayName :: CharParser a Day-dayName = choice- [ caseString "Mon" >> return Monday- , try (caseString "Tue") >> return Tuesday- , caseString "Wed" >> return Wednesday- , caseString "Thu" >> return Thursday- , caseString "Fri" >> return Friday- , try (caseString "Sat") >> return Saturday- , caseString "Sun" >> return Sunday- ]---- | Four-digit year-year :: CharParser a Int-year = fourDigits---- | One or two digit month (e.g. 3 for March, 11 for November)-monthNum :: CharParser a Month-monthNum = do mn <- manyNtoM 1 2 digit- return $ intToMonth $ (read mn :: Int)---- | January is 1, February is 2, etc-intToMonth :: Int -> Month-intToMonth 1 = January-intToMonth 2 = February-intToMonth 3 = March-intToMonth 4 = April-intToMonth 5 = May-intToMonth 6 = June-intToMonth 7 = July-intToMonth 8 = August-intToMonth 9 = September-intToMonth 10 = October-intToMonth 11 = November-intToMonth 12 = December-intToMonth _ = error "invalid month!"---- | English three-letter month abbreviations (e.g. Jan, Feb, Mar)-monthName :: CharParser a Month-monthName = choice- [ try (caseString "Jan") >> return January- , caseString "Feb" >> return February- , try (caseString "Mar") >> return March- , try (caseString "Apr") >> return April- , caseString "May" >> return May- , try (caseString "Jun") >> return June- , caseString "Jul" >> return July- , caseString "Aug" >> return August- , caseString "Sep" >> return September- , caseString "Oct" >> return October- , caseString "Nov" >> return November- , caseString "Dec" >> return December- ]---- | day in one or two digit notation-day :: CharParser a Int-day = do d <- manyNtoM 1 2 digit- return (read d :: Int)---- | hour in two-digit notation-hour :: CharParser a Int-hour = twoDigits---- | minute in two-digit notation-minute :: CharParser a Int-minute = twoDigits---- | second in two-digit notation-second :: CharParser a Int-second = twoDigits---- | limited timezone support------ * +HHMM or -HHMM------ * Universal timezones: UTC, UT------ * Zones from GNU coreutils/lib/getdate.y, less half-hour ones ----- sorry Newfies.------ * any sequence of alphabetic characters (WARNING! treated as 0!)-zone :: CharParser a Int-zone = choice- [ do { _ <- char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }- , do { _ <- char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }- , mkZone "UTC" 0- , mkZone "UT" 0- , mkZone "GMT" 0- , mkZone "WET" 0- , mkZone "WEST" 1- , mkZone "BST" 1- , mkZone "ART" (-3)- , mkZone "BRT" (-3)- , mkZone "BRST" (-2)- , mkZone "AST" (-4)- , mkZone "ADT" (-3)- , mkZone "CLT" (-4)- , mkZone "CLST" (-3)- , mkZone "EST" (-5)- , mkZone "EDT" (-4)- , mkZone "CST" (-6)- , mkZone "CDT" (-5)- , mkZone "MST" (-7)- , mkZone "MDT" (-6)- , mkZone "PST" (-8)- , mkZone "PDT" (-7)- , mkZone "AKST" (-9)- , mkZone "AKDT" (-8)- , mkZone "HST" (-10)- , mkZone "HAST" (-10)- , mkZone "HADT" (-9)- , mkZone "SST" (-12)- , mkZone "WAT" 1- , mkZone "CET" 1- , mkZone "CEST" 2- , mkZone "MET" 1- , mkZone "MEZ" 1- , mkZone "MEST" 2- , mkZone "MESZ" 2- , mkZone "EET" 2- , mkZone "EEST" 3- , mkZone "CAT" 2- , mkZone "SAST" 2- , mkZone "EAT" 3- , mkZone "MSK" 3- , mkZone "MSD" 4- , mkZone "SGT" 8- , mkZone "KST" 9- , mkZone "JST" 9- , mkZone "GST" 10- , mkZone "NZST" 12- , mkZone "NZDT" 13- -- if we don't understand it, just give a GMT answer...- , do { _ <- manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])- (lookAhead space_digit);- return 0 }- ]- where mkZone n o = try $ do { caseString n; return (o*60*60) }- space_digit = try $ do { _ <- char ' '; oneOf ['0'..'9'] }------- English dates and intervals --------------------------------------------------- | In English, either a date followed by a time, or vice-versa, e.g,------ * yesterday at noon------ * yesterday tea time------ * 12:00 yesterday------ See 'englishDate' and 'englishTime'--- Uses its first argument as "now", i.e. the time relative to which--- "yesterday", "today" etc are to be interpreted-englishDateTime :: CalendarTime -> CharParser a CalendarTime-englishDateTime now =- try $ dateMaybeAtTime <|> timeThenDate- where- -- yesterday (at) noon- dateMaybeAtTime = try $- do ed <- englishDate now- t <- option Nothing $ try $- do { _ <- space; optional $ caseString "at "; Just `liftM` englishTime }- return $ fromMaybe id t $ ed- -- tea time 2005-12-04- timeThenDate = try $- do t <- englishTime- optional $ char ','- _ <- space- ed <- englishDate now- return $ t $ unsetTime $ ed---- | Specific dates in English as specific points of time, e.g,------ * today------ * yesterday------ * last week (i.e. the beginning of that interval)------ * 4 months ago (via 'englishAgo')------ The first argument is "now".-englishDate :: CalendarTime -> CharParser a CalendarTime-englishDate now = try $- (caseString "today" >> (return $ resetCalendar now))- <|> (caseString "yesterday" >> (return $ oneDay `subtractFromCal` now) )- <|> fst `fmap` englishLast now- <|> englishAgo now- where oneDay = TimeDiff 0 0 1 0 0 0 0---- | English expressions for points in the past, e.g.------ * 4 months ago------ * 1 day ago------ * day before yesterday------ See 'englishDuration'-englishAgo :: CalendarTime -> CharParser a CalendarTime-englishAgo now =- try $ do p <- englishDuration- _ <- try space- (m,ref) <- (try $ caseString "ago" >> return ((-1), now))- <|> do m <- beforeMod <|> afterMod- _ <- space- d <- englishDate now- <|> fst `fmap` englishLast now- <|> unsafeToCalendarTime `fmap` iso8601DateTime (ctTZ now)- return (m,d)- return $ multiplyDiff m p `addToCal` ref- where- beforeMod = try $ caseString "before" >> return (-1)- afterMod = try $ (caseStrings ["after","since"]) >> return 1---- | English expressions for intervals of time,------ * before tea time (i.e. from the beginning of time)------ * after 14:00 last month (i.e. till now)------ * between last year and last month------ * in the last three months (i.e. from then till now)------ * 4 months ago (i.e. till now; see 'englishAgo')-englishInterval :: CalendarTime -> CharParser a TimeInterval-englishInterval now = twixt <|> before <|> after <|> inTheLast <|> lastetc- where- englishDT = (unsafeToCalendarTime `fmap` iso8601DateTime (ctTZ now)- <|> englishDateTime now)- before = try $- do caseString "before"- _ <- space- end <- englishDT- return (Just theBeginning, Just end)- after = try $- do caseStrings ["after","since"]- _ <- space- start <- englishDT- return (Just start, Nothing)- twixt = try $- do caseString "between"- _ <- space- start <- englishDT- _ <- space- caseString "and"- _ <- space- end <- englishDT- return (Just start, Just end)- inTheLast = try $- do caseString "in the last"- _ <- space- dur <- englishDuration- return (Just $ dur `subtractFromCal` now, Just now)- lastetc =- do l <- englishAgo now- return (Just l, Just now)---- | Durations in English that begin with the word \"last\",--- E.g. \"last 4 months\" is treated as the duration between--- 4 months ago and now-englishLast :: CalendarTime -> CharParser a (CalendarTime, CalendarTime)-englishLast now =- -- last year, last week, last 3 years, etc- try $ do caseString "last"- _ <- space- d <- englishDuration- return (d `subtractFromCal` now, now)---- | Either an 'iso8601Time' or one of several common--- English time expressions like 'noon' or 'tea time'-englishTime :: CharParser a (CalendarTime->CalendarTime)-englishTime = try $- choice [ wrapM `fmap` iso8601Time- , namedTime "noon" 12 0- , namedTime "midnight" 0 0- , namedTime "tea time" 16 30- , namedTime "bed time" 2 30- , namedTime "proper bed time" 21 30 ]- where namedTime name h m = try $- do caseString name- return $ \c -> c { ctHour = h, ctMin = m }- wrapM f = unsafeToCalendarTime . f . toMCalendarTime---- | Some English durations, e.g.------ * day------ * 4 score------ * 7 years------ * 12 months------ This is not particularly strict about what it accepts.--- For example, "7 yeares", "4 scores" or "1 days" are--- just fine.-englishDuration :: CharParser a TimeDiff-englishDuration = try $- do n <- option 1 $ do { x <- many1 digit; _ <- space; (return $ read x) }- b <- base- optional (caseStrings ["es","s"])- let current = multiplyDiff n b- next <- option noTimeDiff $ try $ do- { optional space; _ <- char ',' ; optional space ; englishDuration }- return $ addDiff current next- where- base = choice- [ try $ caseString "score" >> (return $ TimeDiff 20 0 0 0 0 0 0) -- why not?- , caseString "year" >> (return $ TimeDiff 1 0 0 0 0 0 0)- , try $ caseString "month" >> (return $ TimeDiff 0 1 0 0 0 0 0)- , caseString "fortnight" >> (return $ TimeDiff 0 0 14 0 0 0 0)- , caseString "week" >> (return $ TimeDiff 0 0 7 0 0 0 0)- , caseString "day" >> (return $ TimeDiff 0 0 1 0 0 0 0)- , caseString "hour" >> (return $ TimeDiff 0 0 0 1 0 0 0)- , caseString "minute" >> (return $ TimeDiff 0 0 0 0 1 0 0)- , caseString "second" >> (return $ TimeDiff 0 0 0 0 0 1 0) ]------- Calendar and TimeDiff manipulation ------------------------------------------------- | The very beginning of time, i.e. 1970-01-01-theBeginning :: CalendarTime-theBeginning = unsafePerformIO $ toCalendarTime $ TOD 0 0---- | An 'MCalenderTime' is an underspecified 'CalendarTime'--- It is used for parsing dates. For example, if you want to parse--- the date '4 January', it may be useful to underspecify the year--- by setting it to 'Nothing'. This uses almost the same fields as--- 'System.Time.CalendarTime', a notable exception being that we--- introduce 'mctWeek' to indicate if a weekday was specified or not-data MCalendarTime = MCalendarTime- { mctYear :: Maybe Int- , mctMonth :: Maybe Month- , mctDay :: Maybe Int- , mctHour :: Maybe Int- , mctMin :: Maybe Int- , mctSec :: Maybe Int- , mctPicosec :: Maybe Integer- , mctWDay :: Maybe Day- , mctYDay :: Maybe Int- , mctTZName :: Maybe String- , mctTZ :: Maybe Int- , mctIsDST :: Maybe Bool- , mctWeek :: Bool -- is set or not-} deriving Show---- | Trivially convert a 'CalendarTime' to a fully specified--- 'MCalendarTime' (note that this sets the 'mctWeek' flag to--- @False@-toMCalendarTime :: CalendarTime -> MCalendarTime-toMCalendarTime (CalendarTime a b c d e f g h i j k l) =- MCalendarTime (Just a) (Just b) (Just c) (Just d) (Just e) (Just f)- (Just g) (Just h) (Just i) (Just j) (Just k) (Just l)- False---- | Returns the first 'CalendarTime' that falls within a 'MCalendarTime'--- This is only unsafe in the sense that it plugs in default values--- for fields that have not been set, e.g. @January@ for the month--- or @0@ for the seconds field.--- Maybe we should rename it something happier.--- See also 'resetCalendar'-unsafeToCalendarTime :: MCalendarTime -> CalendarTime-unsafeToCalendarTime m =- CalendarTime- { ctYear = fromMaybe 0 $ mctYear m- , ctMonth = fromMaybe January $ mctMonth m- , ctDay = fromMaybe 1 $ mctDay m- , ctHour = fromMaybe 0 $ mctHour m- , ctMin = fromMaybe 0 $ mctMin m- , ctSec = fromMaybe 0 $ mctSec m- , ctPicosec = fromMaybe 0 $ mctPicosec m- , ctWDay = fromMaybe Sunday $ mctWDay m- , ctYDay = fromMaybe 0 $ mctYDay m- , ctTZName = fromMaybe "" $ mctTZName m- , ctTZ = fromMaybe 0 $ mctTZ m- , ctIsDST = fromMaybe False $ mctIsDST m- }--addToCal :: TimeDiff -> CalendarTime -> CalendarTime-addToCal td = toUTCTime . addToClockTime td . toClockTime--subtractFromCal :: TimeDiff -> CalendarTime -> CalendarTime-subtractFromCal = addToCal . multiplyDiff (-1)--addToMCal :: TimeDiff -> MCalendarTime -> MCalendarTime-addToMCal td mc =- copyCalendar (addToCal td $ unsafeToCalendarTime mc) mc--subtractFromMCal :: TimeDiff -> MCalendarTime -> MCalendarTime-subtractFromMCal = addToMCal . multiplyDiff (-1)---- surely there is a more concise way to express these-addDiff :: TimeDiff -> TimeDiff -> TimeDiff-addDiff (TimeDiff a1 a2 a3 a4 a5 a6 a7) (TimeDiff b1 b2 b3 b4 b5 b6 b7) =- TimeDiff (a1+b1) (a2+b2) (a3+b3) (a4+b4) (a5+b5) (a6+b6) (a7 + b7)---- | 'multiplyDiff' @i d@ multiplies every field in @d@ with @i@------ FIXME; this seems like a terrible idea! it seems like--- we should get rid of it if at all possible, maybe adding an--- invertDiff function-multiplyDiff :: Int -> TimeDiff -> TimeDiff-multiplyDiff m (TimeDiff a1 a2 a3 a4 a5 a6 a7) =- TimeDiff (a1*m) (a2*m) (a3*m) (a4*m) (a5*m) (a6*m) (a7 * (toInteger m))--nullMCalendar :: MCalendarTime-nullMCalendar = MCalendarTime Nothing Nothing Nothing Nothing Nothing Nothing- Nothing Nothing Nothing Nothing Nothing Nothing- False---- | Set a calendar to UTC time any eliminate any inconsistencies within--- (for example, where the weekday is given as @Thursday@, but this does not--- match what the numerical date would lead one to expect)-resetCalendar :: CalendarTime -> CalendarTime-resetCalendar = toUTCTime . toClockTime---- | 'copyCalendar' @c mc@ replaces any field which is--- specified in @mc@ with the equivalent field in @c@--- @copyCalendar c nullMCalendar == nullMCalendar@-copyCalendar :: CalendarTime -> MCalendarTime -> MCalendarTime-copyCalendar c mc = mc- { mctYear = mctYear mc >> Just (ctYear c)- , mctMonth = mctMonth mc >> Just (ctMonth c)- , mctDay = mctDay mc >> Just (ctDay c)- , mctHour = mctHour mc >> Just (ctHour c)- , mctMin = mctMin mc >> Just (ctMin c)- , mctSec = mctSec mc >> Just (ctSec c)- , mctPicosec = mctPicosec mc >> Just (ctPicosec c)- , mctWDay = mctWDay mc >> Just (ctWDay c)- , mctYDay = mctYDay mc >> Just (ctYDay c)- , mctTZName = mctTZName mc >> Just (ctTZName c)- , mctTZ = mctTZ mc >> Just (ctTZ c)- , mctIsDST = mctIsDST mc >> Just (ctIsDST c)- }---- | Zero the time fields of a 'CalendarTime'-unsetTime :: CalendarTime -> CalendarTime-unsetTime mc = mc- { ctHour = 0- , ctMin = 0- , ctSec = 0- , ctPicosec = 0- }
− src/Lcs.hs
@@ -1,484 +0,0 @@--- Copyright (C) 2002 David Roundy--- Copyright (C) 2005 Benedikt Schmidt------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}---- |--- Module : Lcs--- Copyright : 2003 David Roundy--- 2005 Benedikt Schmidt--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable------ LCS stands for Longest Common Subsequence, and it is a relatively--- challenging problem to find an LCS efficiently. This module implements--- the algorithm described in:------ "An O(ND) Difference Algorithm and its Variations", Eugene Myers,--- Algorithmica Vol. 1 No. 2, 1986, pp. 251-266;--- especially the variation described in section 4.2 and most refinements--- implemented in GNU diff (D is the edit-distance).------ There is currently no heuristic to reduce the running time and produce--- suboptimal output for large inputs with many differences. It behaves like--- GNU diff with the -d option in this regard.------ In the first step, a hash value for every line is calculated and collisions--- are marked with a special value. This reduces a string comparison to an--- int comparison for line tuples where at least one of the hash values is--- not equal to the special value. After that, lines which only exists in one--- of the files are removed and marked as changed which reduces the running--- time of the following difference algorithm. GNU diff additionally removes--- lines that appear very often in the other file in some cases.--- The last step tries to create longer changed regions and line up deletions--- in the first file to insertions in the second by shifting changed lines--- forward and backward.--module Lcs ( getChanges,- shiftBoundaries ) where--import Control.Monad-import Data.Int-import Control.Monad.ST-import Data.Maybe-import ByteStringUtils (hashPS)-import qualified Data.ByteString as B (empty, ByteString)-import Data.Array.Base-import Data.Array.Unboxed-import qualified Data.Map as Map ( lookup, empty, insertWith )-#include "impossible.h"---- | create a list of changes between a and b, each change has the form--- (starta, lima, startb, limb) which means that a[starta, lima)--- has to be replaced by b[startb, limb)-getChanges :: [B.ByteString] -> [B.ByteString]- -> [(Int,[B.ByteString],[B.ByteString])]-getChanges a b = dropStart (initP a) (initP b) 1--dropStart :: PArray -> PArray -> Int- -> [(Int,[B.ByteString],[B.ByteString])]-dropStart a b off- | off > aLen a = [(off - 1, [], getSlice b off (aLen b))]- | off > aLen b = [(off - 1, getSlice a off (aLen a), [])]- | a!off == b!off = dropStart a b (off + 1)- | otherwise = dropEnd a b off 0--dropEnd :: PArray -> PArray -> Int -> Int- -> [(Int,[B.ByteString],[B.ByteString])]-dropEnd a b off end- | off > alast = [(off - 1, [], getSlice b off blast)]- | off > blast = [(off - 1, getSlice a off alast, [])]- | a!alast == b!blast = dropEnd a b off (end + 1)- | otherwise = getChanges' (a, (off, alast)) (b, (off, blast))- where alast = aLen a - end- blast = aLen b - end--getSlice :: PArray -> Int -> Int -> [B.ByteString]-getSlice a from to- | from > to = []- | otherwise = (a ! from) : (getSlice a (from + 1) to)--getChanges' :: (PArray, (Int, Int)) -> (PArray, (Int, Int))- -> [(Int,[B.ByteString],[B.ByteString])]-getChanges' (a, abounds) (b, bbounds) =- map (convertPatch 0 a b) $ createPatch c_a c_b- where- -- If the last few characters of two lines are the same, the lines are- -- probably the same. The choice of 20 is plucked out of the air.- toHash x bnds = listArray bnds [ hashPS $ x!i | i <- range bnds]- ah = toHash a abounds :: HArray- mkAMap m (i:is) =- let ins (_,_,_,new) (collision,_,_,old) =- (collision || (new /= old), True, False, old)- m' = Map.insertWith ins (ah!i) (False, True, False, a!i) m- in mkAMap m' is- mkAMap m _ = m- hm_a = mkAMap Map.empty (range abounds)- --- bh = toHash b bbounds :: HArray- mkBMap m (i:is) =- let ins (_,_,_,new) (collision,in_a,_,old) =- (collision || (new /= old), in_a, True, old)- m' = Map.insertWith ins (bh!i) (False, False, True, b!i) m- in mkBMap m' is- mkBMap m _ = m- hm = mkBMap hm_a (range bbounds)- -- take care of collisions, if there are different lines with the- -- same hash in both files, then set the hash to markColl,- -- PackedStrings are compared for two lines with the hash markColl- get (i, h) = case Map.lookup h hm of- Just (_,False,_,_) -> Nothing- Just (_,_,False,_) -> Nothing- Just (False,True,True,_) -> Just (i, h)- Just (True,True,True,_) -> Just (i, markColl)- Nothing -> impossible-- a' = mapMaybe get [(i, ah!i) | i <- range (bounds ah)]- b' = mapMaybe get [(i, bh!i) | i <- range (bounds bh)]-- (c_a, c_b) = diffArr a' b' (a, abounds) (b, bbounds)---- | mark hash value where collision occured-markColl :: Int32-markColl = 2345677---- | return arrays with changes in a and b (1 indexed), offsets start with 0-diffArr :: [(Int,Int32)] -> [(Int,Int32)]- -> (PArray, (Int, Int)) -> (PArray, (Int, Int))- -> (BArray, BArray)-diffArr a b (p_a, (off_a, l_a)) (p_b, (off_b, l_b)) = runST (- do let h_a = initH (map snd a)- h_b = initH (map snd b)- m_a = initM (map fst a)- m_b = initM (map fst b)- end_a = (aLen p_a)- end_b = (aLen p_b)- c_a <- initVChanged end_a- c_b <- initVChanged end_b- mapM_ (\ (l,_) -> writeArray c_a l False) a- mapM_ (\ (l,_) -> writeArray c_b l False) b- _ <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b 0 0 (aLen h_a) (aLen h_b)- let unchanged ar = do {xs <- getElems ar; return $ length (filter not xs) -1}- err <- liftM2 (/=) (unchanged c_a) (unchanged c_b)- when err impossible- -- Mark common lines at beginning and end- mapM_ (\ i -> writeArray c_a i False ) [1..(off_a - 1)]- mapM_ (\ i -> writeArray c_b i False ) [1..(off_b - 1)]- mapM_ (\ i -> writeArray c_a i False ) [(l_a + 1) .. end_a]- mapM_ (\ i -> writeArray c_b i False ) [(l_b + 1) .. end_b]- shiftBoundaries c_a c_b p_a 1 1- shiftBoundaries c_b c_a p_b 1 1- err1 <- liftM2 (/=) (unchanged c_a) (unchanged c_b)- when err1 impossible- c_a' <- unsafeFreeze c_a- c_b' <- unsafeFreeze c_b- return (c_a', c_b'))---- | set changes array for a and b and return number of changed lines-cmpseq :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray- -> BSTArray s -> BSTArray s -> Int -> Int -> Int -> Int -> ST s Int-cmpseq _ _ _ _ _ _ _ _ _ _ 0 0 = return 0-cmpseq h_a h_b p_a p_b m_a m_b c_a c_b off_a off_b l_a l_b = do- let lim_a = off_a+l_a- lim_b = off_b+l_b- off_a' = findSnake h_a h_b p_a p_b m_a m_b off_a off_b l_a l_b off_a off_b- off_b' = off_b+off_a'-off_a- lim_a' = findSnakeRev h_a h_b p_a p_b m_a m_b lim_a lim_b off_a' off_b'- lim_b' = lim_b+lim_a'-lim_a- l_a' = lim_a'-off_a'- l_b' = lim_b'-off_b'- if l_a' == 0 || l_b' == 0- then if l_a' == 0- then do when (l_b' > 0) $- mapM_ (\i -> writeArray c_b (m_b!i) True)- [(off_b' + 1) .. lim_b']- return l_b'- else do when (l_a' > 0) $- mapM_ (\i -> writeArray c_a (m_a!i) True)- [(off_a' + 1) .. lim_a']- return l_a'- else do let m = l_a' + l_b'- del = l_a' - l_b'- dodd = odd del- v <- initV m- vrev <- initVRev m l_a'- writeArray vrev 0 l_a'- writeArray v 0 0- (xmid, ymid, _) <- findDiag 1 h_a h_b p_a p_b m_a m_b v vrev- off_a' off_b' l_a' l_b' del dodd- when ((xmid == 0 && ymid == 0) || (xmid == l_a' && ymid == l_b')- || (xmid < 0 || ymid < 0 || xmid > l_a' || ymid > l_b'))- impossible- c1 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b- off_a' off_b' xmid ymid- c2 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b- (off_a' + xmid) (off_b' + ymid)- (l_a' - xmid) (l_b' - ymid)- return $ c1 + c2---- | return (xmid, ymid, cost) for the two substrings--- a[off_a+1..off_a+1+l_a] and b-findDiag :: Int -> HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray- -> VSTArray s -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> Bool- -> ST s (Int, Int, Int)-findDiag c h_a h_b p_a p_b m_a m_b v vrev off_a off_b l_a l_b del dodd = do- when (c > l_a + l_b) $ error "findDiag failed"- r <- findF- case r of- Just (xmid, ymid) -> return (xmid, ymid, (c*2 - 1))- Nothing ->- do r' <- findR- case r' of- Just (xmid, ymid) -> return (xmid, ymid, c*2)- Nothing -> findDiag (c + 1) h_a h_b p_a p_b m_a m_b v vrev- off_a off_b l_a l_b del dodd- where fdmax = if c <= l_a then c else l_a - ((l_a + c) `mod` 2)- rdmax = if c <= l_b then c else l_b - ((l_b + c) `mod` 2)- lastrdmax = if (c-1) <= l_b then c-1 else l_b-(l_b + (c-1) `mod` 2)- lastrdmin = -(if (c-1) <= l_a then c-1 else l_a-((l_a + (c-1)) `mod` 2))- fdmin = -rdmax- rdmin = -fdmax- findF = findF' fdmax- findR = findR' rdmax- findF' d = do x <- findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b- if dodd && d - del >= lastrdmin && d - del <= lastrdmax- then do xr <- readArray vrev (d - del)- if xr <= x then return $ Just (x, x - d)- else if d <= fdmin then return Nothing- else findF' (d-2)- else if d <= fdmin then return Nothing else findF' (d-2)- findR' d = do x <- findOneRev h_a h_b p_a p_b m_a m_b vrev d del off_a off_b- if not dodd && (d + del >= fdmin) && (d + del <= fdmax)- then do xf <- readArray v (d + del)- if x <= xf then return $ Just (x,x-del-d)- else if d <= rdmin then return Nothing- else findR' (d-2)- else if d <= rdmin then return Nothing else findR' (d-2)---- | find position on diag d with one more insert/delete going forward-findOne :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray- -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int-findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b = do- x0 <- do xbelow <- readArray v (d - 1)- xover <- readArray v (d + 1)- return $ if xover > xbelow then xover else xbelow + 1- let y0 = x0 - d- x = findSnake h_a h_b p_a p_b m_a m_b (x0+off_a) (y0+off_b)- l_a l_b off_a off_b- writeArray v d (x - off_a)- return (x-off_a)---- | follow snake from northwest to southeast, x and y are absolute positions-findSnake :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray- -> Int -> Int -> Int -> Int -> Int -> Int -> Int-findSnake h_a h_b p_a p_b m_a m_b x y l_a l_b off_a off_b =- if x < l_a + off_a && y < l_b + off_b && h_a!(x+1) == h_b!(y+1)- && (h_a!(x+1) /= markColl || p_a!(m_a!(x+1)) == p_b!(m_b!(y+1)))- then findSnake h_a h_b p_a p_b m_a m_b (x + 1) (y + 1) l_a l_b off_a off_b- else x---- | find position on diag d with one more insert/delete going backward-findOneRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray- -> VSTArray s -> Int -> Int -> Int -> Int -> ST s Int-findOneRev h_a h_b p_a p_b m_a m_b v d del off_a off_b = do- x0 <- do xbelow <- readArray v (d - 1)- xover <- readArray v (d + 1)- return $ if xbelow < xover then xbelow else xover-1- let y0 = x0 - del - d- x = findSnakeRev h_a h_b p_a p_b m_a m_b (x0+off_a) (y0+off_b)- off_a off_b- writeArray v d (x-off_a)- return (x-off_a)---- | follow snake from southeast to northwest, x and y are absolute positions-findSnakeRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray- -> Int -> Int -> Int -> Int -> Int-findSnakeRev h_a h_b p_a p_b m_a m_b x y off_a off_b =- if x > off_a && y > off_b && h_a!x == h_b!y- && (h_a!x /= markColl || p_a!(m_a!x) == p_b!(m_b!y))- then findSnakeRev h_a h_b p_a p_b m_a m_b (x - 1) (y - 1) off_a off_b- else x---- | try to create nicer diffs by shifting around regions of changed lines-shiftBoundaries :: BSTArray s -> BSTArray s -> PArray -> Int -> Int -> ST s ()-shiftBoundaries c_a c_b p_a i_ j_ =- do x <- nextChanged c_a i_- case x of- Just start ->- do let skipped = start - i_- j1 <- nextUnchangedN c_b skipped j_- end <- nextUnchanged c_a start- j2 <- nextUnchanged c_b j1- (i3,j3) <- expand start end j2- shiftBoundaries c_a c_b p_a i3 j3- Nothing -> return () -- no change up to end of file- where noline = (aLen p_a) + 1- expand start i j =- do let len = i - start- (start0,i0,j0) <- shiftBackward start i j- b <- if j0 > 1 then readArray c_b (j0-1) else return False- let corr = if b then i0 else noline- let blank = if p_a!(i0-1) == B.empty then i0- else noline- (start1,i1,j1,corr1,blank1) <- shiftForward start0 i0 j0 corr blank- -- prefer corresponding to ending with blank line- let newi = if corr1 == noline then blank1- else corr1- (start2,i2,j2) <- moveCorr start1 i1 j1 newi- if len /= i2 - start2- then expand start2 i2 j2- else return (i2, j2)- shiftBackward start i j =- if start > 1 && p_a!(i-1) == p_a!(start-1)- then do when (i == start) impossible- b1 <- readArray c_a (i-1)- b2 <- readArray c_a (start-1)- when (not b1 || b2) impossible- writeArray c_a (i-1) False- writeArray c_a (start-1) True- b <- if start > 2 then readArray c_a (start-2)- else return False- start' <- if b then liftM (1+) (prevUnchanged c_a (start-2))- else return (start-1)- j' <- prevUnchanged c_b (j-1)- shiftBackward start' (i-1) j'- else return (start,i,j)- shiftForward start i j corr blank =- if i <= aLen p_a && p_a!i == p_a!start &&- -- B.empty at the end of file marks empty line after final newline- not ((i == aLen p_a) && (p_a!i == B.empty))- then do when (i == start) impossible- b1 <- readArray c_a i- b2 <- readArray c_a start- when (not b2 || b1) impossible- writeArray c_a i True- writeArray c_a start False- i0 <- nextUnchanged c_a (i+1)- j0 <- nextUnchanged c_b (j+1)- let corr0 = if i0 > (i+1) then noline- else if j0-j > 2 then i0 else corr- let blank0 = if i0 > i+1 then noline- else if p_a!(i0-1) == B.empty then i0- else blank- shiftForward (start+1) i0 j0 corr0 blank0- else return (start,i,j,corr,blank)- moveCorr start i j corr =- if corr >= i- then return (start,i,j)- else do b1 <- readArray c_a (i-1)- b2 <- readArray c_a (start-1)- when (not b1 || b2) impossible- when (p_a!(i-1) /= p_a!(start-1)) impossible- writeArray c_a (i-1) False- writeArray c_a (start-1) True- j' <- prevUnchanged c_b (j-1)- moveCorr (start-1) (i-1) j' corr---- | goto next unchanged line, return the given line if unchanged-nextUnchanged :: BSTArray s -> Int -> ST s Int-nextUnchanged c i = do- len <- aLenM c- if i == len + 1 then return i- else do b <- readArray c i- if b then nextUnchanged c (i+1)- else return i---- | skip at least one unchanged line, if there is none advance--- behind the last line-skipOneUnChanged :: BSTArray s -> Int -> ST s Int-skipOneUnChanged c i = do- len <- aLenM c- if i == len + 1- then return i- else do b <- readArray c i- if not b then return (i+1)- else skipOneUnChanged c (i+1)---- | goto n-th next unchanged line-nextUnchangedN :: BSTArray s -> Int -> Int -> ST s Int-nextUnchangedN c n i =- if n == 0 then return i- else do i' <- skipOneUnChanged c i- nextUnchangedN c (n-1) i'---- | goto next changed line, return the given line if changed-nextChanged :: BSTArray s -> Int -> ST s (Maybe Int)-nextChanged c i = do- len <- aLenM c- if i <= len- then do b <- readArray c i- if not b then nextChanged c (i+1)- else return $ Just i- else return Nothing---- | goto previous unchanged line, return the given line if unchanged-prevUnchanged :: BSTArray s -> Int -> ST s Int-prevUnchanged c i = do- b <- readArray c i- if b then prevUnchanged c (i-1)- else return i--type HArray = UArray Int Int32-type BArray = UArray Int Bool-type PArray = Array Int B.ByteString-type MapArray = UArray Int Int-type VSTArray s = STUArray s Int Int-type BSTArray s = STUArray s Int Bool--initV :: Int -> ST s (VSTArray s)-initV dmax = newArray (-(dmax + 1), dmax + 1) (-1)--initVRev :: Int -> Int -> ST s (VSTArray s)-initVRev dmax xmax = newArray (-(dmax + 1), dmax + 1) (xmax + 1)---- 1 indexed, v[0] is used as a guard element-initVChanged :: Int -> ST s (BSTArray s)-initVChanged l = do- a <- newArray (0, l) True- writeArray a 0 False- return a- -- set to false for all lines which have a mapping later- -- other lines are only present in one of the files--initH :: [Int32] -> HArray-initH a = listArray (0, length a) (0:a)--initM :: [Int] -> MapArray-initM a = listArray (0, length a) (0:a)--initP :: [B.ByteString] -> PArray-initP a = listArray (0, length a) (B.empty:a)--aLen :: (IArray a e) => a Int e -> Int-aLen a = snd $ bounds a-aLenM :: (MArray a e m) => a Int e -> m Int-aLenM a = getBounds a >>= return . snd--convertPatch :: Int -> PArray -> PArray -> (Int, Int, Int, Int)- -> (Int,[B.ByteString],[B.ByteString])-convertPatch off a b (a0,a1,b0,b1)- | b0 == b1 = (b0+off,getDelete a a0 a1,[])- | a0 == a1 = (b0+off,[],getInsert b b0 b1)- | otherwise = (b0+off,getDelete a a0 a1,getInsert b b0 b1)--getInsert :: PArray -> Int -> Int -> [B.ByteString]-getInsert b from to- | from >= to = []- | otherwise = (b!(from+1)):(getInsert b (from+1) to)-getDelete :: PArray -> Int -> Int -> [B.ByteString]-getDelete a from to- | from >= to = []- | otherwise = (a!(from+1)):(getDelete a (from+1) to)--createPatch :: BArray -> BArray -> [(Int, Int, Int, Int)]-createPatch c_a c_b =- reverse $ createP c_a c_b (aLen c_a) (aLen c_b)--createP :: BArray -> BArray -> Int -> Int -> [(Int, Int, Int, Int)]-createP _ _ 0 0 = []-createP c_a c_b ia ib =- if c_a!ia || c_b!ib- then let ia' = skipChangedRev c_a ia- ib' = skipChangedRev c_b ib- in (ia',ia,ib',ib):(createP c_a c_b ia' ib')- else createP c_a c_b (ia-1) (ib-1)--skipChangedRev :: BArray -> Int -> Int-skipChangedRev c i = if i >= 0 && c!i then skipChangedRev c (i-1) else i
− src/Preproc.hs
@@ -1,187 +0,0 @@--- | This program mangles a pseudo-LaTeX document into actual LaTeX.--- There are three key changes to the input:------ * \\input{foo} is replaced by the contents of the file foo (after--- it, too, is mangled). Note that this is relative to the--- working directory, *not* relative to the file being parsed.------ * Anything between \\begin{code} and \\end{code} is deleted.--- Note that this is quite unlike normal literate documentation--- (for which we use Haddock, not LaTeX).------ * Some nonstandard pseudo-LaTeX commands are expanded into actual--- LaTeX text. In particular, \\darcsCommand{foo} is replaced by--- LaTeX markup describing the command @foo@.-module Preproc ( preprocMain ) where-import qualified Ratified( readFile )-import System.FilePath ( (</>) )-import System.Environment ( getArgs )-import System.Exit ( exitWith, ExitCode(..) )-import Control.Monad ( when )-import Data.List ( stripPrefix )-import Text.Regex ( matchRegex, mkRegex )-import Darcs.Commands ( DarcsCommand(SuperCommand,- commandSubCommands, commandName,- commandExtraArgHelp, commandBasicOptions,- commandAdvancedOptions, commandHelp,- commandDescription),- extractCommands )-import Darcs.Arguments ( optionsLatex )-import Darcs.Commands.Help ( commandControlList, environmentHelp )-import English ( andClauses )-import Version ( version )--theCommands :: [DarcsCommand]-theCommands = extractCommands commandControlList---- | The entry point for this program. The path to the TeX master--- file is supplied as the first argument. Bootstrapping into--- 'preproc' then happens by passing it a pseudo-document that--- contains a single input (include) line.-preprocMain :: [String] -> IO ()-preprocMain args = do- when (length args < 1) $ exitWith $ ExitFailure 1- putStrLn "%% This file was automatically generated by preproc."- c <- preproc ["\\input{"++head args++"}"]- mapM_ putStrLn c---- | Depending on whether pdflatex or htlatex is to be used, the LaTeX--- output of this program must vary subtly. This procedure returns--- true iff the command-line arguments contain @--html@.-amHtml :: IO Bool-amHtml = do args <- getArgs- return $ elem "--html" args---- | Given a list of input lines in pseudo-LaTeX, return the same--- document in LaTeX. The pseudo-LaTeX lines are replaced, other--- lines are used unmodified.-preproc :: [String] -> IO [String]-preproc [] = return [] -- Empty input, empty output.-preproc ("\\usepackage{html}":ss) = -- only use html package with latex2html- do rest <- preproc ss- ah <- amHtml- return $ if ah- then "\\usepackage{html}" : rest- else "\\usepackage{hyperref}" : rest-preproc ("\\begin{code}":ss) = ignore ss- where ignore :: [String] -> IO [String]- ignore ("\\end{code}":ss') = preproc ss'- ignore (_:ss') = ignore ss'- ignore [] = return []-preproc ("\\begin{options}":ss) =- do rest <- preproc ss- ah <- amHtml- return $ if ah- then "\\begin{rawhtml}" : "<div class=\"cmd-opt-hdr\">" : rest- else ("\\begin{Verbatim}[frame=lines,xleftmargin=1cm," ++- "xrightmargin=1cm]") : rest-preproc ("\\end{options}":ss) =- do rest <- preproc ss- ah <- amHtml- return $ if ah- then "</div>" : "\\end{rawhtml}" : rest- else "\\end{Verbatim}" : rest-preproc ("\\darcsVersion":ss) = do- rest <- preproc ss- return $ version:rest-preproc (s:ss) = do- rest <- preproc ss- let rx = mkRegex "^\\\\(input|darcsCommand|darcsEnv)\\{(.+)\\}$"- case matchRegex rx s of- Just ["input", path] ->- do cs <- Ratified.readFile $ "doc" </> "src" </> path -- not part of normal darcs operation- this <- preproc $ lines cs- return $ this ++ rest- Just ["darcsCommand", command] ->- return $ latexCommandHelp command : rest- Just ["darcsEnv", variable] ->- return $ envHelp variable : rest- -- The base case for the whole preproc function. Nothing to- -- mangle, so this is an ordinary line of TeX, and we append it to- -- the result unmodified.- _ -> return $ s : rest--latexCommandHelp :: String -> String-latexCommandHelp command = section ++ "{darcs " ++ command ++ "}\n" ++- "\\label{" ++ command ++ "}\n" ++- gh ++ getOptions command ++ "\n" ++ gd- where- section = if ' ' `elem` command then "\\subsubsection" else "\\subsection"- -- | Given a Darcs command name as a string, return that command's (multi-line) help string.- gh :: String- gh = escapeLatexSpecials $ commandProperty commandHelp theCommands command- -- | Given a Darcs command name as a string, return that command's (one-line) description string.- gd :: String- gd = commandProperty commandDescription theCommands command--getOptions :: String -> String-getOptions comm = getComOptions $ getC names theCommands- where names = words comm--getC :: [String] -> [DarcsCommand] -> [DarcsCommand]-getC (name:ns) commands =- case ns of- [] -> [get name commands]- _ -> case get name commands of- c@SuperCommand { } ->- c : getC ns (extractCommands $ commandSubCommands c)- _ ->- error $ "Not a supercommand: " ++ name- where get n (c:cs) | commandName c == n = c- | otherwise = get n cs- get n [] = error $ "No such command: "++n-getC [] _ = error "no command specified"--getComOptions :: [DarcsCommand] -> String-getComOptions c =- "\\par\\verb!Usage: darcs " ++ cmd ++ " [OPTION]... " ++- args ++ "!\n\n" ++ "Options:\n\n" ++ optionsLatex opts1 ++- (if null opts2 then "" else "\n\n" ++ "Advanced options:\n\n" ++ optionsLatex opts2)- where cmd = unwords $ map commandName c- args = unwords $ commandExtraArgHelp $ last c- opts1 = commandBasicOptions $ last c- opts2 = commandAdvancedOptions $ last c--commandProperty :: (DarcsCommand -> String) -> [DarcsCommand] -> String- -> String-commandProperty property commands name =- property $ last c- where names = words name- c = getC names commands----envHelp :: String -> String-envHelp var = unlines $ render $ entry environmentHelp- where render (ks, ds) =- ("\\paragraph{" ++ escapeLatexSpecials (andClauses ks) ++ "}") :- ("\\label{env:" ++ var ++ "}") :- map escapeLatexSpecials ds- entry [] = undefined- entry (x:xs) | elem var $ fst x = x- | otherwise = entry xs---- | LaTeX treats a number of characters or sequences specially.--- Therefore when including ordinary help text in a LaTeX document, it--- is necessary to escape these characters in the way LaTeX expects.-escapeLatexSpecials :: String -> String--- Order is important-escapeLatexSpecials =- bs2 . amp . percent . carrot . dollar . underscore . rbrace . lbrace . bs1- where- amp = replace "&" "\\&"- bs1 = replace "\\" "\001"- bs2 = replace "\001" "$\\backslash$"- carrot = replace "^" "\\^{}"- dollar = replace "$" "\\$"- lbrace = replace "{" "\\{"- percent = replace "%" "\\%"- rbrace = replace "}" "\\}"- underscore = replace "_" "\\_"-- replace :: Eq a => [a] -> [a] -> [a] -> [a]- replace _ _ [] = []- replace find repl s =- case stripPrefix find s of- Just rest -> repl ++ replace find repl rest- Nothing -> head s : replace find repl (tail s)
− src/Printer.lhs
@@ -1,425 +0,0 @@--A Document is at heart ShowS from the prelude-\htmladdnormallink{http://www.haskell.org/onlinereport/standard-prelude.html#\$tShowS}--Essentially, if you give a Doc a string it'll print out whatever it-wants followed by that string. So \verb!(text "foo")! makes the Doc that-prints \verb!"foo"! followed by its argument. The combinator names are taken-from Text.PrettyPrint.HughesPJ, although the behaviour of the two libraries is-slightly different.--The advantage of Printer over simple string appending/concatenating is-that the appends end up associating to the right, e.g.:--\begin{verbatim}- (text "foo" <> text "bar") <> (text "baz" <> text "quux") ""-= \s -> (text "foo" <> text "bar") ((text "baz" <> text "quux") s) ""-= (text "foo" <> text "bar") ((text "baz" <> text "quux") "")-= (\s -> (text "foo") (text "bar" s)) ((text "baz" <> text "quux") "")-= text "foo" (text "bar" ((text "baz" <> text "quux") ""))-= (\s -> "foo" ++ s) (text "bar" ((text "baz" <> text "quux") ""))-= "foo" ++ (text "bar" ((text "baz" <> text "quux") ""))-= "foo" ++ ("bar" ++ ((text "baz" <> text "quux") ""))-= "foo" ++ ("bar" ++ ((\s -> text "baz" (text "quux" s)) ""))-= "foo" ++ ("bar" ++ (text "baz" (text "quux" "")))-= "foo" ++ ("bar" ++ ("baz" ++ (text "quux" "")))-= "foo" ++ ("bar" ++ ("baz" ++ ("quux" ++ "")))-\end{verbatim}--The Empty alternative comes in because you want-\begin{verbatim}- text "a" $$ vcat xs $$ text "b"-\end{verbatim}-(\verb!$$! means ``above'', vcat is the list version of \verb!$$!) to be-\verb!"a\nb"! when \verb!xs! is \verb![]!, but without the concept of an-Empty Document each \verb!$$! would add a \verb!'\n'! and you'd end up with-\verb!"a\n\nb"!. Note that \verb!Empty /= text ""! (the latter would cause two-\verb!'\n'!s).--This code was made generic in the element type by Juliusz Chroboczek.-\begin{code}-module Printer (Printable(..), Doc(Doc,unDoc), Printers, Printers'(..), Printer, Color(..),- hPutDoc, hPutDocLn, putDoc, putDocLn,- hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith,- renderString, renderStringWith, renderPS, renderPSWith,- renderPSs, renderPSsWith, lineColor,- prefix, insertBeforeLastline, colorText, invisibleText,- hiddenText, hiddenPrefix, userchunk, text,- printable, wrapText,- blueText, redText, greenText, magentaText, cyanText,- unsafeText, unsafeBoth, unsafeBothText, unsafeChar,- invisiblePS, packedString, unsafePackedString, userchunkPS,- simplePrinters, invisiblePrinter, simplePrinter,- doc, empty, (<>), (<?>), (<+>), ($$), vcat, vsep, hcat,- minus, newline, plus, space, backslash, lparen, rparen,- parens,- errorDoc,- ) where--import Data.List (intersperse)-import System.IO (Handle, stdout, hPutStr)-import ByteStringUtils ( linesPS )-import qualified Data.ByteString as B (ByteString, hPut, concat)-import qualified Data.ByteString.Char8 as BC (unpack, pack, singleton)---- | A 'Printable' is either a String, a packed string, or a chunk of--- text with both representations.-data Printable = S !String- | PS !B.ByteString- | Both !String !B.ByteString---- | 'spaceP' is the 'Printable' representation of a space.-spaceP :: Printable-spaceP = Both " " (BC.singleton ' ')---- | 'newlineP' is the 'Printable' representation of a newline.-newlineP :: Printable-newlineP = S "\n"---- | Minimal 'Doc's representing the common characters 'space', 'newline'--- 'minus', 'plus', and 'backslash'.-space, newline, plus, minus, backslash :: Doc-space = unsafeBoth " " (BC.singleton ' ')-newline = unsafeChar '\n'-minus = unsafeBoth "-" (BC.singleton '-')-plus = unsafeBoth "+" (BC.singleton '+')-backslash = unsafeBoth "\\" (BC.singleton '\\')---- | 'lparen' is the 'Doc' that represents @\"(\"@-lparen :: Doc-lparen = unsafeBoth "(" (BC.singleton '(')---- | 'rparen' is the 'Doc' that represents @\")\"@-rparen :: Doc-rparen = unsafeBoth ")" (BC.singleton ')')---- | @'parens' doc@ returns a 'Doc' with the content of @doc@ put within--- a pair of parenthesis.-parens :: Doc -> Doc-parens d = lparen <> d <> rparen--errorDoc :: Doc -> a-errorDoc = error . renderStringWith simplePrinters'----- | 'putDocWith' puts a doc on stdout using the given printer.-putDocWith :: Printers -> Doc -> IO ()-putDocWith prs = hPutDocWith prs stdout---- | 'putDocLnWith' puts a doc, followed by a newline on stdout using--- the given printer.-putDocLnWith :: Printers -> Doc -> IO ()-putDocLnWith prs = hPutDocLnWith prs stdout----- | 'putDoc' puts a doc on stdout using the simple printer 'simplePrinters'.-putDoc :: Doc -> IO ()--- | 'putDocLn' puts a doc, followed by a newline on stdout using--- 'simplePrinters'-putDocLn :: Doc -> IO ()-putDoc = hPutDoc stdout-putDocLn = hPutDocLn stdout---- | 'hputDocWith' puts a doc on the given handle using the given printer.-hPutDocWith :: Printers -> Handle -> Doc -> IO ()--- | 'hputDocLnWith' puts a doc, followed by a newline on the given--- handle using the given printer.-hPutDocLnWith :: Printers -> Handle -> Doc -> IO ()--hPutDocWith prs h d = hPrintPrintables h (renderWith (prs h) d)-hPutDocLnWith prs h d = hPutDocWith prs h (d <?> newline)---- |'hputDoc' puts a doc on the given handle using 'simplePrinters'-hPutDoc :: Handle -> Doc -> IO ()--- 'hputDocLn' puts a doc, followed by a newline on the given handle using--- 'simplePrinters'.-hPutDocLn :: Handle -> Doc -> IO ()-hPutDoc = hPutDocWith simplePrinters-hPutDocLn = hPutDocLnWith simplePrinters---- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle h-hPrintPrintables :: Handle -> [Printable] -> IO ()-hPrintPrintables h = mapM_ (hPrintPrintable h)---- | @hPrintPrintable h@ prints a 'Printable' to the handle h.-hPrintPrintable :: Handle -> Printable -> IO ()-hPrintPrintable h (S ps) = hPutStr h ps-hPrintPrintable h (PS ps) = B.hPut h ps-hPrintPrintable h (Both _ ps) = B.hPut h ps---- | a 'Doc' is a bit of enriched text. 'Doc's get concatanated using--- '<>', which is right-associative.-newtype Doc = Doc { unDoc :: St -> Document }---- | The State associated with a doc. Contains a set of printers for each--- hanlde, and the current prefix of the document.-data St = St { printers :: !Printers',- currentPrefix :: !([Printable] -> [Printable]) }-type Printers = Handle -> Printers'---- | A set of printers to print different types of text to a handle.-data Printers' = Printers {colorP :: !(Color -> Printer),- invisibleP :: !Printer,- hiddenP :: !Printer,- userchunkP :: !Printer,- defP :: !Printer,- lineColorT :: !(Color -> Doc -> Doc),- lineColorS :: !([Printable] -> [Printable])- }-type Printer = Printable -> St -> Document--data Color = Blue | Red | Green | Cyan | Magenta---- | 'Document' is a wrapper around '[Printable] -> [Printable]' which allows--- for empty Documents. The simplest 'Documents' are built from 'String's--- using 'text'.-data Document = Document ([Printable] -> [Printable])- | Empty---- | renders a 'Doc' into a 'String' with control codes for the--- special features of the doc.-renderString :: Doc -> String-renderString = renderStringWith simplePrinters'---- | renders a 'Doc' into a 'String' using a given set of printers.-renderStringWith :: Printers' -> Doc -> String-renderStringWith prs d = concatMap toString $ renderWith prs d- where toString (S s) = s- toString (PS ps) = BC.unpack ps- toString (Both s _) = s---- | renders a 'Doc' into 'B.ByteString' with control codes for the--- special features of the Doc. See also 'readerString'.-renderPS :: Doc -> B.ByteString-renderPS = renderPSWith simplePrinters'---- | renders a 'Doc' into a list of 'PackedStrings', one for each line.-renderPSs :: Doc -> [B.ByteString]-renderPSs = renderPSsWith simplePrinters'---- | renders a doc into a 'B.ByteString' using a given set of printers.-renderPSWith :: Printers' -> Doc -> B.ByteString-renderPSWith prs d = B.concat $ renderPSsWith prs d---- | renders a 'Doc' into a list of 'PackedStrings', one for each--- chunk of text that was added to the doc, using the given set of--- printers.-renderPSsWith :: Printers' -> Doc -> [B.ByteString]-renderPSsWith prs d = map toPS $ renderWith prs d- where toPS (S s) = BC.pack s- toPS (PS ps) = ps- toPS (Both _ ps) = ps---- | renders a 'Doc' into a list of 'Printables' using a set of--- printers. Each item of the list corresponds to a string that was--- added to the doc.-renderWith :: Printers' -> Doc -> [Printable]-renderWith ps (Doc d) = case d (initState ps) of- Empty -> []- Document f -> f []--initState :: Printers' -> St-initState prs = St { printers = prs, currentPrefix = id }--prefix :: String -> Doc -> Doc-prefix s (Doc d) = Doc $ \st ->- let p = S s- st' = st { currentPrefix = currentPrefix st . (p:) } in- case d st' of- Document d'' -> Document $ (p:) . d''- Empty -> Empty---insertBeforeLastline :: Doc -> Doc -> Doc-insertBeforeLastline a b =- case reverse $ map packedString $ linesPS $ renderPS a of- (ll:ls) -> vcat (reverse ls) $$ b $$ ll- [] -> error "empty Doc given as first argument of Printer.insert_before_last_line"---lineColor :: Color -> Doc -> Doc-lineColor c d = Doc $ \st -> case lineColorT (printers st) c d of- Doc d' -> d' st--hiddenPrefix :: String -> Doc -> Doc-hiddenPrefix s (Doc d) =- Doc $ \st -> let pr = printers st- p = S (renderStringWith pr $ hiddenText s)- st' = st { currentPrefix = currentPrefix st . (p:) }- in case d st' of- Document d'' -> Document $ (p:) . d''- Empty -> Empty---- | 'unsafeBoth' builds a Doc from a 'String' and a 'B.ByteString' representing--- the same text, but does not check that they do.-unsafeBoth :: String -> B.ByteString -> Doc-unsafeBoth s ps = Doc $ simplePrinter (Both s ps)---- | 'unsafeBothText' builds a 'Doc' from a 'String'. The string is stored in the--- Doc as both a String and a 'B.ByteString'.-unsafeBothText :: String -> Doc-unsafeBothText s = Doc $ simplePrinter (Both s (BC.pack s))---- | 'packedString' builds a 'Doc' from a 'B.ByteString' using 'printable'-packedString :: B.ByteString -> Doc--- | 'unsafePackedString' builds a 'Doc' from a 'B.ByteString' using 'simplePrinter'-unsafePackedString :: B.ByteString -> Doc--- | 'invisiblePS' creates a 'Doc' with invisible text from a 'B.ByteString'-invisiblePS :: B.ByteString -> Doc--- | 'userchunkPS' creates a 'Doc' representing a user chunk from a 'B.ByteString'.-userchunkPS :: B.ByteString -> Doc-packedString = printable . PS-unsafePackedString = Doc . simplePrinter . PS-invisiblePS = invisiblePrintable . PS-userchunkPS = userchunkPrintable . PS---- | 'unsafeChar' creates a Doc containing just one character.-unsafeChar :: Char -> Doc-unsafeChar = unsafeText . (:"")---- | 'text' creates a 'Doc' from a @String@, using 'printable'.-text :: String -> Doc--- | 'unsafeText' creates a 'Doc' from a 'String', using 'simplePrinter' directly-unsafeText :: String -> Doc--- | 'invisibleText' creates a 'Doc' containing invisible text from a @String@-invisibleText :: String -> Doc--- | 'hiddenText' creates a 'Doc' containing hidden text from a @String@-hiddenText :: String -> Doc--- | 'userchunk' creates a 'Doc' containing a user chunk from a @String@-userchunk :: String -> Doc--- | 'blueText' creates a 'Doc' containing blue text from a @String@-blueText, redText, greenText, magentaText, cyanText :: String -> Doc-text = printable . S-unsafeText = Doc . simplePrinter . S-invisibleText = invisiblePrintable . S-hiddenText = hiddenPrintable . S-userchunk = userchunkPrintable . S-blueText = colorText Blue-redText = colorText Red-greenText = colorText Green-magentaText = colorText Magenta-cyanText = colorText Cyan---- | 'colorText' creates a 'Doc' containing colored text from a @String@-colorText :: Color -> String -> Doc-colorText c = mkColorPrintable c . S---- | @'wrapText' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters-wrapText :: Int -> String -> Doc-wrapText n s =- vcat $ map text $ reverse $ "": (foldl add_to_line [] $ words s)- where add_to_line [] a = [a]- add_to_line ("":d) a = (a:d)- add_to_line (l:ls) new | length l + length new > n = new:l:ls- add_to_line (l:ls) new = (l ++ " " ++ new):ls---- | 'printable x' creates a 'Doc' from any 'Printable'.-printable, invisiblePrintable, hiddenPrintable, userchunkPrintable :: Printable -> Doc-printable x = Doc $ \st -> defP (printers st) x st--mkColorPrintable :: Color -> Printable -> Doc-mkColorPrintable c x = Doc $ \st -> colorP (printers st) c x st-invisiblePrintable x = Doc $ \st -> invisibleP (printers st) x st-hiddenPrintable x = Doc $ \st -> hiddenP (printers st) x st-userchunkPrintable x = Doc $ \st -> userchunkP (printers st) x st---- | 'simplePrinters' is a 'Printers' which uses the set 'simplePriners\'' on any--- handle.-simplePrinters :: Printers-simplePrinters _ = simplePrinters'---- | A set of default printers suitable for any handle. Does not use color.-simplePrinters' :: Printers'-simplePrinters' = Printers { colorP = const simplePrinter,- invisibleP = simplePrinter,- hiddenP = invisiblePrinter,- userchunkP = simplePrinter,- defP = simplePrinter,- lineColorT = const id,- lineColorS = id- }---- | 'simplePrinter' is the simplest 'Printer': it just concatenates together--- the pieces of the 'Doc'-simplePrinter :: Printer--- | 'invisiblePrinter' is the 'Printer' for hidden text. It just replaces--- the document with 'empty'. It's useful to have a printer that doesn't--- actually do anything because this allows you to have tunable policies,--- for example, only printing some text if it's to the terminal, but not--- if it's to a file or vice-versa.-invisiblePrinter :: Printer-simplePrinter x = unDoc $ doc (\s -> x:s)-invisiblePrinter _ = unDoc empty--infixr 6 <>-infixr 6 <+>-infixr 5 $$---- | The empty 'Doc'.-empty :: Doc-empty = Doc $ const Empty-doc :: ([Printable] -> [Printable]) -> Doc-doc f = Doc $ const $ Document f---- | '(<>)' is the concatenation operator for 'Doc's-(<>) :: Doc -> Doc -> Doc--- | @a '<?>' b@ is @a <> b@ if @a@ is not empty, else empty.-(<?>) :: Doc -> Doc -> Doc--- | @a '<+>' b@ is @a@ followed by a space, then @b@.-(<+>) :: Doc -> Doc -> Doc--- | @a '$$' b@ is @a@ above @b@.-($$) :: Doc -> Doc -> Doc--- a then b-Doc a <> Doc b =- Doc $ \st -> case a st of- Empty -> b st- Document af ->- Document (\s -> af $ case b st of- Empty -> s- Document bf -> bf s)---- empty if a empty, else a then b-Doc a <?> Doc b =- Doc $ \st -> case a st of- Empty -> Empty- Document af -> Document (\s -> af $ case b st of- Empty -> s- Document bf -> bf s)---- a then space then b-Doc a <+> Doc b =- Doc $ \st -> case a st of- Empty -> b st- Document af -> Document (\s -> af $ case b st of- Empty -> s- Document bf ->- spaceP:bf s)---- a above b-Doc a $$ Doc b =- Doc $ \st -> case a st of- Empty -> b st- Document af ->- Document (\s -> af $ case b st of- Empty -> s- Document bf -> sf (newlineP:pf (bf s)))- where pf = currentPrefix st- sf = lineColorS $ printers st---- | 'vcat' piles vertically a list of 'Doc's.-vcat :: [Doc] -> Doc-vcat [] = empty-vcat ds = foldr1 ($$) ds---- | 'vsep' piles vertically a list of 'Doc's leaving a blank line between each.-vsep :: [Doc] -> Doc-vsep [] = empty-vsep ds = foldr1 ($$) $ intersperse (text "") ds---- | 'hcat' concatenates (horizontally) a list of 'Doc's-hcat :: [Doc] -> Doc-hcat [] = empty-hcat ds = foldr1 (<>) ds--\end{code}-
− src/Progress.hs
@@ -1,305 +0,0 @@-{-# LANGUAGE CPP #-}--#include "gadts.h"---- |--- Module : Progress--- Copyright : 2008 David Roundy--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable------ Utility functions for tracking progress of long-running actions.--module Progress- (- beginTedious- , endTedious- , tediousSize- , debugMessage- , debugFail- , withoutProgress- , progress- , progressKeepLatest- , finishedOne- , finishedOneIO- , progressList- , minlist- , setProgressMode- ) where---import Prelude hiding (lookup)--import Control.Exception.Extensible ( onException )-import Control.Monad ( when )-import Control.Concurrent ( forkIO, threadDelay )--import Data.Char ( toLower )-import Data.Map ( Map, empty, adjust, insert, delete, lookup )-import Data.Maybe ( isJust )-import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )--import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn,- hSetBuffering, hIsTerminalDevice,- Handle, BufferMode(LineBuffering) )-import System.IO.Unsafe ( unsafePerformIO )--import Darcs.Global ( withDebugMode, debugMessage, putTiming, debugFail )---data ProgressData = ProgressData- { sofar :: !Int- , latest :: !(Maybe String)- , total :: !(Maybe Int)- }--handleProgress :: IO ()-handleProgress = do- threadDelay 1000000- handleMoreProgress "" 0---handleMoreProgress :: String -> Int -> IO ()-handleMoreProgress k n = withProgressMode $ \m ->- if m then do s <- getProgressLast- mp <- getProgressData s- case mp of- Nothing -> do- threadDelay 1000000- handleMoreProgress k n- Just p -> do- when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p- threadDelay 1000000- handleMoreProgress s (sofar p)- else do threadDelay 1000000- handleMoreProgress k n---printProgress :: String- -> ProgressData- -> IO ()-printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) =- myput output output- where- output = k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued. " ++ l-printProgress k (ProgressData {latest=Just l}) =- myput (k ++ " " ++ l) k-printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s =- myput (k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued")- (k ++ " " ++ show s)-printProgress k (ProgressData {sofar=s}) =- myput (k ++ " " ++ show s) k---myput :: String -> String -> IO ()-myput l s = withDebugMode $ \debugMode ->- if debugMode- then putTiming >> hPutStrLn stderr l- else- if '\n' `elem` l- then myput (takeWhile (/= '\n') l) s- else putTiming >> if length l < 80- then simpleput l- else simpleput (take 80 s)---simpleput :: String -> IO ()-simpleput = unsafePerformIO $ mkhPutCr stderr-{-# NOINLINE simpleput #-}----- | @beginTedious k@ starts a tedious process and registers it in--- '_progressData' with the key @k@. A tedious process is one for which we want--- a progress indicator.------ Wouldn't it be safer if it had type String -> IO ProgressDataKey, so that we--- can ensure there is no collision? What happens if you call beginTedious twice--- with the same string, without calling endTedious in the meantime?-beginTedious :: String -> IO ()-beginTedious k = do- debugMessage $ "Beginning " ++ map toLower k- setProgressData k $ ProgressData- { sofar = 0- , latest = Nothing- , total = Nothing- }----- | @endTedious k@ unregisters the tedious process with key @k@, printing--- "Done" if such a tedious process exists.-endTedious :: String -> IO ()-endTedious k = whenProgressMode $ do- p <- getProgressData k- modifyIORef _progressData (\(a,m) -> (a,delete k m))- when (isJust p) $ debugMessage $ "Done " ++- (map toLower k)---tediousSize :: String- -> Int- -> IO ()-tediousSize k s = updateProgressData k uptot- where- uptot p = case total p of- Just t -> seq ts $ p { total = Just ts }- where ts = t + s- Nothing -> p { total = Just s }----- | XXX: document this constant-minlist :: Int-minlist = 4---progressList :: String- -> [a]- -> [a]-progressList _ [] = []-progressList k (x:xs) = if l < minlist- then x:xs- else startit x : pl xs- where- l = length (x:xs)-- startit y = unsafePerformIO $ do- beginTedious k- tediousSize k l- return y-- pl [] = []- pl [y] = unsafePerformIO $ do- endTedious k- return [y]- pl (y:ys) = progress k y : pl ys---progress :: String- -> a- -> a-progress k a = unsafePerformIO $ progressIO k >> return a---progressIO :: String -> IO ()-progressIO "" = return ()-progressIO k = do- updateProgressData k $ \p ->- p { sofar = sofar p + 1, latest = Nothing }- putDebug k ""---progressKeepLatest :: String- -> a- -> a-progressKeepLatest k a = unsafePerformIO $ progressKeepLatestIO k >> return a---progressKeepLatestIO :: String -> IO ()-progressKeepLatestIO "" = return ()-progressKeepLatestIO k = do- updateProgressData k (\p -> p {sofar = sofar p + 1})- putDebug k ""---finishedOne :: String -> String -> a -> a-finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a---finishedOneIO :: String -> String -> IO ()-finishedOneIO "" _ = return ()-finishedOneIO k l = do- updateProgressData k (\p -> p { sofar = sofar p + 1,- latest = Just l })- putDebug k l---putDebug :: String- -> String- -> IO ()-putDebug _ _ = return ()---putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k---putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++l---_progressMode :: IORef Bool-_progressMode = unsafePerformIO $ do- hSetBuffering stderr LineBuffering- newIORef True-{-# NOINLINE _progressMode #-}--_progressData :: IORef (String, Map String ProgressData)-_progressData = unsafePerformIO $ do- _ <- forkIO handleProgress- newIORef ("", empty)-{-# NOINLINE _progressData #-}---mkhPutCr :: Handle- -> IO (String -> IO ())-mkhPutCr fe = do- isTerm <- hIsTerminalDevice fe- stdoutIsTerm <- hIsTerminalDevice stdout- return $- if isTerm- then \s -> do- hPutStr fe $ '\r':s ++ "\r"- hFlush fe- let spaces = '\r':replicate (length s) ' ' ++ "\r"- hPutStr fe spaces- when stdoutIsTerm $ hPutStr stdout spaces- else \s -> when (not $ null s) $ do hPutStrLn fe s- hFlush fe---setProgressMode :: Bool -> IO ()-setProgressMode m = writeIORef _progressMode m---withoutProgress :: IO a -> IO a-withoutProgress j = withProgressMode $ \m -> do- debugMessage "Disabling progress reports..."- setProgressMode False- a <- j `onException` setProgressMode m- if m then debugMessage "Reenabling progress reports."- else debugMessage "Leaving progress reports off."- setProgressMode m- return a---updateProgressData :: String- -> (ProgressData -> ProgressData)- -> IO ()-updateProgressData k f =- whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m))---setProgressData :: String- -> ProgressData- -> IO ()-setProgressData k p =- whenProgressMode $ modifyIORef _progressData (\(a,m) -> (a,insert k p m))---getProgressData :: String -> IO (Maybe ProgressData)-getProgressData k = withProgressMode $ \p ->- if p- then (lookup k . snd) `fmap` readIORef _progressData- else return Nothing---getProgressLast :: IO String-getProgressLast = withProgressMode $ \p ->- if p- then fst `fmap` readIORef _progressData- else return ""---whenProgressMode :: IO a -> IO ()-whenProgressMode j = withProgressMode $ const $ j >> return ()---withProgressMode :: (Bool -> IO a) -> IO a-withProgressMode j = readIORef _progressMode >>= j--
− src/Ratified.hs
@@ -1,8 +0,0 @@--- | XXX: Perhaps a word of explanation here [WL]-module Ratified- (- readFile- , hGetContents- ) where--import System.IO( hGetContents )
− src/SHA1.hs
@@ -1,212 +0,0 @@--- Copyright (C) 2001, 2004 Ian Lynagh <igloo@earth.li>------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- name shadowing disabled because a,b,c,d,e are shadowed loads in step 4-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}--{-# LANGUAGE CPP #-}---- |--- Module : SHA1--- Copyright : 2001, 2004 Ian Lynagh <igloo@earth.li>--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module SHA1 (sha1PS) where--import ByteStringUtils (unsafeWithInternals)-import qualified Data.ByteString as B (ByteString, pack, length, concat)--import Data.Char (intToDigit)-import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR)-import Data.Word (Word8, Word32)-import Foreign.Ptr (Ptr, castPtr)-import Foreign.Marshal.Array (advancePtr)-import Foreign.Storable (peek, poke)-import System.IO.Unsafe (unsafePerformIO)--data ABCDE = ABCDE !Word32 !Word32 !Word32 !Word32 !Word32-data XYZ = XYZ !Word32 !Word32 !Word32--sha1PS :: B.ByteString -> String-sha1PS s = s5- where s1_2 = sha1Step12PadLength s- abcde = sha1Step3Init- abcde' = unsafePerformIO- $ unsafeWithInternals s1_2 (\ptr len ->- do let ptr' = castPtr ptr-#ifndef BIGENDIAN- fiddleEndianness ptr' len-#endif- sha1Step4Main abcde ptr' len)- s5 = sha1Step5Display abcde'--fiddleEndianness :: Ptr Word32 -> Int -> IO ()-fiddleEndianness p 0 = p `seq` return ()-fiddleEndianness p n- = do x <- peek p- poke p $ shiftL x 24- .|. shiftL (x .&. 0xff00) 8- .|. (shiftR x 8 .&. 0xff00)- .|. shiftR x 24- fiddleEndianness (p `advancePtr` 1) (n - 4)---- sha1Step12PadLength assumes the length is at most 2^61.--- This seems reasonable as the Int used to represent it is normally 32bit,--- but obviously could go wrong with large inputs on 64bit machines.--- The B.ByteString library should probably move to Word64s if this is an--- issue, though.--sha1Step12PadLength :: B.ByteString -> B.ByteString-sha1Step12PadLength s- = let len = B.length s- num_nuls = (55 - len) `mod` 64- padding = 128:replicate num_nuls 0- len_w8s = reverse $ sizeSplit 8 (fromIntegral len*8)- in B.concat [s, B.pack padding, B.pack len_w8s]--sizeSplit :: Int -> Integer -> [Word8]-sizeSplit 0 _ = []-sizeSplit p n = fromIntegral d:sizeSplit (p-1) n'- where (n', d) = divMod n 256--sha1Step3Init :: ABCDE-sha1Step3Init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0--sha1Step4Main :: ABCDE -> Ptr Word32 -> Int -> IO ABCDE-sha1Step4Main abcde _ 0 = return $! abcde-sha1Step4Main (ABCDE a0@a b0@b c0@c d0@d e0@e) s len- = do- (e, b) <- doit f1 0x5a827999 (x 0) a b c d e- (d, a) <- doit f1 0x5a827999 (x 1) e a b c d- (c, e) <- doit f1 0x5a827999 (x 2) d e a b c- (b, d) <- doit f1 0x5a827999 (x 3) c d e a b- (a, c) <- doit f1 0x5a827999 (x 4) b c d e a- (e, b) <- doit f1 0x5a827999 (x 5) a b c d e- (d, a) <- doit f1 0x5a827999 (x 6) e a b c d- (c, e) <- doit f1 0x5a827999 (x 7) d e a b c- (b, d) <- doit f1 0x5a827999 (x 8) c d e a b- (a, c) <- doit f1 0x5a827999 (x 9) b c d e a- (e, b) <- doit f1 0x5a827999 (x 10) a b c d e- (d, a) <- doit f1 0x5a827999 (x 11) e a b c d- (c, e) <- doit f1 0x5a827999 (x 12) d e a b c- (b, d) <- doit f1 0x5a827999 (x 13) c d e a b- (a, c) <- doit f1 0x5a827999 (x 14) b c d e a- (e, b) <- doit f1 0x5a827999 (x 15) a b c d e- (d, a) <- doit f1 0x5a827999 (m 16) e a b c d- (c, e) <- doit f1 0x5a827999 (m 17) d e a b c- (b, d) <- doit f1 0x5a827999 (m 18) c d e a b- (a, c) <- doit f1 0x5a827999 (m 19) b c d e a- (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e- (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d- (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c- (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b- (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a- (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e- (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d- (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c- (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b- (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a- (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e- (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d- (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c- (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b- (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a- (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e- (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d- (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c- (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b- (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a- (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e- (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d- (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c- (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b- (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a- (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e- (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d- (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c- (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b- (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a- (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e- (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d- (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c- (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b- (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a- (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e- (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d- (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c- (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b- (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a- (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e- (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d- (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c- (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b- (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a- (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e- (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d- (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c- (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b- (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a- (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e- (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d- (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c- (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b- (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a- (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e- (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d- (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c- (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b- (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a- let abcde' = ABCDE (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e)- sha1Step4Main abcde' (s `advancePtr` 16) (len - 64)- where {-# INLINE f1 #-}- f1 (XYZ x y z) = (x .&. y) .|. ((complement x) .&. z)- {-# INLINE f2 #-}- f2 (XYZ x y z) = x `xor` y `xor` z- {-# INLINE f3 #-}- f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z)- {-# INLINE x #-}- x n = peek (s `advancePtr` n)- {-# INLINE m #-}- m n = do let base = s `advancePtr` (n .&. 15)- x0 <- peek base- x1 <- peek (s `advancePtr` ((n - 14) .&. 15))- x2 <- peek (s `advancePtr` ((n - 8) .&. 15))- x3 <- peek (s `advancePtr` ((n - 3) .&. 15))- let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1- poke base res- return res- {-# INLINE doit #-}- doit f k i a b c d e = a `seq` c `seq`- do i' <- i- return (rotateL a 5 + f (XYZ b c d) + e + i' + k,- rotateL b 30)--sha1Step5Display :: ABCDE -> String-sha1Step5Display (ABCDE a b c d e)- = concatMap showAsHex [a, b, c, d, e]--showAsHex :: Word32 -> String-showAsHex n = showIt 8 n ""- where- showIt :: Int -> Word32 -> String -> String- showIt 0 _ r = r- showIt i x r = case quotRem x 16 of- (y, z) -> let c = intToDigit (fromIntegral z)- in c `seq` showIt (i-1) y (c:r)
− src/URL.hs
@@ -1,332 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}---- |--- Module : URL--- Copyright : 2008 Dmitry Kurochkin <dmitry.kurochkin@gmail.com>--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module URL ( copyUrl, copyUrlFirst, setDebugHTTP,- disableHTTPPipelining, maxPipelineLength,- waitUrl, Cachable(Cachable, Uncachable, MaxAge),- environmentHelpProxy, environmentHelpProxyPassword,- ConnectionError(..),- ) where--import Data.IORef ( newIORef, readIORef, writeIORef, IORef )-import Data.Map ( Map )-import qualified Data.Map as Map-import System.Directory ( copyFile )-import System.IO.Unsafe ( unsafePerformIO )-import Control.Concurrent ( forkIO )-import Control.Concurrent.Chan ( isEmptyChan, newChan, readChan, writeChan, Chan )-import Control.Concurrent.MVar ( isEmptyMVar, modifyMVar_, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, withMVar, MVar )-import Control.Monad ( unless, when )-import Control.Monad.Trans ( liftIO )-import Control.Monad.State ( evalStateT, get, modify, put, StateT )--import Workaround ( renameFile )-import Darcs.Global ( atexit )-import Progress ( debugMessage )-import Darcs.Lock ( removeFileMayNotExist )--import Numeric ( showHex )-import System.Random ( randomRIO )-import URL.Request--#ifdef HAVE_CURL-import qualified URL.Curl as Curl-#elif defined(HAVE_HTTP)-import qualified URL.HTTP as HTTP -#else-import Progress ( debugFail )-import qualified HTTP ( requestUrl, waitNextUrl )-#endif-#include "impossible.h"--{-# NOINLINE maxPipelineLengthRef #-}-maxPipelineLengthRef :: IORef Int-maxPipelineLengthRef = unsafePerformIO $ do- enabled <- pipeliningEnabled-#ifdef HAVE_CURL- when (not enabled) (debugMessage $- "Warning: pipelining is disabled, because libcurl "++- "version darcs was compiled with is too old (< 7.19.1)")-#endif- newIORef $ if enabled then 100 else 1--maxPipelineLength :: IO Int-maxPipelineLength = readIORef maxPipelineLengthRef--{-# NOINLINE urlNotifications #-}-urlNotifications :: MVar (Map String (MVar String))-urlNotifications = unsafePerformIO $ newMVar Map.empty--{-# NOINLINE urlChan #-}-urlChan :: Chan UrlRequest-urlChan = unsafePerformIO $ do- ch <- newChan--- Warning: A do-notation statement discarded a result of type GHC.Conc.ThreadId.- _ <- forkIO (urlThread ch)- return ch---- ------------------------------------------------------------------------- urlThread--- ------------------------------------------------------------------------type UrlM a = StateT UrlState IO a--urlThread :: Chan UrlRequest -> IO ()-urlThread ch = do junk <- flip showHex "" `fmap` randomRIO rrange- evalStateT (urlThread' ch) (UrlState Map.empty emptyQ 0 junk)- where rrange = (0, 2^(128 :: Integer) :: Integer)---- | Internal to urlThread-urlThread' :: Chan UrlRequest -> UrlM ()-urlThread' ch = do- empty <- liftIO $ isEmptyChan ch- st <- get- let l = pipeLength st- w = waitToStart st- reqs <- if not empty || (nullQ w && l == 0)- then liftIO (readAllRequests ch)- else return []- mapM_ addReq reqs- checkWaitToStart- waitNextUrl- urlThread' ch---- | Internal to urlThread-readAllRequests :: Chan UrlRequest -> IO [UrlRequest]-readAllRequests ch = do- r <- readChan ch- debugMessage $ "URL.urlThread ("++url r++"\n"++- " -> "++file r++")"- empty <- isEmptyChan ch- reqs <- if not empty- then readAllRequests ch- else return []- return (r:reqs)---- | Internal to urlThread-addReq :: UrlRequest -> UrlM ()-addReq r = do- d <- liftIO (alreadyDownloaded u)- if d- then dbg "Ignoring UrlRequest of URL that is already downloaded."- else reallyAdd- where- f = file r- c = cachable r- u = url r- reallyAdd = do- st <- get- let p = inProgress st- w = waitToStart st- e = (f, [], c)- new_w = case priority r of- High -> pushQ u w- Low -> insertQ u w- new_st = st { inProgress = Map.insert u e p- , waitToStart = new_w }- case Map.lookup u p of- Just (f', fs', c') -> do- let new_c = minCachable c c'- when (c /= c') $ let new_p = Map.insert u (f', fs', new_c) p- in do modify (\s -> s { inProgress = new_p })- dbg $ "Changing "++u++" request cachability from "++show c++" to "++show new_c- when (u `elemQ` w && priority r == High) $ do- modify (\s -> s { waitToStart = pushQ u (deleteQ u w) })- dbg $ "Moving "++u++" to head of download queue."- if f `notElem` (f':fs')- then let new_p = Map.insert u (f', f:fs', new_c) p- in do modify (\s -> s { inProgress = new_p })- dbg "Adding new file to existing UrlRequest."- else dbg "Ignoring UrlRequest of file that's already queued."- _ -> put new_st----- | Internal to urlThread-alreadyDownloaded :: String -> IO Bool-alreadyDownloaded u = do- n <- withMVar urlNotifications (return . (Map.lookup u))- case n of- Just v -> not `fmap` isEmptyMVar v- Nothing -> return True---- ------------------------------------------------------------------------checkWaitToStart :: StateT UrlState IO ()-checkWaitToStart = do- st <- get- let l = pipeLength st- mpl <- liftIO maxPipelineLength- when (l < mpl) $ do- let w = waitToStart st- case readQ w of- Just (u,rest) -> do- case Map.lookup u (inProgress st) of- Just (f, _, c) -> do- dbg ("URL.requestUrl ("++u++"\n"++- " -> "++f++")")- let f_new = f++"-new_"++randomJunk st- err <- liftIO $ requestUrl u f_new c- if null err- then do liftIO $ atexit (removeFileMayNotExist f_new)- put $ st { waitToStart = rest- , pipeLength = l + 1 }- else do dbg $ "Failed to start download URL "++u++": "++err- liftIO $ do removeFileMayNotExist f_new- downloadComplete u err- put $ st { waitToStart = rest }- _ -> bug $ "Possible bug in URL.checkWaitToStart "++u- checkWaitToStart- _ -> return ()--copyUrlFirst :: String -> FilePath -> Cachable -> IO ()-copyUrlFirst = copyUrlWithPriority High--copyUrl :: String -> FilePath -> Cachable -> IO ()-copyUrl = copyUrlWithPriority Low--copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO ()-copyUrlWithPriority p u f c = do- debugMessage ("URL.copyUrlWithPriority ("++u++"\n"++- " -> "++f++")")- v <- newEmptyMVar- old_mv <- modifyMVar urlNotifications (return . (\(a, b) -> (b, a)) . Map.insertLookupWithKey (\_k _n old -> old) u v)- case old_mv of- Nothing -> writeChan urlChan $ UrlRequest u f c p -- ok, new URL- Just _ -> debugMessage $ "URL.copyUrlWithPriority already in progress, skip (" ++ u ++ "\n" ++ "-> " ++ f ++ ")"--waitNextUrl :: StateT UrlState IO ()-waitNextUrl = do- st <- get- let l = pipeLength st- when (l > 0) $ do- dbg "URL.waitNextUrl start"- (u, e, ce) <- liftIO $ waitNextUrl'- let p = inProgress st- new_st = st { inProgress = Map.delete u p- , pipeLength = l - 1 }- liftIO $ if null e- then case Map.lookup u p of- Just (f, fs, _) -> do- renameFile (f++"-new_"++randomJunk st) f- mapM_ (safeCopyFile st f) fs- downloadComplete u e- debugMessage $ "URL.waitNextUrl succeeded: "++u++" "++f- Nothing -> bug $ "Possible bug in URL.waitNextUrl: "++u- else case Map.lookup u p of- Just (f, _, _) -> do- removeFileMayNotExist (f++"-new_"++randomJunk st)- case ce of- Just httpError -> downloadComplete u (show httpError)- Nothing -> downloadComplete u e- debugMessage $ "URL.waitNextUrl failed: "++- u++" "++f++" "++e- Nothing -> bug $ "Another possible bug in URL.waitNextUrl: "++u++" "++e- unless (null u) $ put new_st- where safeCopyFile st f t = let new_t = t++"-new_"++randomJunk st- in do copyFile f new_t- renameFile new_t t--downloadComplete :: String -> String -> IO ()-downloadComplete u e = do- r <- withMVar urlNotifications (return . (Map.lookup u))- case r of- Just notifyVar -> putMVar notifyVar e- Nothing -> debugMessage $ "downloadComplete URL '"++u++"' downloaded several times"--waitUrl :: String -> IO ()-waitUrl u = do debugMessage $ "URL.waitUrl "++u- r <- withMVar urlNotifications (return . (Map.lookup u))- case r of- Just var -> do- e <- readMVar var- modifyMVar_ urlNotifications (return . (Map.delete u))- unless (null e) $ do- debugMessage $ "Failed to download URL "++u++": "++e- fail e- Nothing -> return () -- file was already downloaded--dbg :: String -> StateT a IO ()-dbg = liftIO . debugMessage--minCachable :: Cachable -> Cachable -> Cachable-minCachable Uncachable _ = Uncachable-minCachable _ Uncachable = Uncachable-minCachable (MaxAge a) (MaxAge b) = MaxAge $ min a b-minCachable (MaxAge a) _ = MaxAge a-minCachable _ (MaxAge b) = MaxAge b-minCachable _ _ = Cachable--disableHTTPPipelining :: IO ()-disableHTTPPipelining = writeIORef maxPipelineLengthRef 1--setDebugHTTP :: IO ()-requestUrl :: String -> FilePath -> Cachable -> IO String-waitNextUrl' :: IO (String, String, Maybe ConnectionError)-pipeliningEnabled :: IO Bool--#ifdef HAVE_CURL--setDebugHTTP = Curl.setDebugHTTP-requestUrl = Curl.requestUrl-waitNextUrl' = Curl.waitNextUrl-pipeliningEnabled = Curl.pipeliningEnabled--#elif defined(HAVE_HTTP)--setDebugHTTP = return ()-requestUrl = HTTP.requestUrl-waitNextUrl' = HTTP.waitNextUrl-pipeliningEnabled = return False--#else--setDebugHTTP = debugMessage "URL.setDebugHttp works only with libcurl"-requestUrl _ _ _ = debugFail "URL.requestUrl: there is no libcurl!"-waitNextUrl' = debugFail "URL.waitNextUrl': there is no libcurl!"-pipeliningEnabled = return False--#endif---- Usage of these environment variables happens in C code, so the--- closest to "literate" user documentation is here, where the--- offending function 'curl_request_url' is imported.-environmentHelpProxy :: ([String], [String])-environmentHelpProxy = (["HTTP_PROXY", "HTTPS_PROXY", "FTP_PROXY",- "ALL_PROXY", "NO_PROXY"], [- "If Darcs was built with libcurl, the environment variables HTTP_PROXY,",- "HTTPS_PROXY and FTP_PROXY can be set to the URL of a proxy in the form",- "",- " [protocol://]<host>[:port]",- "",- "In which case libcurl will use the proxy for the associated protocol",- "(HTTP, HTTPS and FTP). The environment variable ALL_PROXY can be used",- "to set a single proxy for all libcurl requests.",- "",- "If the environment variable NO_PROXY is a comma-separated list of host",- "names, access to those hosts will bypass proxies defined by the above",- "variables. For example, it is quite common to avoid proxying requests",- "to machines on the local network with",- "",- " NO_PROXY=localhost,*.localdomain",- "",- "For compatibility with lynx et al, lowercase equivalents of these",- "environment variables (e.g. $http_proxy) are also understood and are",- "used in preference to the uppercase versions.",- "",- "If Darcs was not built with libcurl, all these environment variables",- "are silently ignored, and there is no way to use a web proxy."])--environmentHelpProxyPassword :: ([String], [String])-environmentHelpProxyPassword = (["DARCS_PROXYUSERPWD"], [- "If Darcs was built with libcurl, and you are using a web proxy that",- "requires authentication, you can set the $DARCS_PROXYUSERPWD",- "environment variable to the username and password expected by the",- "proxy, separated by a colon. This environment variable is silently",- "ignored if Darcs was not built with libcurl."])
− src/URL/Curl.hs
@@ -1,80 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--module URL.Curl where--#ifdef HAVE_CURL--import Control.Exception.Extensible ( bracket )-import Control.Monad ( when )-import Foreign.C.Types ( CLong(..), CInt(..) )--import Progress ( debugMessage )--import URL.Request--import Foreign.C.String ( withCString, peekCString, CString )-import Foreign.Ptr-import Foreign.Marshal.Alloc-import Foreign.Storable--setDebugHTTP :: IO ()-setDebugHTTP = curl_enable_debug--requestUrl :: String -> FilePath -> Cachable -> IO String-requestUrl u f cache =- withCString u $ \ustr ->- withCString f $ \fstr -> do- err <- curl_request_url ustr fstr (cachableToInt cache) >>= peekCString- return err--waitNextUrl :: IO (String, String, Maybe ConnectionError)-waitNextUrl =- bracket malloc free $ \ errorPointer ->- bracket malloc free $ \ httpErrorPointer -> do- e <- curl_wait_next_url errorPointer httpErrorPointer >>= peekCString- ce <- do- errorNum <- peek errorPointer- if not (null e)- then return $- case errorNum of- 6 -> Just CouldNotResolveHost- 7 -> Just CouldNotConnectToServer- 28 -> Just OperationTimeout- _ -> Nothing- else do- when (errorNum == 90 ) $ debugMessage "The environment variable DARCS_CONNECTION_TIMEOUT is not a number"- return Nothing- u <- curl_last_url >>= peekCString- httpErrorCode <- peek httpErrorPointer- let detailedErrorMessage = if httpErrorCode > 0- then e ++ " " ++ show httpErrorCode- else e- return (u, detailedErrorMessage, ce)--pipeliningEnabled :: IO Bool-pipeliningEnabled = do- r <- curl_pipelining_enabled- return $ r /= 0--cachableToInt :: Cachable -> CInt-cachableToInt Cachable = -1-cachableToInt Uncachable = 0-cachableToInt (MaxAge n) = n--foreign import ccall "hscurl.h curl_request_url"- curl_request_url :: CString -> CString -> CInt -> IO CString--foreign import ccall "hscurl.h curl_wait_next_url"- curl_wait_next_url :: Ptr CInt -> Ptr CLong-> IO CString--foreign import ccall "hscurl.h curl_last_url"- curl_last_url :: IO CString--foreign import ccall "hscurl.h curl_enable_debug"- curl_enable_debug :: IO ()--foreign import ccall "hscurl.h curl_pipelining_enabled"- curl_pipelining_enabled :: IO CInt--#endif
− src/URL/HTTP.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE CPP #-}--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 )-import Network.URI-import System.IO.Error ( ioeGetErrorString )-import System.IO.Unsafe ( unsafePerformIO )-import Darcs.Global ( debugMessage )-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-#endif--fetchUrl :: String -> IO String-postUrl- :: String -- ^ url- -> String -- ^ body- -> String -- ^ mime type- -> IO () -- ^ result--requestUrl :: String -> FilePath -> a -> IO String-waitNextUrl :: IO (String, String, Maybe ConnectionError)--#ifdef HAVE_HTTP--headers :: [Header]-headers = [Header HdrUserAgent $ "darcs-HTTP/" ++ version]--fetchUrl url = case parseURI url of- Nothing -> fail $ "Invalid URI: " ++ url- Just uri -> do debugMessage $ "Fetching over HTTP: "++url- resp <- catch (browse $ do- setCheckForProxy True- setOutHandler debugMessage- setErrHandler debugMessage- request Request { rqURI = uri,- rqMethod = GET,- rqHeaders = headers,- rqBody = "" })- (\(err :: IOException) -> debugFail $ show err)- case resp of- (_, res@Response { rspCode = (2,0,0) }) -> return (rspBody res)- (_, Response { rspCode = (x,y,z) }) ->- debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error getting " ++ show uri--postUrl url body mime = case parseURI url of- Nothing -> fail $ "Invalid URI: " ++ url- Just uri -> do debugMessage $ "Posting to HTTP: "++url- resp <- catch (browse $ do- setCheckForProxy True- setOutHandler debugMessage- setErrHandler debugMessage- request Request { rqURI = uri,- rqMethod = POST,- rqHeaders = headers ++ [Header HdrContentType mime,- Header HdrAccept "text/plain",- Header HdrContentLength- (show $ length body) ],- rqBody = body })- (\(err :: IOException) -> debugFail $ show err)- case resp of- (_, res@Response { rspCode = (2,y,z) }) -> do- putStrLn $ "Success 2" ++ show y ++ show z- putStrLn (rspBody res)- return ()- (_, res@Response { rspCode = (x,y,z) }) -> do- putStrLn $ rspBody res- debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error posting to " ++ show uri--requestedUrl :: IORef (String, FilePath)-requestedUrl = unsafePerformIO $ newIORef ("", "")--requestUrl u f _ = do- (u', _) <- readIORef requestedUrl- if null u'- then do writeIORef requestedUrl (u, f)- return ""- else return "URL already requested"--waitNextUrl = do- (u, f) <- readIORef requestedUrl- if null u- then return ("", "No URL requested", Nothing)- else do writeIORef requestedUrl ("", "")- e <- (fetchUrl u >>= \s -> B.writeFile f (BC.pack s) >> return "") `catch` h- let ce = case e of- "timeout" -> Just OperationTimeout- _ -> Nothing- return (u, e, ce)- where h = return . ioeGetErrorString--#else--fetchUrl _ = debugFail "Network.HTTP does not exist"-postUrl _ _ _ = debugFail "Cannot use http POST because darcs was not compiled with Network.HTTP."--requestUrl _ _ _ = debugFail "Network.HTTP does not exist"-waitNextUrl = debugFail "Network.HTTP does not exist"--#endif
− src/URL/Request.hs
@@ -1,59 +0,0 @@-module URL.Request where--import Data.Map ( Map )-import Data.List ( delete )-import Foreign.C.Types ( CInt )--data UrlRequest = UrlRequest { url :: String- , file :: FilePath- , cachable :: Cachable- , priority :: Priority }--data Cachable = Cachable | Uncachable | MaxAge !CInt- deriving (Show, Eq)--data UrlState = UrlState { inProgress :: Map String ( FilePath- , [FilePath]- , Cachable )- , waitToStart :: Q String- , pipeLength :: Int- , randomJunk :: String }--data Q a = Q [a] [a]--readQ :: Q a -> Maybe (a, Q a)-readQ (Q (x:xs) ys) = Just (x, Q xs ys)-readQ (Q [] ys) = do x:xs <- Just $ reverse ys- Just (x, Q xs [])--insertQ :: a -> Q a -> Q a-insertQ y (Q xs ys) = Q xs (y:ys)--pushQ :: a -> Q a -> Q a-pushQ x (Q xs ys) = Q (x:xs) ys--deleteQ :: Eq a => a -> Q a -> Q a-deleteQ x (Q xs ys) = Q (delete x xs) (delete x ys)--elemQ :: Eq a => a -> Q a -> Bool-elemQ x (Q xs ys) = x `elem` xs || x `elem` ys--emptyQ :: Q a-emptyQ = Q [] []--nullQ :: Q a -> Bool-nullQ (Q [] []) = True-nullQ _ = False--data Priority = High | Low deriving Eq---- | Data type to represent a connection error.--- The following are the codes from libcurl--- which map to each of the constructors:--- * 6 -> CouldNotResolveHost : The remote host was not resolved.--- * 7 -> CouldNotConnectToServer : Failed to connect() to host or proxy.--- * 28 -> OperationTimeout: the specified time-out period was reached.-data ConnectionError = CouldNotResolveHost |- CouldNotConnectToServer |- OperationTimeout- deriving (Eq, Read, Show)
− src/Workaround.hs
@@ -1,148 +0,0 @@-{-# LANGUAGE CPP #-}---- |--- Module : Workaround--- Copyright : 2008 David Roundy <droundy@darcs.net>--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module Workaround- (- renameFile- , setExecutable- , getCurrentDirectory- , installHandler- , raiseSignal- , Handler(..)- , Signal- , sigINT- , sigHUP- , sigABRT- , sigALRM- , sigTERM- , sigPIPE- ) where--import Prelude hiding ( catch )--#ifdef WIN32--import qualified System.Directory ( renameFile, getCurrentDirectory, removeFile )-import Control.Exception ( catch, IOException )-import qualified Control.Exception ( mask )-import qualified System.IO.Error ( isDoesNotExistError, ioError )--#else--import System.Posix.Signals(installHandler, raiseSignal, Handler(..), Signal,- sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE)-import System.Directory ( renameFile, getCurrentDirectory )-import System.Posix.Files (fileMode,getFileStatus, setFileMode,- setFileCreationMask,- ownerReadMode, ownerWriteMode, ownerExecuteMode,- groupReadMode, groupWriteMode, groupExecuteMode,- otherReadMode, otherWriteMode, otherExecuteMode)-import Data.Bits ( (.&.), (.|.), complement )--#endif--#ifdef WIN32--- Dummy implementation of POSIX signals-data Handler = Default- | Ignore- | Catch (IO ())--type Signal = Int--installHandler :: Signal- -> Handler- -> Maybe ()- -> IO ()-installHandler _ _ _ = return ()---raiseSignal :: Signal -> IO ()-raiseSignal _ = return ()---sigINT :: Signal-sigINT = 0---- not used: sigKILL = 0--sigHUP :: Signal-sigHUP = 0---- not used: sigQUIT = 0--sigABRT :: Signal-sigABRT = 0--sigTERM :: Signal-sigTERM = 0--sigPIPE :: Signal-sigPIPE = 0--sigALRM :: Signal-sigALRM = 0----- | System.Directory.renameFile incorrectly fails when the new file already--- exists. This code works around that bug at the cost of losing atomic--- writes.-renameFile :: FilePath- -> FilePath- -> IO ()-renameFile old new = Control.Exception.mask $ \_ ->- System.Directory.renameFile old new- `catch` \(_ :: IOException) ->- do System.Directory.removeFile new- `catch`- (\e -> if System.IO.Error.isDoesNotExistError e- then return ()- else System.IO.Error.ioError e)- System.Directory.renameFile old new---setExecutable :: FilePath- -> Bool- -> IO ()-setExecutable _ _ = return ()----- | System.Directory.getCurrentDirectory returns a path with backslashes in it--- under windows, and some of the code gets confused by that, so we override--- getCurrentDirectory and translates '\\' to '/'-getCurrentDirectory :: IO FilePath-getCurrentDirectory = do- d <- System.Directory.getCurrentDirectory- return $ map rb d- where- rb '\\' = '/'- rb c = c--#else---setExecutable :: FilePath- -> Bool- -> IO ()-setExecutable f ex = do- st <- getFileStatus f- umask <- setFileCreationMask 0--- Warning: A do-notation statement discarded a result of type System.Posix.Types.FileMode.- _ <- setFileCreationMask umask- let rw = fileMode st .&.- (ownerReadMode .|. ownerWriteMode .|.- groupReadMode .|. groupWriteMode .|.- otherReadMode .|. otherWriteMode)- total = if ex then rw .|.- ((ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode)- .&. complement umask)- else rw- setFileMode f total--#endif
src/atomic_create.c view
@@ -125,11 +125,12 @@ rc = link(filename, p); if(rc >= 0) goto success;- else if(errno == EPERM || errno == EOPNOTSUPP) {+ else if(errno == EPERM || errno == EOPNOTSUPP || errno == ENOSYS) { /* Linux returns EPERM when making hard links on filesystems that don't support them. */ /* It seems that MacOS returns EOPNOTSUPP on filesystems that don't support hard links. */+ /* Linux using SSHFS returns ENOSYS for link(). */ unlink(filename); free(filename); return sloppy_atomic_create(p);
− src/darcs.hs
@@ -1,88 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING. If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}---- |--- Module : Main--- Copyright : 2002-2003 David Roundy--- License : GPL--- Maintainer : darcs-devel@darcs.net--- Stability : experimental--- Portability : portable--module Main ( main ) where--import Control.Exception.Extensible ( AssertionFailed(..), handle )-import Control.Monad ( forM_ )-import System.IO ( stdin, stdout, stderr, hSetBinaryMode )-import System.Exit ( exitWith, ExitCode(..) )-import System.Environment ( getArgs )--import Darcs.Commands.Help ( helpCmd, listAvailableCommands, printVersion,- commandControlList )-import Darcs.Flags ( DarcsFlag(Verbose) )-import Darcs.Global ( withAtexit, atexit )-import Darcs.Repository( reportBadSources )-import Darcs.RunCommand ( runTheCommand )-import Darcs.SignalHandler ( withSignalsHandled )--import Darcs.Utils ( setDarcsEncodings )-import Exec ( ExecException(..) )-import Preproc( preprocMain )-import Version ( version, context, builddeps )--#include "impossible.h"--execExceptionHandler :: ExecException -> IO a-execExceptionHandler (ExecException cmd args redirects reason) = do- putStrLn . unlines $- [ "Failed to execute external command: " ++ unwords (cmd:args)- , "Lowlevel error: " ++ reason- , "Redirects: " ++ show redirects- ]- exitWith $ ExitFailure 3--main :: IO ()-main = withAtexit . withSignalsHandled . handleExecFail . handleAssertFail $ do- atexit reportBadSources- setDarcsEncodings- argv <- getArgs- -- Explicitly handle no-args and special "help" arguments.- case argv of- [] -> printVersion >> runHelpCmd- ["-h"] -> runHelpCmd- ["--help"] -> runHelpCmd- ["--overview"] -> helpCmd [Verbose] []- ["--commands"] -> listAvailableCommands- ["-v"] -> putStrLn version- ["--version"] -> putStrLn version- ["--exact-version"] -> printExactVersion- ("--preprocess-manual" : rest) -> preprocMain rest- _ -> do- forM_ [stdout, stdin, stderr] $ \h -> hSetBinaryMode h True- runTheCommand commandControlList (head argv) (tail argv)- where- handleExecFail = handle execExceptionHandler- handleAssertFail = handle $ \(AssertionFailed e) -> bug e- runHelpCmd = helpCmd [] []- printExactVersion = do- putStrLn $ "darcs compiled on " ++ __DATE__ ++ ", at " ++ __TIME__- putStrLn context- putStrLn "Compiled with:\n"- putStr builddeps-
− src/gadts.h
@@ -1,15 +0,0 @@-#ifdef GADT_WITNESSES--#define C(contexts) contexts-#define FORALL(types) forall types.-#define PATCHKIND (* -> * -> *)-#define SEALEDPATCHKIND (* -> *)--#else--#define C(contexts)-#define FORALL(types)-#define PATCHKIND *-#define SEALEDPATCHKIND *--#endif
src/hscurl.c view
@@ -120,9 +120,11 @@ const char *curl_request_url(const char *url, const char *filename,- int cache_time)+ int cache_time,+ int* errorCode) { int error;+ *errorCode = -1; if (init_done == 0) {@@ -172,6 +174,12 @@ return error_strings[RESULT_FILE_OPEN_FAIL]; } + error = set_time_out(easy, errorCode);+ if (error != CURLE_OK ){+ *errorCode = error;+ return curl_easy_strerror(error);+ }+ error = curl_easy_setopt(easy, CURLOPT_PRIVATE, url_data); if (error != CURLE_OK) return curl_easy_strerror(error);@@ -349,7 +357,7 @@ *errorCode = 90 ; } - error = curl_easy_setopt(handle, CURLOPT_TIMEOUT, time_out);+ error = curl_easy_setopt(handle, CURLOPT_CONNECTTIMEOUT, time_out); return error; }
src/hscurl.h view
@@ -2,7 +2,8 @@ const char *curl_request_url(const char *url, const char *filename,- int cache_time);+ int cache_time,+ int *errorCode); const char *curl_wait_next_url(int *errorCode, long* httpErrorCode);
src/impossible.h view
@@ -1,4 +1,4 @@-import qualified Darcs.Bug as Bug_+import qualified Darcs.Util.Bug as Bug_ #define darcsBug (\imp_funny_name -> imp_funny_name (__FILE__,__LINE__,__TIME__,__DATE__))
− src/test.hs
@@ -1,206 +0,0 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, DeriveDataTypeable #-}-module Main ( main ) where--import qualified Darcs.Test.Misc-import qualified Darcs.Test.Patch-import qualified Darcs.Test.Email--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-import Test.Framework-import Shellish hiding ( liftIO, run )-import qualified Shellish--doUnit :: IO [Test]-doUnit = return unitTests---- | This is the big list of tests that will be run using testrunner.-unitTests :: [Test]-unitTests =- [ Darcs.Test.Email.testSuite- , Darcs.Test.Misc.testSuite- ] ++ Darcs.Test.Patch.testSuite---- ------------------------------------------------------------------------- shell tests--- ------------------------------------------------------------------------data Format = Hashed | Darcs2 deriving Show-data Running = Running deriving Show-data Result = Success | Skipped | Failed String--instance Show Result where- show Success = "Success"- show Skipped = "Skipped"- show (Failed f) = unlines (map ("| " ++) $ lines f)--instance TestResultlike Running Result where- testSucceeded Success = True- testSucceeded Skipped = True- testSucceeded _ = False--data ShellTest = ShellTest { format :: Format- , testfile :: FilePath- , 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 =- do wd <- pwd- setenv "HOME" wd- setenv "TESTDATA" (srcdir </> "tests" </> "data")- setenv "TESTBIN" (srcdir </> "tests" </> "bin")- setenv "DARCS_TESTING_PREFS_DIR" $ wd </> ".darcs"- setenv "EMAIL" "tester"- setenv "DARCS_DONT_COLOR" "1"- setenv "DARCS_DONT_ESCAPE_ANYTHING" "1"- getenv "PATH" >>= setenv "PATH" . ((takeDirectory dp ++ pathVarSeparator) ++)- setenv "DARCS" dp- mkdir ".darcs"- writefile ".darcs/defaults" defaults--- Warning: A do-notation statement discarded a result of type String.- _ <- Shellish.run "bash" [ "test" ]- return Success- `catch_sh` \e -> case e of- RunFailed _ 200 _ -> return Skipped- RunFailed _ _ _ -> Failed <$> B.unpack <$> lastOutput- where defaults = unlines ["ALL " ++ fmtstr, "send no-edit-description", "ALL ignore-times"]- fmtstr = case fmt of- Darcs2 -> "darcs-2"- Hashed -> "hashed"-#ifdef WIN32- pathVarSeparator = ";"-#else- pathVarSeparator = ":"-#endif--runtest :: ShellTest -> ShIO Result-runtest t =- withTmp $ \dir -> do- cp "tests/lib" dir- cp ("tests" </> testfile t) (dir </> "test")- srcdir <- pwd- silently $ sub $ cd dir >> runtest' t srcdir- where- withTmp =- case testdir t of- Just dir -> \job -> do- let d = (dir </> show (format t) </> takeBaseName (testfile t))- mkdir_p d- job d- Nothing -> withTmpDir--instance Testlike Running Result ShellTest where- testTypeName _ = "Shell"- runTest _ test = runImprovingIO $ do yieldImprovement Running- liftIO (shellish $ runtest test)--shellTest :: FilePath -> Format -> Maybe FilePath -> String -> Test-shellTest dp fmt tdir file = Test (file ++ " (" ++ show fmt ++ ")") $ ShellTest fmt file tdir dp--findShell :: FilePath -> Maybe FilePath -> Bool -> ShIO [Test]-findShell dp tdir isFailing =- do files <- sort <$> grep relevant <$> grep (".sh" `isSuffixOf`) <$> ls "tests"- return [ shellTest dp fmt tdir file- | fmt <- [ Darcs2, Hashed ]- , file <- files ]- where relevant = (if isFailing then id else not) . ("failing-" `isPrefixOf`)--findNetwork :: FilePath -> Maybe FilePath -> ShIO [Test]-findNetwork dp tdir =- do files <- sort <$> grep (".sh" `isSuffixOf`) <$> ls "tests/network"- return [ shellTest dp Darcs2 tdir ("network" </> file) | file <- files ]---- ------------------------------------------------------------------------- harness--- ------------------------------------------------------------------------data Config = Config { failing :: Bool- , shell :: Bool- , network :: Bool- , unit :: Bool- , darcs :: String- , tests :: [String]- , testDir :: Maybe FilePath- , plain :: Bool- , hideSuccesses :: Bool- , threads :: Int }- deriving (Data, Typeable, Eq)--instance Attributes Config where- attributes _ = group "Options"- [ failing %> Help "Run the failing (shell) tests."- , shell %> Help "Run the passing, non-network shell tests." %+ Default True- , network %> Help "Run the network shell tests."- , unit %> Help "Run the unit tests." %+ Default True- , tests %> Help "Pattern to limit the tests to run." %+ short 't'- , testDir %> Help "Directory to run tests in" %+ Default (Nothing :: Maybe FilePath)- , plain %> Help "Use plain-text output."- , hideSuccesses %> Help "Hide successes."- , threads %> Default (1 :: Int) %+ short 'j' ]--data DarcsTest = DarcsTest deriving Typeable-instance Command DarcsTest (Record Config) where- run _ conf _ = do- let args = [ "-j", show $ threads conf ] - ++ concat [ ["-t", x ] | x <- tests conf ]- ++ [ "--plain" | True <- [plain conf] ]- ++ [ "--hide-successes" | True <- [hideSuccesses conf] ]- ++ [ "--maximum-unsuitable-generated-tests", "700" ]- case testDir conf of- 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 (not (isAbsolute $ darcsBin)) $- fail ("Argument to --darcs should be an absolute path")- 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 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- where- exeSuffix :: String-#ifdef WIN32- exeSuffix = ".exe"-#else- exeSuffix = ""-#endif--main :: IO ()-main = do hSetBinaryMode stdout True- hSetBuffering stdout NoBuffering- hSetBinaryMode stderr True- hSetBinaryMode stdin True- getArgs >>= execute DarcsTest
− src/win32/CtrlC.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--module CtrlC (withCtrlCHandler) where--import Data.Word ( Word32 )-import Foreign.Ptr ( FunPtr )-import Control.Exception ( bracket )--type Handler = Word32 -> IO Int--foreign import ccall "wrapper" wrap :: Handler -> IO (FunPtr Handler)-foreign import stdcall "SetConsoleCtrlHandler" setConsoleCtrlHandler :: FunPtr Handler -> Int -> IO ()---withCtrlCHandler :: IO () -> IO a -> IO a-withCtrlCHandler handler m = do- fp <- wrap (\_ctrlType -> handler >> return 1)- bracket (setConsoleCtrlHandler fp 1) (const $ setConsoleCtrlHandler fp 0) (const m)---
+ src/win32/Darcs/Util/CtrlC.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module Darcs.Util.CtrlC ( withCtrlCHandler ) where++import Data.Word ( Word32 )+import Foreign.Ptr ( FunPtr )+import Control.Exception ( bracket_ )++type Handler = Word32 -> IO Int++foreign import ccall "wrapper" wrap :: Handler -> IO (FunPtr Handler)+foreign import stdcall "SetConsoleCtrlHandler" setConsoleCtrlHandler :: FunPtr Handler -> Int -> IO ()+++withCtrlCHandler :: IO () -> IO a -> IO a+withCtrlCHandler handler m = do+ fp <- wrap (\_ctrlType -> handler >> return 1)+ bracket_ (setConsoleCtrlHandler fp 1) (setConsoleCtrlHandler fp 0) m+++
src/win32/System/Posix/IO.hsc view
@@ -39,7 +39,7 @@ openFd :: FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd openFd name how maybe_mode off = do-#if mingw32_HOST_OS && __GLASGOW_HASKELL__ >= 612+#if mingw32_HOST_OS withCWString name $ \s -> do #else withCString name $ \s -> do
src/win32/send_email.c view
@@ -130,7 +130,7 @@ else if(send_res== MAPI_E_TEXT_TOO_LARGE) fprintf(stderr, "MAPI error: Text too large.\n"); else if(send_res== MAPI_E_INVALID_SESSION) fprintf(stderr, "MAPI error: Invalid session.\n"); else if(send_res== MAPI_E_TYPE_NOT_SUPPORTED) fprintf(stderr, "MAPI error: Type not supported.\n");- else if(send_res== MAPI_E_AMBIGUOUS_RECIP) fprintf(stderr, "MAPI error: Ambigious recipient.\n");+ else if(send_res== MAPI_E_AMBIGUOUS_RECIPIENT) fprintf(stderr, "MAPI error: Ambigious recipient.\n"); else if(send_res== MAPI_E_MESSAGE_IN_USE) fprintf(stderr, "MAPI error: Messag in use.\n"); else if(send_res== MAPI_E_NETWORK_FAILURE) fprintf(stderr, "MAPI error: Network failure.\n"); else if(send_res== MAPI_E_INVALID_EDITFIELDS) fprintf(stderr, "MAPI error: Invalid editfields\n");
tests/README.test_maintainers.txt view
@@ -1,112 +1,1 @@--The following is provided as a reference for those interested in understanding-how the test suite works, and how to add and maintain tests.--Overview of types of tests-==========================--Darcs has tests in two formats. Unit tests that directly test Haskell-functions are written in Haskell and live in modules under src/Darcs/Test.-Functional tests that test the darcs binary are written in Shell and live in-tests/.--Haskell tests-----------------------------These are QuickCheck and HUnit tests primarily testing the Darcs core. The-Haskell modules containing these tests are under Darcs.Test in the module-hierarchy. They are called from src/unit.lhs using the test-framework package-from Hackage.--More about the Haskell tests can be found on http://wiki.darcs.net/Development/UnitTests.--Shell tests------------------------------Shell tests are useful because they are easy to create from a copy/paste-of actual shell commands executed. They are considered successful if no-bad exit codes are returned from the commands in the script. If the name of the-script file starts with 'failing-' however, the script is expected to return-a bad exit code. If such a script returns a bad exit code, this will not be-treated as a test suite failure. This is useful to document bugs and to-do-items.--How to run tests-=============================--To build the unit tests, pass the "-ftest" flag to "cabal configure" and then-do "cabal build". To run them, do "dist/build/unit/unit". They take a while.-Output like "[OK]" and "[OK, passed 100 tests]" is good. Output like-"Arguments exhausted after 33 tests" is a shortage of QuickCheck test-cases, not a test failure.--"runghc Setup.lhs test" causes all the functional tests in "tests/" to be run-against repositories in the old, hashed, and darcs2 formats.--Because "runghc Setup.lhs test" can take a long time to run, it's useful to run-fewer tests at once. To help with that, 'runghc Setup.lhs test' accepts-arguments to run only a specific group of test scripts, or only named test-scripts:-- runghc Setup.lhs test tests # all tests, excluding bugs or network tests- runghc Setup.lhs test bugs # all bugs (the 'failing-' scripts)- runghc Setup.lhs test network # the network tests-- # and this one runs tests/issue279_get_extra.sh and tests/repair_corrupt.sh- runghc Setup.lhs test issue279_get_extra repair-corrupt--Tips for writing (and reading) tests-====================================--- Avoid including a repo format type to "darcs init"- This insures that all three repo formats will be tested.- However, if you know that the test only passes under some- repo formats, *do* explicitly include a format option to "darcs init".---Tips for writing tests-------------------------- Copy EXAMPLE.sh as a template to start from (don't forget to customise- the headers!).--- Simply call darcs using "darcs" as you would in the shell. It is the- responsibility of the test harness to ensure that the darcs we are- testing is first in the path.--- Always use Bash explicitly - this improves the portability of our tests.--- Always add this near the top of the script:-- set -ev-- The "v" causes the contents of the script to be printed as part of the run,- which is helpful for debugging. The "e" causes the script to exit as soon as- there is an error.--- Try to avoid defining functions where possible. This makes them- harder to run and generally harder to use. There are certainly cases- where it is appropriate to define a function, but please do not do- this just to avoid a little duplication.--- Also try to be careful using certain utilities; 'yes' is prohibited since- it can cause infinite loops on Mac OS X; 'find' can be very useful, but- options and behavior can differ from GNU find to the BSD finds to Solaris's- find and so on. In general, stick to POSIX flags and functionality.--- There is a utility script intended for factoring out common calls and- functions, called 'lib'. It can be invoked by adding a line like '. lib' to- your shell script. lib provides 'set -ev', a common definition of 'not', and- 'abort_windows' for use in scripts which shouldn't run under Windows.- You don't have to use lib if you don't want to, or if it causes problems.--- If you need to skip a test for any reason, the darcs-specific- convention is to "exit 200". This alerts the shell harness that the- test was explicitly skipped and not passed.--- You can use the trap feature from bash to make ensure that darcs executes- some command even if the test fails. Trapping ERR lets you have your- last word just before a test fails. Trapping EXIT lets you do the- same before any sort of explicit exit (such as the explicit 'exit 1'- in the 'not' helper function). For more details, see the bash man- page or just grep trap in the test suite.+Please consult <http://darcs.net/Development/RegressionTests>.
tests/add-formerly-pl.sh view
@@ -16,20 +16,20 @@ mkdir oof.d darcs add foo.d darcs add oof.d-not darcs add foo.d 2>&1 | grep -i directory+not darcs add -v foo.d 2>&1 | grep -i directory # Try adding the same directory when it's already in the repo-not darcs add foo.d oof.d 2>&1 | grep -i directories+not darcs add -v foo.d oof.d 2>&1 | grep -i directories # Make sure that messages about files call them files touch bar touch baz darcs add bar darcs add baz-not darcs add bar 2>&1 | grep -i "following file is"-not darcs add bar baz 2>&1 | grep -i "following files are"+not darcs add -v bar 2>&1 | grep -i "following file is"+not darcs add -v bar baz 2>&1 | grep -i "following files are" # Make sure that messages about both files and directories say so-not darcs add bar foo.d 2>&1 | grep -i 'files and directories'+not darcs add -v bar foo.d 2>&1 | grep -i 'files and directories' # Make sure that parent directories are added for files@@ -37,13 +37,13 @@ mkdir -p b.d/bb.d touch a.d/aa.d/aaa.d/baz touch a.d/aa.d/aaa.d/bar-darcs add a.d/aa.d/aaa.d/bar a.d/aa.d/aaa.d/baz b.d/bb.d 2> log+darcs add -v a.d/aa.d/aaa.d/bar a.d/aa.d/aaa.d/baz b.d/bb.d 2> log test ! -s log # no output # Make sure that darcs doesn\'t complains about duplicate adds when adding parent dirs. mkdir c.d touch c.d/baz-darcs add c.d/baz c.d 2> log+darcs add -v c.d/baz c.d 2> log test ! -s log # no output # Make sure that add output looks good when adding files in subdir@@ -52,7 +52,7 @@ darcs add -rv d.d | grep 'd.d/foo' # 'adding a non-existent dir and file gives the expected message-not darcs add notadir/notafile 2>&1 | grep -i 'does not exist'+not darcs add -v notadir/notafile 2>&1 | grep -i 'does not exist' cd .. rm -rf temp1
tests/add.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/addexitval.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -rf tmp mkdir tmp@@ -17,7 +17,7 @@ >foo darcs add foo >stdout 2>stderr-$empty stdout+$nonempty stdout # print confirmation message of added file $empty stderr darcs add foo >stdout 2>stderr && exit 1 || true
tests/addmv.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1 temp2
tests/addrace.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1 temp2
tests/addrm.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1 temp2
tests/amend-cancelling.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # This checks for a possible bug in patch selection where the no available # patches case is hit.@@ -13,7 +13,7 @@ darcs record -am A echo 'l1' >> A darcs record -am l1-darcs amend-record -a --patch 'A'+darcs amend -a --patch 'A' cd .. rm -rf temp1
tests/amend-record-back-up.sh view
@@ -34,6 +34,6 @@ darcs record -lam 'file2' echo 'file2:amended' > file2-echo 'nkya' | darcs amend-record+echo 'nkya' | darcs amend darcs changes -p 'file2' -v | grep amended
− tests/amend-record.sh
@@ -1,78 +0,0 @@-#!/usr/bin/env bash--# Testing amend-record.--. lib--rm -rf temp1-# set up the repository-mkdir temp1-cd temp1-darcs init-cd ..--# do some work here-cd temp1-# Plain amend-record-touch foo-darcs add foo-darcs record -a -m add_foo-echo 'another line' > foo-echo y | darcs amend -a foo | grep -i 'amending changes'-darcs changes -v | grep 'another line'-# amend-record of removed file-touch bar1-touch bar2-cat > bar1 << FOO-a line-b line-FOO-darcs add bar1 bar2-darcs record -a -m add_bars-rm -f bar2-echo y | darcs amend -a | grep -i 'finished amending'-# Special case: patch is empty after amend-cp foo foo.old-echo 'another line' >> foo-darcs record -a -m add_line foo | grep -i 'finished recording'-mv foo.old foo-echo y | darcs amend -a foo | grep -i 'amending changes'-# Amend --author, -m, etc-echo "another line" >> foo-echo y | darcs amend -a -m new_name foo | grep -i 'amending changes'-darcs changes --last=1 | grep new_name-echo "another line" >> foo-echo y | darcs amend -a -m new_name -A new_author foo | grep -i 'amending changes'-darcs changes --last=1 | grep new_author--# check that normally the date changes when we amend-echo "another line" >> foo-darcs changes --last=1 | head -n 1 > old_date-sleep 1-echo y | darcs amend -a foo -A new_author | grep -i 'amending changes'-darcs changes --last=1 | head -n 1 > new_date-not cmp old_date new_date--# check that --keep-date works-echo "another line" >> foo-darcs changes --last=1 | head -n 1 > old_date-sleep 1-echo y | darcs amend -a foo -A new_author --keep-date | grep -i 'amending changes'-darcs changes --last=1 | head -n 1 > new_date-cmp old_date new_date--cd ..--# check that the identity changes with --keep-date-darcs get temp1 temp2-cd temp2--echo "another line" >> foo-darcs changes --last=1 | head -n 1 > old_date-echo y | darcs amend -a foo -A new_author --keep-date | grep -i 'amending changes'-darcs pull ../temp1 -a --skip-conflicts | grep -i "Skipping some"--cd ..---rm -rf temp1 temp2
tests/amend-unrecord.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-## Test for amend-record --unrecord+## Test for amend --unrecord ## ## Copyright (C) 2012 Ganesh Sittampalam ##@@ -35,11 +35,11 @@ (echo 1 ; echo x ; echo y ; echo 2) > foo darcs rec -am "insert 1 and 2" -(echo yyn) | darcs amend-record --unrecord+(echo yyny) | darcs amend --unrecord (echo x ; echo y ; echo 2) > foo.expected darcs show contents foo | diff -q foo.expected - -(echo yeny) | DARCS_EDITOR="sed -i -e s/2/2j/" darcs amend-record --unrecord+(echo yenyy) | DARCS_EDITOR="sed -i -e s/2/2j/" darcs amend --unrecord (echo x ; echo y ; echo 2j) > foo.expected darcs show contents foo | diff -q foo.expected - @@ -50,8 +50,8 @@ echo y | darcs amend -a darcs show contents bar | diff -q bar - -# test that amend-unrecord alias exists, and --all and specifying files works-echo y | darcs amend-unrecord -a foo+# test that amend --unrecord --all and specifying files works+echo y | darcs amend --unrecord -a foo (echo x ; echo y) > foo.expected darcs show contents foo | diff -q foo.expected - darcs show contents bar | diff -q bar -
+ tests/amend.sh view
@@ -0,0 +1,78 @@+#!/usr/bin/env bash++# Testing amend++. lib++rm -rf temp1+# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++# do some work here+cd temp1+# Plain amend+touch foo+darcs add foo+darcs record -a -m add_foo+echo 'another line' > foo+echo y | darcs amend -a foo | grep -i 'amending changes'+darcs changes -v | grep 'another line'+# amend of removed file+touch bar1+touch bar2+cat > bar1 << FOO+a line+b line+FOO+darcs add bar1 bar2+darcs record -a -m add_bars+rm -f bar2+echo y | darcs amend -a | grep -i 'finished amending'+# Special case: patch is empty after amend+cp foo foo.old+echo 'another line' >> foo+darcs record -a -m add_line foo | grep -i 'finished recording'+mv foo.old foo+echo y | darcs amend -a foo | grep -i 'amending changes'+# Amend --author, -m, etc+echo "another line" >> foo+echo y | darcs amend -a -m new_name foo | grep -i 'amending changes'+darcs changes --last=1 | grep new_name+echo "another line" >> foo+echo y | darcs amend -a -m new_name -A new_author foo | grep -i 'amending changes'+darcs changes --last=1 | grep new_author++# check that normally the date changes when we amend+echo "another line" >> foo+darcs changes --last=1 | head -n 1 > old_date+sleep 1+echo y | darcs amend -a foo -A new_author | grep -i 'amending changes'+darcs changes --last=1 | head -n 1 > new_date+not cmp old_date new_date++# check that --keep-date works+echo "another line" >> foo+darcs changes --last=1 | head -n 3 | grep Date > old_date+sleep 1+echo y | darcs amend -a foo -A new_author --keep-date | grep -i 'amending changes'+darcs changes --last=1 | head -n 3 | grep Date > new_date+cmp old_date new_date++cd ..++# check that the identity changes with --keep-date+darcs get temp1 temp2+cd temp2++echo "another line" >> foo+darcs changes --last=1 | head -n 1 > old_date+echo y | darcs amend -a foo -A new_author --keep-date | grep -i 'amending changes'+darcs pull ../temp1 -a --skip-conflicts | grep -i "Skipping some"++cd ..+++rm -rf temp1 temp2
tests/apply-hunks.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp0 temp1 temp2
+ tests/apply-reorder.sh view
@@ -0,0 +1,67 @@+#!/usr/bin/env bash++## Test that apply --reorder moves to the top the uncommon set of patches between+## the current repository and the set of patches we are applying.++. lib # Load some portability helpers.++check_patches_order () {+ darcs changes | tr -d "\n" | grep $1.*$2.*$3+}++test_init () {+ rm -rf R1 R2+ + darcs init "R1"+ cd R1++ touch "r1_0"+ darcs add "r1_0"+ darcs record -a --author=me -m "Adding r1_0" "r1_0"++ cd ..++ darcs clone "R1" "R2"++ cd R2++ touch "r2_0"+ darcs add "r2_0"+ darcs record -a --author=me -m "Adding r2_0" "r2_0"+ darcs send --no-minimize --author=me -a --no-edit-description -o ../R1/P ++ cd ..++ cd R1++ touch "r1_1"+ darcs add "r1_1"+ darcs record -a --author=me -m "Adding r1_1" "r1_1"+ + cd ..+}+++test_init++cd R1++darcs apply P+# Without reorder the expected order is r2_0, r1_1, r1_0 .+check_patches_order r2_0 r1_1 r1_0++# Test that apply --reorder reorders even if there is nothing to apply.+darcs apply --reorder P+check_patches_order r1_1 r2_0 r1_0++cd ..++test_init++cd R1++darcs apply --reorder P+# With reorder the expected order is r1_1, r2_0, r1_0 .+check_patches_order r1_1 r2_0 r1_0++cd ..
tests/ask_deps.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp mkdir temp@@ -35,19 +35,19 @@ touch b darcs add b # test 0-echo n/n/n/q | tr / \\012 | darcs rec -am b0+echo nnnY | tr '[A-Z]' '[a-z]' | darcs rec -am b0 darcs ann -p b0 # test 1 echo 1 > b-echo n/n/y/q | tr / \\012 | darcs rec -am b1+echo nnyY | tr '[A-Z]' '[a-z]' | darcs rec -am b1 darcs ann -p b1 | grep '^\[a0' # test 2 echo 2 > b-echo n/y/q | tr / \\012 | darcs rec -am b2+echo nyY | tr '[A-Z]' '[a-z]' | darcs rec -am b2 darcs ann -p b2 | grep '^\[a1' # test 3 echo 3 > b-echo y/q | tr / \\012 | darcs rec -am b3+echo yY | tr '[A-Z]' '[a-z]' | darcs rec -am b3 darcs ann -p b3 | grep '^\[a2' cd ..
− tests/bad-match-pattern.sh
@@ -1,38 +0,0 @@-#!/usr/bin/env bash--# This is a test for issue761, which pointed out that we didn't check the-# syntax of --match patterns until after having spent considerable time-# doing considerable work. So here we construct a very invalid repository,-# and check that darcs fails *before* it notices that it's pulling from a-# bad repository. Thus we verify that we aren't doing any work prior to-# checking the flags.--set -ev--rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-touch foo bar-darcs add foo bar-darcs record -a -m 'add two files'-darcs tag -m tag-rm foo bar-darcs record -a -m 'rm two files'-darcs tag -m tag2--rm -rf _darcs/inventories/*-rm -rf _darcs/patches/*--cd ..--mkdir temp2-cd temp2-darcs init-! darcs pull --match 'foobar' ../temp1 2> error-cat error--grep foobar error--rm -rf temp1 temp2-
tests/bad_pending_after_pull.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -fr temp1 temp2 @@ -23,7 +23,7 @@ cd temp2 darcs init darcs pull --all ../temp1-darcs whatsnew | grep 'No changes'+not darcs whatsnew cd .. rm -fr temp1 temp2@@ -45,7 +45,7 @@ cd temp2 darcs init darcs pull --all ../temp1-darcs whatsnew | grep 'No changes'+not darcs whatsnew cd .. rm -fr temp1 temp2
tests/bin/trackdown-bisect-helper.hs view
@@ -1,7 +1,7 @@ {- -Tool for construction of testing repository for trackdown testing-with bisect option. Written by Matthias Fischmann.+Tool for construction of testing repository for test --bisect.+Written by Matthias Fischmann. Usage:
tests/binary.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ve+. ./lib binary=example_binary.png function checkbinary(){ cmp $binary ../temp1/$binary
+ tests/changes-duplicate.sh view
@@ -0,0 +1,49 @@+#!/usr/bin/env bash+## Test for patch index automation - <SYNOPSIS: Patch index should+## always be in sync with repo after execution of any command.>+##+## Copyright (C) 2012 BSRK Aditya+##+## 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.++#pragma repo-format darcs-2++. lib+grep darcs-2 $HOME/.darcs/defaults || exit 200++rm -rf R S+darcs init --repo R+darcs init --repo S++cd R+touch f+darcs record -lam 'p1'++cd ../S+touch f+darcs record -lam 'p2'+darcs send -ao p2.dpatch ../R++cd ../R+darcs apply -a ../S/p2.dpatch +darcs changes --verbose+darcs changes --verbose | grep -q 'duplicate'+darcs changes f --verbose | not grep -q 'duplicate'
tests/changes.sh view
@@ -1,7 +1,7 @@ #!/usr/bin/env bash-set -ev+. ./lib -# Some tests for 'darcs changes'+# Some tests for 'darcs changes -a' rm -rf temp1 mkdir temp1
tests/changes_send_context.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # RT#544 using context created with 8-bit chars; rm -rf temp1
− tests/check.sh
@@ -1,42 +0,0 @@-#!/usr/bin/env bash-## Ensure that "darcs check --test" succeeds when run in a complete-## repository with a dummy test that always succeeds.-##-## Copyright (C) 2008 David Roundy-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib # Load some portability helpers.-rm -rf R # Another script may have left a mess.-darcs init --repo R-darcs setpref --repo R test 'grep hello f'-not darcs record --repo R -am 'true test' --test-darcs record --repo R -am 'true test' --no-test--touch R/f-darcs record --repo R -lam 'added foo' --no-test-darcs tag --repo R -m 'got f?'--echo hello > R/f-darcs record --repo R -lam 'hellofoo' --test-darcs chec --repo R --test--rm -rf R # Clean up after ourselves.
tests/conflict-doppleganger.sh view
@@ -1,5 +1,7 @@ #!/usr/bin/env bash +#pragma repo-format darcs-1,darcs-2+ . lib # Tests for the doppleganger conflict bug.
tests/conflict-fight-failure.sh view
@@ -9,7 +9,7 @@ # Author: Pekka Pessi # -set -ev+. ./lib record="record --ignore-time --all --author X"
tests/conflict-fight.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -rf temp0 temp1 temp2
tests/convert.sh view
@@ -1,5 +1,7 @@ #!/usr/bin/env bash +#pragma repo-format darcs-1+ ## Tests for convert command based on previously checked results ## to generate new test material for this test, ## see bin/convert-writer.sh@@ -28,7 +30,7 @@ . lib -grep old-fashioned $HOME/.darcs/defaults || grep hashed $HOME/.darcs/defaults || exit 200+grep darcs-1 $HOME/.darcs/defaults || exit 200 runtest() { rm -rf temp@@ -37,16 +39,16 @@ mkdir repo cd repo- darcs init+ darcs init --darcs-1 darcs apply --allow-conflicts $TESTDATA/convert/darcs1/$1.dpatch cd ..- echo 'I understand the consequences of my action' | darcs convert repo repo2+ echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 mkdir empty-darcs2 cd empty-darcs2 darcs init --darcs-2 cd .. cd repo2- darcs send -a -o ../$1-darcs2.dpatch ../empty-darcs2+ darcs send --no-minimize -a -o ../$1-darcs2.dpatch ../empty-darcs2 cd .. diff -I'1 patch for repository ' -I'patches for repository ' -I'Oct 1' -u $TESTDATA/convert/darcs2/$1.dpatch $1-darcs2.dpatch }
+ tests/convert_export.sh view
@@ -0,0 +1,51 @@+#!/usr/bin/env bash+## test incremental fast-export to git+##+## Copyright (C) 2014 Guillaume Hoffmann+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++# only run if git present+git --version | grep -i "git version" || exit 200++darcs init --repo R # Create our test repos.+cd R+mkdir d e # Change the working tree.+echo 'Example content.' > d/f+darcs record -lam 'Add d/f and e.'++git init gitmirror++darcs convert export --write-marks darcs-to-git.marks > fex+(cd gitmirror && git fast-import --export-marks=git.marks < ../fex)++darcs mv d/f e/+darcs record -am 'Move d/f to e/f.'++darcs convert export --read-marks darcs-to-git.marks --write-marks darcs-to-git.marks > fex2+(cd gitmirror && git fast-import --import-marks=git.marks --export-marks=git.marks < ../fex2)++# restore the git working tree by making a clone+git clone gitmirror gitmirror-clone++diff e/f gitmirror-clone/e/f
tests/data/context-v1.dpatch view
@@ -1,9 +1,13 @@ 2 patches for repository /home/ganesh/darcs-comp/temp/empty: -Thu Oct 21 18:28:18 BST 2010 Ganesh Sittampalam <ganesh@earth.li>+patch 573defe88544e8f75a18e530e3aeaf6608951aa1+Author: Ganesh Sittampalam <ganesh@earth.li>+Date: Thu Oct 21 18:28:18 BST 2010 * init -Thu Oct 21 18:28:31 BST 2010 Ganesh Sittampalam <ganesh@earth.li>+patch c8ec7c8b2df55720ba2c3a21adb80790363f421e+Author: Ganesh Sittampalam <ganesh@earth.li>+Date: Thu Oct 21 18:28:31 BST 2010 * ABC New patches:
tests/data/context-v2.dpatch view
@@ -1,9 +1,13 @@ 2 patches for repository /home/ganesh/darcs-comp/temp/empty: -Thu Oct 21 18:28:18 BST 2010 Ganesh Sittampalam <ganesh@earth.li>+patch 573defe88544e8f75a18e530e3aeaf6608951aa1+Author: Ganesh Sittampalam <ganesh@earth.li>+Date: Thu Oct 21 18:28:18 BST 2010 * init -Thu Oct 21 18:28:31 BST 2010 Ganesh Sittampalam <ganesh@earth.li>+patch c8ec7c8b2df55720ba2c3a21adb80790363f421e+Author: Ganesh Sittampalam <ganesh@earth.li>+Date: Thu Oct 21 18:28:31 BST 2010 * ABC New patches:
tests/data/convert/darcs2/resolution.dpatch view
@@ -1,18 +1,28 @@ 5 patches for repository /tmp/tmp6648/temp/empty-darcs2: -Sat Oct 16 23:32:07 BST 2010 tester+patch c88a093ab344f21fc3af74eee6741db45df22498+Author: tester+Date: Sat Oct 16 23:32:07 BST 2010 * wibble -Sat Oct 16 23:32:07 BST 2010 tester+patch 9d61f1de5ae27b8f1678735b4741abe4a869d899+Author: tester+Date: Sat Oct 16 23:32:07 BST 2010 * A -Sat Oct 16 23:32:07 BST 2010 tester+patch 3b3282935c87c2aede246a42f5c0a926fae2be35+Author: tester+Date: Sat Oct 16 23:32:07 BST 2010 * B -Sat Oct 16 23:32:07 BST 2010 tester+patch bc42df597aa06b720f03367499e3dffe36baa9a4+Author: tester+Date: Sat Oct 16 23:32:07 BST 2010 * AB -Sat Oct 16 23:32:07 BST 2010 tester+patch 8efe5b608a6236bd136ead946ef26369207ca5ac+Author: tester+Date: Sat Oct 16 23:32:07 BST 2010 * C New patches:
tests/data/convert/darcs2/simple.dpatch view
@@ -1,6 +1,8 @@ 1 patch for repository /tmp/tmp5746/temp/empty-darcs2: -Sat Oct 16 23:28:30 BST 2010 tester+patch 62068c47f23550e3a32aaf652d1e14e53598ba98+Author: tester+Date: Sat Oct 16 23:28:30 BST 2010 * wibble New patches:
tests/data/convert/darcs2/threewayanddep.dpatch view
@@ -1,18 +1,28 @@ 5 patches for repository /tmp/tmp5530/temp/empty-darcs2: -Sat Oct 16 23:27:54 BST 2010 tester+patch 349a0bab437265867f9af955d72127bac4cea1a6+Author: tester+Date: Sat Oct 16 23:27:54 BST 2010 * wibble -Sat Oct 16 23:27:54 BST 2010 tester+patch 650955997f5fac7fa2e14127a25ea5ac70f4dab0+Author: tester+Date: Sat Oct 16 23:27:54 BST 2010 * A1 -Sat Oct 16 23:27:54 BST 2010 tester+patch 476d8520cfc9be9b44299e6f4753de6adca83bcf+Author: tester+Date: Sat Oct 16 23:27:54 BST 2010 * A2 -Sat Oct 16 23:27:54 BST 2010 tester+patch 4d2a18f739f8f4c384b5653a5ad03d5e77724efe+Author: tester+Date: Sat Oct 16 23:27:54 BST 2010 * B -Sat Oct 16 23:27:54 BST 2010 tester+patch 81ba98134cf0d725e827318ca2753be4148568b7+Author: tester+Date: Sat Oct 16 23:27:54 BST 2010 * C New patches:
tests/data/convert/darcs2/threewayandmultideps.dpatch view
@@ -1,24 +1,38 @@ 7 patches for repository /tmp/tmp5411/temp/empty-darcs2: -Sat Oct 16 23:27:21 BST 2010 tester+patch fd370912c8a92d249e00e7c91856ed9530d6c914+Author: tester+Date: Sat Oct 16 23:27:21 BST 2010 * wibble -Sat Oct 16 23:27:21 BST 2010 tester+patch ac7df6a4761de10b4c440a9adb39c4f0236cb519+Author: tester+Date: Sat Oct 16 23:27:21 BST 2010 * A1 -Sat Oct 16 23:27:21 BST 2010 tester+patch 121d6130551316a64fa7a061cfc44f5946213f85+Author: tester+Date: Sat Oct 16 23:27:21 BST 2010 * A2 -Sat Oct 16 23:27:21 BST 2010 tester+patch 513848985dfc5b5ea1533d56b597daa7317f35bc+Author: tester+Date: Sat Oct 16 23:27:21 BST 2010 * B1 -Sat Oct 16 23:27:21 BST 2010 tester+patch 84edd5450901a4d31f1b49a9a6da4563a6ed73fe+Author: tester+Date: Sat Oct 16 23:27:21 BST 2010 * B2 -Sat Oct 16 23:27:21 BST 2010 tester+patch bec254c63929d83d13929eec63f2e5e5a8aabbb4+Author: tester+Date: Sat Oct 16 23:27:21 BST 2010 * C1 -Sat Oct 16 23:27:21 BST 2010 tester+patch 0e08cbe9489dfc7f21e9528b4c6a7d06f4fec25a+Author: tester+Date: Sat Oct 16 23:27:21 BST 2010 * C2 New patches:
tests/data/convert/darcs2/threewayconflict.dpatch view
@@ -1,15 +1,23 @@ 4 patches for repository /tmp/tmp5605/temp/empty-darcs2: -Sat Oct 16 23:28:14 BST 2010 tester+patch 8d6bfafe7ac2a628340563d92917da9639a8d509+Author: tester+Date: Sat Oct 16 23:28:14 BST 2010 * wibble -Sat Oct 16 23:28:14 BST 2010 tester+patch c0a55ca9dedb993d05d2779ca4f72984e87083cd+Author: tester+Date: Sat Oct 16 23:28:14 BST 2010 * A -Sat Oct 16 23:28:14 BST 2010 tester+patch fb027d809948379ca6357d654a6ce8cf45235dfa+Author: tester+Date: Sat Oct 16 23:28:14 BST 2010 * B -Sat Oct 16 23:28:14 BST 2010 tester+patch 7eeb8289feadd843a19485f493235566a2c48bea+Author: tester+Date: Sat Oct 16 23:28:14 BST 2010 * C New patches:
tests/data/convert/darcs2/tworesolutions.dpatch view
@@ -1,24 +1,38 @@ 7 patches for repository /tmp/tmp6805/temp/empty-darcs2: -Sat Oct 16 23:34:33 BST 2010 tester+patch d1638af339ea13cf23df131015309be1915ae247+Author: tester+Date: Sat Oct 16 23:34:33 BST 2010 * wibble -Sat Oct 16 23:34:33 BST 2010 tester+patch 687f568b2fa78eea4431b49c76524fd75cce06bf+Author: tester+Date: Sat Oct 16 23:34:33 BST 2010 * A -Sat Oct 16 23:34:33 BST 2010 tester+patch f1859e4ecd30f209ad08440964b3fa7b7bb8318d+Author: tester+Date: Sat Oct 16 23:34:33 BST 2010 * B -Sat Oct 16 23:34:33 BST 2010 tester+patch bb4b77fc72cf19af130db16c173f73341d847271+Author: tester+Date: Sat Oct 16 23:34:33 BST 2010 * AB -Sat Oct 16 23:34:33 BST 2010 tester+patch fe0a5a17610dbffc90b421d3b40a9ee30ff7e484+Author: tester+Date: Sat Oct 16 23:34:33 BST 2010 * C -Sat Oct 16 23:34:33 BST 2010 tester+patch 4ecd0a21ee5b7150e567a83c150810656ad76006+Author: tester+Date: Sat Oct 16 23:34:33 BST 2010 * ABC -Sat Oct 16 23:34:33 BST 2010 tester+patch 756f4b3ac209102b5804ad71e54852b74a7281c1+Author: tester+Date: Sat Oct 16 23:34:33 BST 2010 * D New patches:
tests/data/convert/darcs2/twowayconflict.dpatch view
@@ -1,12 +1,18 @@ 3 patches for repository /tmp/tmp5677/temp/empty-darcs2: -Sat Oct 16 23:28:22 BST 2010 tester+patch 8b8ee8c8e9bae5fe01abfd8c991071091241aa1f+Date: Sat Oct 16 23:28:22 BST 2010+Author: tester * wibble -Sat Oct 16 23:28:22 BST 2010 tester+patch 23373e39b77dbce4de67f7631221f2d873ae21df+Author: tester+Date: Sat Oct 16 23:28:22 BST 2010 * A -Sat Oct 16 23:28:22 BST 2010 tester+patch 0058ef88cdd3606a9fbcfa00fb8b7d494db77481+Author: tester+Date: Sat Oct 16 23:28:22 BST 2010 * B New patches:
+ tests/data/laziness-complete.tgz view
binary file changed (absent → 5338 bytes)
+ tests/data/laziness-cut.tgz view
binary file changed (absent → 4352 bytes)
− tests/data/old-with-checkpoint.tgz
binary file changed (3053 → absent bytes)
tests/data/simple-v1.dpatch view
@@ -1,6 +1,8 @@ 1 patch for repository /home/ganesh/darcs-comp/temp/empty: -Wed Oct 20 07:12:31 BST 2010 Ganesh Sittampalam <ganesh@earth.li>+patch 060052b3182f512c548d15dc6789228178cd9a4e+Author: Ganesh Sittampalam <ganesh@earth.li>+Date: Wed Oct 20 07:12:31 BST 2010 * wibble New patches:
tests/data/simple-v2.dpatch view
@@ -1,6 +1,8 @@ 1 patch for repository /home/ganesh/darcs-comp/temp/empty: -Wed Oct 20 07:12:31 BST 2010 Ganesh Sittampalam <ganesh@earth.li>+patch 060052b3182f512c548d15dc6789228178cd9a4e+Author: Ganesh Sittampalam <ganesh@earth.li>+Date: Wed Oct 20 07:12:31 BST 2010 * wibble New patches:
− tests/data/split--old-fashioned-inventory.tgz
binary file changed (2827 → absent bytes)
tests/diff.sh view
@@ -1,10 +1,10 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp-$$ mkdir temp-$$ cd temp-$$-set -e+ darcs initialize echo text > afile.txt darcs add afile.txt@@ -13,6 +13,11 @@ darcs diff --no-unified -p . --store-in-mem > diffinmem darcs diff --no-unified -p . --no-store-in-mem > diffondisk diff diffinmem diffondisk-cd .. +echo text >> afile.txt+darcs diff | sed 's/afile\.txt.*//'> diffnoarg+darcs diff . | sed 's/afile\.txt.*//' > diffdot+diff diffnoarg diffdot++cd .. rm -rf temp-$$
tests/directory_confusion.sh view
@@ -1,12 +1,12 @@ #!/usr/bin/env bash-set -ev+. ./lib T=temp rm -rf "$T" mkdir "$T" echo "$T" cd "$T"-set -e+ darcs initialize echo text > afile.txt darcs add afile.txt
tests/disable.sh view
@@ -1,20 +1,37 @@ #!/usr/bin/env bash . lib -# Some tests for 'darcs whatsnew '- rm -rf temp1 mkdir temp1 cd temp1 darcs init-touch look_summary.txt-# --disable works on command line-not darcs whatsnew -sl --disable 2> log-grep -i disable log-# --disable works from defaults-echo 'whatsnew --disable' > _darcs/prefs/defaults-not darcs whatsnew -sl 2> log-grep -i disable log-cd ..+all_commands=$(darcs --commands | grep -v -- --) +for cmd in $all_commands; do+ # --disable works on command line+ not darcs $cmd --disable 2> log+ grep disable log+ rm log+ # --disable works from defaults+ sub_commands=$(darcs $cmd --list-options | grep -v -- --)+ # disabling super commands in the defaults file is broken+ if test -z "$sub_commands"; then+ echo "$cmd --disable" > _darcs/prefs/defaults+ not darcs $cmd 2> log+ rm _darcs/prefs/defaults+ grep disable log+ rm log+ elif $cmd != setpref; then+ # setpref is not a proper super command+ for scmd in $sub_commands; do+ echo "$cmd $scmd --disable" > _darcs/prefs/defaults+ not darcs $cmd 2> log+ rm _darcs/prefs/defaults+ grep disable log+ rm log+ done+ fi+done++cd .. rm -rf temp1
tests/dist-v.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # tests for "darcs dist"
tests/dist.sh view
@@ -20,8 +20,10 @@ darcs record -a -m add_foo | grep -i "finished recording" darcs dist+darcs dist --zip mv temp1.tar.gz ..+mv temp1.zip .. cd .. @@ -32,4 +34,14 @@ diff -r temp_orig temp1 -rm -rf temp_orig temp1+rm -rf temp1++# Only do following if unzip is present+unzip >& /dev/null &&+(+unzip temp1.zip+diff -r temp_orig temp1+rm -rf temp1+)++rm -rf temp_orig
tests/double-unrevert.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # This demonstrates a bug that happens if you revert followed by # a partial unrevert and a full unrevert. It requires that@@ -22,7 +22,7 @@ sed '4d' A > A1; rm A; mv A1 A sed 's/line6/Line6/' A > A1; rm A; mv A1 A darcs revert -a-echo nyn | darcs unrev+echo nyny | darcs unrev darcs unrev -a cd ..
tests/emailformat.sh view
@@ -1,8 +1,7 @@ #!/usr/bin/env bash -. lib+. ./lib -set -ev switch_to_latin9_locale rm -rf temp1 rm -rf temp2@@ -25,7 +24,8 @@ cd ../temp1 # long email adress: check that email adresses of <= 77 chars don't get split up-darcs send --from="Kjålt Überström $seventysevenaddy" \+darcs send --mail\+ --from="Kjålt Überström $seventysevenaddy" \ --subject "Un patch pour le répositoire" \ --to="Un garçon français <garcon@francais.fr>" \ --sendmail-command='tee mail_as_file %<' \
tests/failed-amend-should-not-break-repo.sh view
@@ -25,8 +25,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -. lib-set -ev+. ./lib rm -rf R mkdir R cd R
tests/failing-issue1013_either_dependency.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib export DARCS_EMAIL=test rm -rf tmp_d1 tmp_d2 tmp_d # Preparations:
tests/failing-issue1014_identical_patches.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # Set up a base repo. Our experiment will start from this point mkdir base
tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib not () { "$@" && exit 1 || :; }
− tests/failing-issue1266_init_inside_a_repo.sh
@@ -1,33 +0,0 @@-#!/usr/bin/env bash-## Test for issue1266 - attempting to initialize a repository inside-## another repository should cause a warning, because while perfectly-## legitimate, it is likely to be accidental.-##-## Copyright (C) 2009 Trent W. Buck-##-## 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--rm -rf temp1 out # Another script may have left a mess.-darcs init --repodir temp1-darcs init --repodir temp1/temp2 2>&1 | tee out-grep -i WARNING out # A warning should be printed.
+ tests/failing-issue1316-2.sh view
@@ -0,0 +1,49 @@+#!/usr/bin/env bash+## Test for issue1316 - junk left in pending+##+## Copyright (C) 2011 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.++# this test is a slightly more complicated variant on failing-issue1316+# it also uses darcs commands to test rather than grepping pending.++. lib # Load some portability helpers.+darcs init --repo R # Create our test repos.++cd R++touch X+darcs rec -lam 'X'++darcs mv X Y+darcs rec -am 'Y'++rm Y+echo 'y' | darcs amend-rec -a++# the bug is that addfile Y shows up in pending+# if pending is empty as it should be, then since+# whatsnew doesn't have -l, it shouldn't report anything+# even after we touch Y.+touch Y+not darcs whatsnew+
+ tests/failing-issue1316.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash+## Test for issue1316 - Removing a directory+##+## Copyright (C) 2009 Nathan Gray, Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++mkdir R+darcs init --repo R # Create our test repos.++cd R+mkdir d # Change the working tree.+darcs record -lam 'Add a directory'+rm -rf d+echo y | darcs amend-record -m 'initial' --all+not grep adddir _darcs/patches/pending
tests/failing-issue1327.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # See issue1327. # results in the error:@@ -24,4 +24,4 @@ darcs record --author foo@bar --ignore-times --all fileA -m "Add just fileA" cd ../temp1 darcs pull --all ../temp2-echo y | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB"+echo yy | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB"
+ tests/failing-issue1332_add_r_boring.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash+## Test for issue1332 - add -r ignores --boring+##+## Copyright (C) 2009 Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.+rm -rf R # Another script may have left a mess.+darcs init --repo R # Create our test repos.++cd R+mkdir d+touch core f+# this is already known to work+darcs add --boring core f+darcs whatsnew > log+grep 'addfile ./f' log+grep 'addfile ./core' log+rm _darcs/patches/pending+touch _darcs/index_invalid++# this fails for issue1332+darcs add -r --boring .+darcs whatsnew > log+grep 'addfile ./f' log+grep 'addfile ./core' log
tests/failing-issue1396_changepref-conflict.sh view
@@ -1,7 +1,5 @@ #!/usr/bin/env bash-set -ev--. lib+. ./lib rm -rf temp1 temp1a temp1b
tests/failing-issue1401_bug_in_get_extra.sh view
@@ -25,6 +25,8 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. +#pragma repo-format darcs-2+ . lib ## This bug only affects darcs-2 repositories.
tests/failing-issue1406.sh view
@@ -37,9 +37,7 @@ darcs push --repo S R rm -rf R/ S/ # Clean up after ourselves. #!/bin/sh-set -ev--. lib+. ./lib rm -rf temp1 darcs init --repodir temp1@@ -53,7 +51,7 @@ echo "y" | not darcs amend-record --all --patch=p1 # There should be one patch in the repo-test 1 -eq `darcs changes --count` || exit 1+test 1 -eq `darcs changes -a --count` || exit 1 # Another check: there should be nothing new after a is restored echo "a" > a@@ -62,24 +60,3 @@ cd .. rm -rf test1 -# the following section of the test does not create a new repo,-# it oprates on an existing old-fashioned repo; no need to run it 3 times-if grep 'old-fashioned' .darcs/defaults; then-- # check that we do the operations on checkpoints tentatively- rm -rf old-with-checkpoint- gunzip -c $TESTDATA/old-with-checkpoint.tgz | tar xf --- echo "test exit 1" > old-with-checkpoint/_darcs/prefs/prefs-- # this amend will fail- echo 'y' | not darcs amend --repo old-with-checkpoint -m 'no longer a checkpoint :P' -p "checkpoint here"-- # check that the patch has not been removed from- # the checkpoints inventory- grep "checkpoint here" old-with-checkpoint/_darcs/checkpoints/inventory- #NOTE: checking the file is a rather white box way of testing it, but- # I could not think of any other way at the time, please improve-- rm -rf old-with-checkpint-fi
+ tests/failing-issue1577-revert-deletes-new-files.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash+## Test for issue1577 - revert deletes unadded files.+##+## Copyright (C) 2013 Owen Stephens+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.+rm -rf R+darcs init --repo R # Create our test repos.++cd R+echo 'Example content.' > f+darcs add f+darcs rev -a+[[ -e f ]]
+ tests/failing-issue1579_diff_opts.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash+## Test for issue1579 - the diff-opts parameter with multiple parameters +## separated by space are passed like an one parameter to diff.+##+## Copyright (C) 2013 dixiecko+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.+abort_windows # No diff command available++darcs init --repo R # Create our test repos.++cd R+echo 'Example content line 1.' > f+darcs record -lam 'Add f.'+echo 'Example content line 2.' >> f++# Darcs passes the parameters to diff like [ "-wpurNd -U 999" ]+# instead of [ "-wpurNd","-U","999" ]+darcs diff --diff-opts '-wpurNd -U 999' > result++# Darcs doesn't indicate the error in return error code,+# when diff command didn't work the result is empty.++if [ -z "$(cat result)" ]; then + exit 2+fi
tests/failing-issue1610_get_extra.sh view
@@ -25,6 +25,8 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. +#pragma repo-format darcs-1+ . lib # Load some portability helpers. # this test is not relevant for darcs 2 repositories
tests/failing-issue1702-optimize-relink-vs-cache.sh view
@@ -68,7 +68,7 @@ [[ ! R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false ## Optimize *should* hard-link all three together.-darcs optimize --relink --repodir R --sibling S+darcs optimize relink --repodir R --sibling S ## Confirm that all three are hard linked. ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging
− tests/failing-issue1845-paths-working-copy.sh
@@ -1,37 +0,0 @@-#!/usr/bin/env bash-## Test for issue1845 - darcs wants file paths from root of working copy-##-## Copyright (C) 2010 Guillaume Hoffmann-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib # Load some portability helpers.-rm -rf R S # Another script may have left a mess.-darcs init --repo R # Create our test repos.-cd R-mkdir subdir-touch subdir/subfile-darcs add subdir subdir/subfile-darcs record -am"add subdir and subfile"-cd subdir-rm subfile-darcs record subfile -am"delete file in subdirectory" # fails because darcs wants subdir/subfile -
tests/failing-issue1926_amend-record_ignores_--index.sh view
@@ -33,7 +33,7 @@ darcs record -lam 'Add file f' echo 'Example content 2.' > g darcs record -lam 'Add file g'-darcs put ../S # S as a copy of R+darcs get . ../S # S as a copy of R echo "y" | darcs amend-record --index=2 -m 'A new file f' # Since --index is ignored this command works in # interactive mode, and the amended patch is the one # with index 1.
− tests/failing-issue1932-colon-breaks-add.sh
@@ -1,77 +0,0 @@-#!/usr/bin/env bash-## Test for issue1932 - "darcs add -qr ." should not break on files with colons-##-## Copyright(C) 2010 Dmitry Astapov-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib # Load some portability helpers.-rm -rf R # Another script may have left a mess.-mkdir -p R # Create our test repo.--cd R-darcs init-darcs --version--# Colons could be in repo names and in file name.-# Colon in repo name is an indication of special case - remote repo.-# Colon in the file could be there under unix and requires no special treatment.--# Repo name with ':' is either scp repo or http repo.-# Let's check scp repo first.-( darcs get user@host:path || true ) > log 2>&1-[ -n "$(fgrep '(scp) failed to fetch' log)" ]--# HTTP repo-( darcs get http://www.bogus.domain.so.it.will.surely.fail.com || true ) > log 2>&1-[ -n "$(fgrep 'CouldNotResolveHost' log)" ]--# All following files should not be added unless "--reserved-ok" is specified,-# but should be added with "--reserved-ok" just fine-mkdir funny-touch funny/0401:19d2-touch funny/c:src-touch funny/c:\\src-touch funny/user@host:path -touch funny/droundy@host: -touch funny/host:path--# Try to add those files. None should be added, darcs should not fail-darcs add -qr funny-darcs wh -l > log 2>&1--# Check that darcs didn't drop dead as 2.4.4 does-[ -z "$(fgrep 'fromJust: Nothing' log)" ]--# Check that no funny files were added-[ -z "$(grep '^A \./funny/.' log)" ]--# Now let's allow colons and add those files-darcs add --reserved-ok -qr funny -darcs wh -l > log 2>&1--# This should add all those files-[ -n "$(grep '^A \./funny/0401:19d2' log)" ]-[ -n "$(grep '^A \./funny/c:src' log)" ]-[ -n "$(grep '^A \./funny/c:\\src' log)" ]-[ -n "$(grep '^A \./funny/user@host:path' log)" ]-[ -n "$(grep '^A \./funny/droundy@host:' log)" ]-[ -n "$(grep '^A \./funny/host:path' log)" ]
+ tests/failing-issue1959-unwritable-cache.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash+## Test for issue1959 - if the index becomes unwritable, darcs should not die.+##+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf R+darcs init --repo R++cd R++echo test > test+darcs rec -alm 'testing'++chmod a-w _darcs/index++darcs wh
+ tests/failing-issue2047_duplicate_conflictor_recommute_fail.sh view
@@ -0,0 +1,127 @@+#!/usr/bin/env bash+## Test that shows failing commute of conflictors/duplicates.+##+## Copyright (C) 2012 Owen Stephens+##+## 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.++# We want to create this situation:+#+# Context: [adddir "./dir1", addfile "./file1.txt"]+#+# (ParTree+# (ParTree (DP "./dir1" RmDir)+# (Move "./file1.txt" "./dir1/file3.txt")+# (SeqTree (DP "./dir1" RmDir) (Move "./file1.txt" "./file2.txt")))+#+# And then create the merged tree consisting of merging the second "branch" of+# a par tree into the first, depth-first.+#+# Finally, we show that commute is broken for certain combinations of+# conflictors/duplicates, since we can commute out one way, but not the+# other. We do so, by creating both orderings of the final two patches, and+# show that only in one case can we obliterate the penultimate patch alone (due+# to non-commutation).+#+# See issue2047 on the BTS for more information.++rm -rf R1* R2 R3*++darcs init --repo R1+cd R1++mkdir dir1+touch file1.txt++darcs rec -alm 'Init'++darcs get . ../R2+darcs get . ../R3++rmdir dir1+darcs rec -am 'Remove dir1'++cd ../R2+darcs mv file1.txt dir1/file3.txt+darcs rec -am 'Move 1 -> 3'++# Create the first merged ParTree.+cd ../R1+darcs pull -a ../R2++# Revert conflict-markup+darcs rev -a++# Create a copy of R1, so we can show the effect of commuting out the final two+# patches, when we create a different ordered R3...+darcs get . ../R1_OTHER++cd ../R3++# Copy R3, so we can create the other ordering for its patches.+darcs get . ../R3_OTHER++#### In R3 we do rmdir; move file+rmdir dir1+darcs rec -alm 'Rmdir'++cd ../R1+darcs pull -a ../R3+darcs rev -a++cd ../R3+darcs mv file1.txt file2.txt+darcs rec -alm 'Move 1 -> 2'++cd ../R1+darcs pull -a ../R3+darcs rev -a++#### In R3_OTHER we do move file; rmdir+cd ../R3_OTHER+darcs mv file1.txt file2.txt+darcs rec -alm 'Move 1 -> 2'++cd ../R1_OTHER+darcs pull -a ../R3_OTHER+darcs rev -a++cd ../R3_OTHER+rmdir dir1+darcs rec -alm 'Rmdir'++cd ../R1_OTHER+darcs pull -a ../R3_OTHER+darcs rev -a++# Now, to show the bug, we can ob the penultimate patch from R1, but not+# R1_OTHER+cd ../R1+darcs ob -p 'Rmdir' -a++[[ $(darcs changes --count) -eq 4 ]]++cd ../R1_OTHER+echo y | darcs ob -p 'Move 1 -> 2' -a++# There should be 4 changes remaining, but due to the failure to commute, we'll+# actually obliterate 2 patches, leaving 3.+[[ $(darcs changes --count) -eq 4 ]]
− tests/failing-issue2066_add_and_remove.sh
@@ -1,41 +0,0 @@-#!/usr/bin/env bash-## Test for issue2066 - darcs record fails when deleted file and added file are specified on the command line-##-## Copyright (C) 2011 David Caldwell <david@porkrind.org>-##-## 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-rm -rf R-mkdir R--cd R-darcs init-echo a > a-darcs add a-darcs record --all -m "a"-rm -f a-echo b > b-darcs add b-darcs record --all -m "-a+b" a b-darcs changes -v | grep 'rmfile ./a' # the remove doesn't get recorded even though we told it to.--cd ..
tests/failing-issue2100-add-failures.sh view
@@ -31,9 +31,9 @@ echo 'Example content.' > d/f not darcs add d/non-existent not darcs whatsnew-not darcs add d/non-existent d/f+not darcs add d/non-existent d/f > log1 2>&1 darcs whatsnew > log2 2>&1-grep "./d/non-existent does not exist" log2+grep "./d/non-existent does not exist" log1 not grep "addfile ./d/non-existent" log2 grep "adddir ./d" log2 grep "addfile ./d/f" log2
+ tests/failing-issue2138-whatsnew-s.sh view
@@ -0,0 +1,59 @@+#!/usr/bin/env bash+## Test for issue2138 - whatsnew --summary does not show conflicts+##+## Copyright (C) 2012 Lele Gaifax+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++rm -rf R S++darcs init --repo R++cd R+echo 'Example content.' > f+darcs record -lam 'Add f'+cd ..++darcs get R S++# Create a deliberate conflict+cd R+echo "Conflict on side R" >> f+darcs record -am 'CR'++cd ../S+echo "Conflict on side S" >> f+darcs record -am 'CS'++darcs pull -a ../R++darcs whatsnew > out+cat out+grep "side R" out | wc -l | grep 1+grep "side S" out | wc -l | grep 1++darcs whatsnew --summary > out+grep "^M!" out | wc -l | grep 1++cd ..+rm -rf R S
+ tests/failing-issue2186-apply--reply-conflict.sh view
@@ -0,0 +1,55 @@+#!/usr/bin/env bash+## Test for issue2186 - If a patch fails (e.g. because of a conflict), +## "apply --reply" does not email a status report.+##+## Copyright (C) 2012 Ilya Perminov+##+## 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++# Create a script that will be used instead of sendmail. It simply saves its +# input to file "message".+echo "#!/usr/bin/env bash" >dummy-sendmail+echo "cat >message" >>dummy-sendmail+chmod a+x dummy-sendmail++darcs init --repo R+darcs get R S++# Create an email message with a patch+cd R+echo 'Example content.' >file1+darcs add file1+darcs rec -a --name patch1+darcs send --dont-edit-description --to noreply@example.net --sendmail-command '../dummy-sendmail %<' -a ../S+mv message patch-set1++# Create the same file in the target repository to trigger a conflict.+cd ../S+echo 'Some text.' >file1+darcs add file1+darcs rec -a --name patch2++# Apply the patch set. darcs should email a report. If it does our dummy-sendmail script will +# create file "message".+darcs apply --reply noreply@example.net --sendmail-command '../dummy-sendmail %<' ../R/patch-set1 || :;+[ -f ./message ] || exit 1
+ tests/failing-issue2186-apply--reply-ok.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+## Test for issue2186 - If patchs are applied successfully, +## "apply --reply" does not email a status report.+##+## Copyright (C) 2012 Ilya Perminov+##+## 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++# Create a script that will be used instead of sendmail. It simply saves its +# input to file "message".+echo "#!/usr/bin/env bash" >dummy-sendmail+echo "cat >message" >>dummy-sendmail+chmod a+x dummy-sendmail++darcs init --repo R+darcs get R S++# Create an email message with a patch+cd R+echo 'Example content.' >file1+darcs add file1+darcs rec -a --name patch1+darcs send --dont-edit-description --to noreply@example.net --sendmail-command '../dummy-sendmail %<' -a ../S+mv message patch-set1++# Apply the patch set. darcs should email a report. If it does our dummy-sendmail script will +# create file "message".+cd ../S+darcs apply --reply noreply@example.net --sendmail-command '../dummy-sendmail %<' ../R/patch-set1+[ -f ./message ] || exit 1
+ tests/failing-issue2187-apply--test-non-interactive.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue2187 - "darcs apply --test <patch-set" crashes if +## the test fails.+##+## Copyright (C) 2012 Ilya Perminov+##+## 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+darcs get R S++# Create a patch bundle+cd R+echo 'Example content.' >file1+darcs add file1+darcs rec -a --name patch1+darcs send --dont-edit-description --output=./patch1 -a ../S++# Setup a test that fails, apply the patch set, check for an unhandled exception.+cd ../S +darcs setpref test false+not darcs apply --test <../R/patch1 > log 2>&1+not fgrep -q "illegal operation" log
+ tests/failing-issue2203-only-list-toplevel-deleted-dirs.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue2203 - darcs should only list toplevel deleted directories+##+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf R+darcs init --repo R+cd R++mkdir -p dir1/dir2++touch dir1/file1+touch dir1/dir2/file2++darcs rec -alm 'Add dirs/files'++rm -r dir1++# Darcs should only report that the top-level dir has been removed, rather than+# each dir/file (i.e 4 changes in this case, not 1).+[[ $(darcs wh | grep '^rm' | wc -l) -eq 1 ]]
+ tests/failing-issue2208-replace-fails-with-resolving-unrecorded-change.sh view
@@ -0,0 +1,53 @@+#!/usr/bin/env bash+## Test for issue2208 - darcs shouldn't fail to replace if unrecorded changes+## would make the replace succeed+##+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf R++darcs init --repo R++cd R++echo -e 'foo\nbar' > testing++darcs rec -alm 'Add testing file'++echo -e 'baz\nbar' > testing++# Darcs will complain here, since we've not recorded the fact that we've+# removed the occurrence of foo+darcs replace bar foo testing | not grep Skipping++# We can get around this by recording, then replacing and amending the patch...+darcs rec -am "I don't want to have to record this!"++darcs replace bar foo testing++echo y | darcs amend -a++# Check the workaround succeeded.+darcs changes --last 1 -v | grep 'replace.*bar.*foo'
+ tests/failing-issue2213-lastregrets-dependencies.sh view
@@ -0,0 +1,41 @@+#!/usr/bin/env bash+## Test for issue2213 - last regrets should respect patch dependencies when+## going back through patches+##+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf R S+darcs init --repo R+darcs init --repo S+cd R++echo 'a' > file+darcs rec -alm a++echo 'b' > file+darcs rec -alm b++# Darcs shouldn't ask about b before asking about a.+echo nkd | darcs push ../S | not grep b
+ tests/failing-issue2219-no-working.sh view
@@ -0,0 +1,69 @@+#!/usr/bin/env bash+## Test for issue2219 - the --no-working-dir flag+##+### Copyright (C) 2011 Eric Kow +##+## Permission is hereby granted, free of charge, to any person o+## 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++# getting a --no-working-dir repo should not create any of the wd files+mkdir R1+cd R1+darcs init+echo "howdy" > a+darcs add a+darcs record -a -m 'a file' a+cd ..+darcs get --no-working-dir R1 R2+test -e R1/a+test ! -e R2/a++# absence of a working dir should not result in a pull conflict+# or a diff for that matter+## 2011-12-27: darcs failed: error opening _darcs/pristine.hashed/7cb4df6851fc86f51ee33ff490a85c9f4f5cc31f7c7d9977c50942453a1a94a9+darcs get R1 R1b+cd R1b+echo "more stuff" > a+darcs record -a -m 'modify a'+cd ../R2+darcs pull ../R1b -a+# NB: not sure if this test expresses what I really intend+DIFFCOUNT=$(darcs diff | wc -l)+test [ $DIFFCOUNT -eq 0 ]++# 2011-12-27: unclear on what should happen here+mkdir S1+cd S1+darcs init --no-working-dir+echo "bonjour" > a+darcs add a+darcs record -a -m 'a file' a+cd ..++# --no-working-dir --working-dir flags should trump each other in the+# same fashion as the rest of darcs+#+## 2011-12-27: fails+darcs get --no-working-dir --with-working-dir R1 R3+test -e R3/a+darcs get --with-working-dir --no-working-dir R1 R4+test ! -e R4
+ tests/failing-issue2234-rollback-under-tag-with-filename.sh view
@@ -0,0 +1,52 @@+#!/usr/bin/env bash+## Test for issue2234 - darcs doesn't ignore tags when rolling back, so tagged+## patches can't be selected. +##+## Copyright (C) 2012 Owen Stephens+##+## 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 -e "line1\nline2" > f1+cp f1 f2++darcs rec -alm 'Add files'++# Make a couple of changes to two files+sed -i -e 's/1/a/' f1+sed -i -e 's/2/b/' f2++darcs rec -am 'change 1'++# Make another change to one file+sed -i -e 's/1/A/' f2+darcs rec -am 'change 2'++darcs tag footag++# we'd like to cut down the presented patches, by giving a filename should ask+# us about the changes in the first patch+darcs rollback -p '1' f1 | not grep -i 'no patches selected'
+ tests/failing-issue2238-unadded-files-showing-added.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for issue2238 - passing -l twice to whatsnew reports unadded files as+## already added.+##+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf R+darcs init --repo R+cd R++touch foo++darcs wh -l | grep 'a \./foo'+darcs wh -ll | grep 'a \./foo'+darcs wh -ll | not grep 'A \./foo'
+ tests/failing-issue2242-rollback-mv.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash+## Test for issue2242 - rollback of a mv patch generates bogus changes+##+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf R+darcs init --repo R+cd R++# Setup dir with empty file in it+mkdir A+touch A/foo+darcs rec -alm 'Add A'++# Mv dir and add content to file+darcs mv A B+echo -e 'line1\nline2' > B/foo+darcs rec -alm 'Move A -> B and change foo'++# Rollback everything in the move/change patch+echo ynya | darcs roll++# We shouldn't see any rm'd dirs/files (just a move and line removal hunk)+darcs wh | not grep rm
+ tests/failing-issue2243-unknown-patch-annotating-empty-first-line.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for issue2243 - annotating a file with a blank first gives an "unknown"+## patch.+##+## Copyright (C) 2012 Owen Stephens+##+## 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 -e "\nline2" > file++darcs rec -alm 'Add file'++darcs annotate file | not grep unknown
+ tests/failing-issue2256-diff-empty-argument.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue2256 - Passing an empty string as an argument to darcs diff+## causes a failiure in updateIndex.+## Copyright (C) 2013 Owen Stephens+##+## 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++rm -rf R++darcs init --repo R++cd R++echo foo > foo+darcs rec -alm 'add foo'++echo bar >> foo++# This should not do anything.+darcs diff '' 2>&1 > output++# We don't want any output.+[[ ! -s output ]]
+ tests/failing-issue2257-impossible-obliterate-subset.sh view
@@ -0,0 +1,64 @@+#!/usr/bin/env bash+## Test for issue2257 - impossible case encountered when obliterating a subset+## of patches+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf issue2257+mkdir issue2257+cd issue2257++darcs init --repo single-patch+darcs init --repo duplicate-patch++cd single-patch++mkdir dir+touch dir/file1+darcs record -alm 'dir and file1'++touch dir/file2+darcs record -alm 'addfile file2'++cd ../duplicate-patch++# Split the dir/file patch into the dir add, and then the file add.+darcs pull -a ../single-patch -p 'dir and file'+darcs unrecord -a++# Only record 'adddir ./dir'+echo yny | darcs record -m 'adddir dir' +# Now record the addfile in a separate patch.+darcs record -am 'addfile file1'++# Pull in the other patches we don't have (which will include the original +# "add dir/file1" patch again since we've amended it to no longer exist, and+# the "addfile file2" patch)+darcs pull -a ../single-patch++# Attempt to obliterate 'addir dir' (but not 'addfile file1'). This seems to be+# a problem with the patch selection, since without -p, we aren't able to+# obliterate 'adddir dir', if we say no to 'addfile file1' (which is+# sensible!).+echo nyy | darcs obliterate -p 'adddir dir'
+ tests/failing-issue2272-rebase-unsuspend-copes-with-unrecorded-changes.sh view
@@ -0,0 +1,52 @@+#!/usr/bin/env bash+## Test for issue2272 - darcs rebase unsuspend should cope with unrecorded changes.+##+## Copyright (C) 2013 Mark Stosberg+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++darcs init --repo R # Create our test repos.+cd R+touch t.txt+darcs add t.txt+darcs record -am 'initial record' t.txt++echo 'original line' > t.txt+darcs record -am 'adding original line' t.txt++# Now make an unrecorded change that's unrelated.+touch 2.txt+darcs add 2.txt++# Suspend the initial patch+darcs rebase suspend -a -p 'adding original line'++# Now, unsuspend that patch. It should succeed despite unrecorded changes being present.+darcs rebase unsuspend -a++# Additional case: An unrecorded change that conflicts with the suspended patch+# This should succeed, but leave conflict markers.+echo 'modified line' >t.txt+darcs rebase unsuspend -a++cd ../
+ tests/failing-issue2293-laziness-amend.sh view
@@ -0,0 +1,35 @@+#!/bin/sh -e+##+## Test that amend-record doesn't read too much of the repository+##+## Copyright (C) 2013 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++gunzip -c $TESTDATA/laziness-cut.tgz | tar xf -++cd repo++echo 'baz' > bar++echo yyyy | darcs amend-rec
+ tests/failing-issue2303-diagnostic-for-bad-patch-index-permissions.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue2303 - diagnostics for patch index should be clear there's a permission problem+##+## Copyright (C) 2013 Mark Stosberg+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++darcs init --repo R # Create our test repos.+cd R+touch t.txt+darcs add t.txt+darcs record -am 'initial record' t.txt+darcs optimize enable-patch-index++chmod -w _darcs/patch_index++# We expect this command to fail because the patch index isn't writable+# and give a reasonable diagnostic that explains this. It should mention that+# the permission problem is the _darcs/patch_index directory.+not darcs oblit -a | grep '_darcs/patch_index';+++cd ../
+ tests/failing-issue2308-changes-missing-amend-edit.sh view
@@ -0,0 +1,54 @@+#!/usr/bin/env bash+## Test for issue2308 changes aren't listed when using amend --edit+##+## Copyright (C) 2013 Owen Stephens+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++rm -rf R++darcs init --repo R++cd R+echo -e 'a\nb\nc' > file+darcs rec -alm 'Add file'++cat > expected <<EOF+ * Add file+Shall I amend this patch? [yNjk...], or ? for more options: Add file+***END OF DESCRIPTION***++Place the long patch description above the ***END OF DESCRIPTION*** marker.+The first line of this file will be the patch name.+++This patch contains the following changes:++EOF++export DARCS_EDITOR=cat+# Ignore the patch date/author line (telling tail to start at line 2) and the+# "finished amending patch:" lines+echo y | darcs amend --edit | tail -n+2 | head -n-3 > actual++not diff expected actual
+ tests/failing-issue2310-rollback-doesnt-readd.sh view
@@ -0,0 +1,43 @@+## Test for issue2310 - darcs rollback of rmfile doesn't add to pending+##+## Copyright (C) 2013 Owen Stephens+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++rm -rf R++darcs init --repo R++cd R++echo foo > foo +darcs rec -alm 'add foo'++rm foo+darcs rec -am 'remove foo'++echo ynya | darcs rollback++# If the file hasn't been re-added in pending, this line will be missing from+# the output of whatsnew+darcs wh | grep 'A ./foo'
+ tests/failing-issue2380-rename-to-deleted-file.sh view
@@ -0,0 +1,47 @@+#!/usr/bin/env bash+## Test for issue2380 - darcs won't rename a file to a file that has been+## deleted in the working dir.+##+## Copyright (C) 2014 Owen Stephens+##+## 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+rm -rf R && darcs init --repo R++. lib++cd R+echo foostuff > foo+echo otherstuff > other+darcs rec -alm 'Add foo and other'++rm foo+darcs mv other foo++# foo should exist, with the correct contents, and other should not+[[ -e foo && ! -e other && $(<foo) == "otherstuff" ]]++echo -e 'hunk ./foo 1\n-foostuff\nrmfile ./foo\nmove ./other ./foo' > expected+darcs wh > actual++diff expected actual++darcs rev -a++[[ -e foo && -e other && $(<foo) == "foostuff" && $(<other) == "otherstuff" ]]
+ tests/failing-issue2383-hunk-edit-fails.sh view
@@ -0,0 +1,76 @@+#!/bin/bash+## Test for issue2383 hunk-edit/last-regrets being able to put darcs into a+## state that it can't apply the recorded patch+##+## Copyright (C) 2013 Owen Stephens+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++rm -rf R+darcs init --repo R++cd R++cat << EOF > file+-- a comment++data D = C Int+ deriving (Eq, Show)+EOF++darcs rec -alm 'Add file'+++cat << EOF > file+-- another comment++-- a comment++data D = C !Int+ deriving (Eq)+EOF++# Massive hack!+cat << EOF > change+========================== BEFORE (reference) ==========================+data D = C Int+ deriving (Eq, Show)+============================= AFTER (edit) =============================+data D = C !Int+ deriving (Eq, Show)+============================= (edit above) =============================+EOF++# Shell script "editor" that makes the change+cat << EOF > foo+#!/bin/bash+cp change darcs-patch-edit-0+EOF+chmod +x foo++export DARCS_EDITOR='./foo'++# Don't pick the first comment, do initially pick the data type change, then at+# last regrets, go back (k) and edit the hunk (e), before accepting (y) the new+# hunk change (keeping the Show instance).+echo nykeyy | darcs rec -m 'Add strictness annotation to C Int'
+ tests/failing-issue2386-no-trailing-EOL.sh view
@@ -0,0 +1,56 @@+#!/usr/bin/env bash+## Test for issue2386 - no trailing EOF produces spurious diff output+##+## Copyright (C) 2014 Owen Stephens+##+## 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++# foo will contain "1\n2\n3"+echo '0: 310a 320a 33' | xxd -r > foo++darcs add foo++# Bad output looked like:+#+# addfile ./foo+# hunk ./foo 1+# -+# +1+# +2+# +3+darcs wh | not grep '^-$'++darcs rec -am 'Add foo'++rm foo++# Bad output looked like:+# hunk ./foo 1+# -1+# -2+# -3+# ++# rmfile ./foo+darcs wh | not grep '^+$'
tests/failing-issue390_whatsnew.sh view
@@ -2,7 +2,7 @@ # For issue390: darcs whatsnew somefile" lstats every file in the working copy and pristine/ directory -set -ev+. ./lib if ! test -x "$(which strace)" then echo skipping test since strace was not found
tests/failing-issue612_repo_not_writable.sh view
@@ -7,10 +7,6 @@ abort_windows -if grep old-fashioned .darcs/defaults; then- exit 200-fi- rm -rf temp1 temp2 mkdir temp1 cd temp1
tests/failing-issue68_broken_pipe.sh view
@@ -2,7 +2,7 @@ # For issue68, 'don't report "resource vanished" when stdout pipe is broken.' -set -ev+. ./lib rm -rf temp1 # Another script may have left a mess.
+ tests/failing-look_for_moves.sh view
@@ -0,0 +1,39 @@+#!/usr/bin/env bash++. ./lib++rm -rf temp1 temp2+mkdir temp1 temp2+cd temp1++# # exchange of dirs with contents and exchange filenames inside++darcs init+mkdir dir dir2+touch dir/foo dir2/foo dir2/foo2+darcs record -a -m add_files_and_dirs -A x --look-for-adds+mv dir dir.tmp+mv dir2 dir+mv dir.tmp dir2+mv dir/foo dir/foo.tmp+mv dir/foo2 dir/foo+mv dir/foo.tmp dir/foo2+darcs wh --summary --look-for-moves > log 2>&1+cat > log.expected <<EOF+ ./dir -> ./dir.tmp~+ ./dir2 -> ./dir+ ./dir.tmp~ -> ./dir2+ ./dir/foo -> ./dir/foo.tmp~+ ./dir/foo2 -> ./dir/foo+ ./dir/foo.tmp~ -> ./dir/foo2+EOF+diff -u log log.expected+rm log log.expected+darcs record -a -m move_dirs -A x --look-for-moves+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *+++cd ..+rm -rf temp1
+ tests/failing-look_for_replaces1.sh view
@@ -0,0 +1,49 @@+#!/usr/bin/env bash+## Failing test for --look-for-replaces+##+## Copyright (C) 2013 Jose Neder+##+## 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++rm -rf R+mkdir R+cd R++# forced replace (the word is in the file) (amend-record)+# amending an addfile patch with a forced replace fails+darcs init+cat > file <<EOF+foo+foo+bar+EOF+darcs record -al -m "add file"+cat > file <<EOF+bar+bar+bar+EOF+echo yyy | darcs amend-record --look-for-replaces+cd ..+rm -rf R+
+ tests/failing-look_for_replaces2.sh view
@@ -0,0 +1,44 @@+#!/usr/bin/env bash+## Failing test for --look-for-replaces combined with --look-for-moves+##+## Copyright (C) 2014 Guillaume Hoffmann+##+## 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++rm -rf R+mkdir R+cd R++darcs init+cat > file <<EOF+foo+EOF+darcs record -lam file+cat > file <<EOF+bar+EOF+mv file newfile+darcs whatsnew --look-for-moves --look-for-replaces | grep replace+cd ..+rm -rf R+
tests/failing-merging_newlines.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # Note that this is fixed, the lines marked # BUG HERE # should be moved back into merging_newlines.sh
tests/failing-newlines.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 @@ -20,7 +20,7 @@ cd temp2 echo "in tmp2" >> one.txt darcs record -A bar -am "add extra line"-lines_added=`darcs changes -v --last=1 | grep '\+' | wc -l`+lines_added=`darcs changes -a -v --last=1 | grep '\+' | wc -l` echo $lines_added test $lines_added -eq 1 cd ..
tests/failing-nice-resolutions.sh view
@@ -1,6 +1,6 @@ #!/bin/sh -set -ev+. ./lib mkdir temp1 cd temp1
tests/failing-pristine-problems.sh view
@@ -25,8 +25,6 @@ . lib # Load some portability helpers. -if grep old-fashioned .darcs/defaults; then exit 200; fi- rm -rf foo mkdir foo cd foo
tests/filepath.sh view
@@ -50,11 +50,11 @@ rm -rf non-darcs # get accepts --repodir.-darcs get --repodir=temp2 temp1 | grep -i "Finished getting"+darcs get --repodir=temp2 temp1 | grep -i "Finished cloning" test -d temp2/_darcs rm -rf temp2 # get accepts absolute --repodir.-darcs get --repodir="${DIR}/temp2" temp1 | grep -i "Finished getting"+darcs get --repodir="${DIR}/temp2" temp1 | grep -i "Finished cloning" test -d temp2/_darcs # changes accepts --repodir.@@ -70,19 +70,19 @@ darcs dist --repodir=temp1 | grep -i "Created dist" # optimize accepts --repodir.-darcs optimize --reorder-patches --repodir=temp1 | grep -i "done optimizing"+darcs optimize reorder --repodir=temp1 | grep -i "done" # repair accepts --repodir. darcs repair --repodir=temp1 | grep -i "already consistent" # replace accepts --repodir.-darcs replace --repodir=temp1 foo bar+darcs replace --repodir=temp1 foo bar baz # setpref accepts --repodir. darcs setpref --repodir=temp1 test echo | grep -i "Changing value of test" -# trackdown accepts --repodir.-darcs trackdown --repodir=temp1 | grep -i "Success!"+# test --linear accepts --repodir.+darcs test --linear --repodir=temp1 | grep -i "Success!" # ---------------------------------------------------------------------- # converting between absolute and relative paths
tests/get-http-packed-detect.sh view
@@ -4,24 +4,23 @@ # Tets that darcs get --verbose reports getting a pack when there is one, # and does not report when there is none or when --no-packs is passed. +#pragma repo-format darcs-1,darcs-2+ . lib -rm -rf R S && mkdir R-cd R-darcs init+rm -rf S -darcs show repo > repo-grep "Format: hashed" repo || exit 200 # not supported with oldfashioned repos+if grep darcs-1 .darcs/defaults; then+format=hashed+elif grep darcs-2 .darcs/defaults; then+format=darcs-2+else format=ERROR; fi -for f in `seq 1 200`; do- echo $f > $f- darcs rec -lam $f-done+gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf - -darcs optimize # FIXME the pristine.hashed in the basic tarball has extra files- # without this step+cd many* -darcs optimize --http+darcs optimize http test -e _darcs/packs/basic.tar.gz test -e _darcs/packs/patches.tar.gz cd ..@@ -29,13 +28,13 @@ serve_http # sets baseurl # check that default behaviour is to get packs-darcs get $baseurl/R S --verbose |grep "Getting packed repository"+darcs get $baseurl/many-files--${format} S --verbose |grep "Cloning packed basic repository" # check that it does really not get packs when --no-packs is passed rm -rf S-darcs get $baseurl/R S --no-packs --verbose |not grep "Getting packed repository"+darcs get $baseurl/many-files--${format} S --no-packs --verbose |not grep "Cloning packed basic repository" # check that it does not clam getting packs when there are not rm -rf S-rm -rf R/_darcs/packs/-darcs get $baseurl/R S --verbose |not grep "Getting packed repository"+rm -rf many-files--${format}/_darcs/packs/+darcs get $baseurl/many-files--${format} S --verbose |not grep "Cloning packed basic repository"
tests/get-http-packed.sh view
@@ -1,30 +1,29 @@ #!/usr/bin/env bash # Written in 2010 by Petr Rockai, placed in public domain +#pragma repo-format darcs-1,darcs-2+ . lib -rm -rf R S && mkdir R-cd R-darcs init+rm -rf S -darcs show repo > repo-grep "Format: hashed" repo || exit 200 # not supported with oldfashioned repos+if grep darcs-1 .darcs/defaults; then+format=hashed+elif grep darcs-2 .darcs/defaults; then+format=darcs-2+else format=ERROR; fi -for f in `seq 1 200`; do- echo $f > $f- darcs rec -lam $f-done+gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf - -darcs optimize # FIXME the pristine.hashed in the basic tarball has extra files- # without this step+cd many* -darcs optimize --http+darcs optimize http test -e _darcs/packs/basic.tar.gz test -e _darcs/packs/patches.tar.gz cd .. serve_http # sets baseurl-darcs get --packs $baseurl/R S+darcs get --packs $baseurl/many-files--${format} S cd S rm _darcs/prefs/sources # avoid any further contact with the original repository darcs check
tests/get_tag.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1@@ -54,7 +54,7 @@ mkdir temp2 cd temp2 darcs init-echo y/n/y | tr / \\012 | darcs pull ../temp1+echo ynyy | darcs pull ../temp1 darcs tag -Ax -m Tag darcs push -a ../temp1 cd ..
tests/harness.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -vex+. ./lib # Print some stuff out for debugging if something goes wrong: echo $HOME
tests/hashed_inventory.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib # We'd just use `diff -x _darcs -r' if -x was portable. diffx () {@@ -31,7 +31,7 @@ mkdir temp1 cd temp1-darcs init --hashed+darcs init --darcs-1 touch foo darcs add foo darcs rec -m t1 -a -A tester@@ -52,7 +52,7 @@ cd temp3 darcs changes cp _darcs/hashed_inventory inv-darcs optimize+darcs optimize clean diff -c inv _darcs/hashed_inventory rm inv makepristine@@ -99,7 +99,7 @@ diff -rc temp2/pristine temp3/pristine cd temp1-darcs put ../temp4+darcs get . ../temp4 cd .. cd temp4 makepristine@@ -111,7 +111,7 @@ cd temp1 darcs tag -A tagger -m atag darcs check-darcs optimize+darcs optimize clean darcs check darcs changes | grep t1 cd ..@@ -121,11 +121,11 @@ darcs add foobarpatch darcs record -a -A silly -m foobarpatch darcs check-darcs optimize+darcs optimize clean darcs check darcs pull -a ../temp1 darcs check-darcs optimize --reorder-patches+darcs optimize reorder darcs check grep 'Starting with inventory' _darcs/hashed_inventory cd ..@@ -139,7 +139,7 @@ cd temp4 darcs pull -p foobarpatch -a ../temp3 darcs pull -a ../temp1-darcs optimize --reorder+darcs optimize reorder darcs check darcs push ../temp1 cd ..
@@ -1,6 +1,6 @@ #!/bin/sh -set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # A test for a missed resolution, inspired by bug #10 in RT
tests/hunk-editor.sh view
@@ -34,7 +34,7 @@ darcs record -lam "version1" echo 'version2' > file-(echo e ; echo y ; echo n) | DARCS_EDITOR="sed -i -e s/version2/version1.5/" darcs record -m "version1.5"+echo eyny | DARCS_EDITOR="sed -i -e s/version2/version1.5/" darcs record -m "version1.5" cat > expected <<EOF hunk ./file 1
tests/ignoretimes.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -rf temp1
tests/illegal_mv.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp mkdir temp
tests/impossible_unrevert.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp mkdir temp@@ -10,10 +10,10 @@ darcs add foo darcs record -a -m aa -A test echo b > foo-echo y | darcs revert -a-echo y/d/y | tr / \\012 | darcs unrecord+echo yy | darcs revert -a+echo ydyy | darcs unrecord # since the unrevert is impossible, we should fail if it succeeds...-echo y | darcs unrevert && exit 1 || true+echo yy | darcs unrevert && exit 1 || true # now let's try a possible unrevert, just for fun... echo b >> foo@@ -21,10 +21,10 @@ echo f/b | tr / \\012 > foo darcs record -a -m 'aaa becomes f' -A test date >> foo-echo y | darcs revert -a-echo y/d/y | tr / \\012 | darcs unpull+echo yy | darcs revert -a+echo ydyy | darcs unpull # Now add the date back on at the end:-echo y | darcs unrevert+echo yy | darcs unrevert echo 'M ./foo +1' > correct_summary darcs whatsnew --dont-look-for-adds --summary > actual_summary diff -c correct_summary actual_summary
tests/init.sh view
@@ -16,4 +16,10 @@ darcs init --repodir temp2 test -d temp2/_darcs -rm -rf temp1 temp2+# Checking that `darcs init x` works++not darcs init x y # refuse when 2 arguments are given+not darcs init x --repodir y # refuse for the same reason+darcs init x++rm -rf temp1 temp2 x
tests/invalid_pending_after_mv_to_self.sh view
@@ -2,7 +2,7 @@ # A regression test for issue567 -set -ev+. ./lib rm -rf temp mkdir temp
tests/issue1012_unrecord_remove.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1 cd temp1@@ -10,9 +10,9 @@ darcs record File.hs -a -m "add File" rm File.hs darcs record -a -m "rm File"-darcs cha+darcs changes darcs unrecord -p "rm File" -a-darcs cha+darcs changes darcs record -a -m "re-rm File" cd .. rm -rf temp1
tests/issue1017_whatsnew_stack.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/issue1039.sh view
@@ -60,9 +60,9 @@ darcs record -a -m "change b $i" done -echo no | darcs send --all --to=random@random --sendmail-command=false ../temp1-echo yes | not darcs send --all --to=random@random --sendmail-command=false ../temp1-not darcs send --all --to=random@random --sendmail-command=false --allow-unrelated-repos ../temp1+echo no | darcs send --mail --all --to=random@random --sendmail-command=false ../temp1+echo yes | not darcs send --mail --all --to=random@random --sendmail-command=false ../temp1+not darcs send --mail --all --to=random@random --sendmail-command=false --allow-unrelated-repos ../temp1 cd .. rm -rf temp1 temp2
tests/issue1043_geteff_a.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -rf temp1 temp2 # creating the fork point
tests/issue1043_geteff_b.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -rf temp1 temp2 # creating the fork point
tests/issue1101.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib DARCS_EDITOR=echo export DARCS_EDITOR@@ -19,10 +19,10 @@ darcs record -a -m add_foo_bar -A x # Test that --cc is also printed as recipient in case of success-darcs send --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com+darcs send --mail --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com # Test that --cc is also printed as recipient in case of error-darcs send --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com+darcs send --mail --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com cd .. rm -rf temp1 temp2
tests/issue1105.sh view
@@ -28,6 +28,8 @@ echo changes author me > _darcs/prefs/defaults not darcs changes+echo changes author me > _darcs/prefs/defaults+not darcs changes echo ALL author me > _darcs/prefs/defaults darcs changes echo ALL unknown > _darcs/prefs/defaults
tests/issue1110_get_hashed.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp1-h gunzip -c $TESTDATA/many-files--old-fashioned-inventory.tgz | tar xf -
tests/issue1139-diff-last.sh view
@@ -1,10 +1,10 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp-$$ mkdir temp-$$ cd temp-$$-set -e+ darcs initialize echo text > foo darcs add foo
tests/issue1139-diff-with-no-args.sh view
@@ -1,10 +1,10 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp-$$ mkdir temp-$$ cd temp-$$-set -e+ darcs initialize echo text > foo darcs add foo
tests/issue1162_add_nonexistent_slash.sh view
@@ -1,6 +1,6 @@ #!/bin/sh -set -ev+. ./lib not () { "$@" && exit 1 || :; }
tests/issue121.sh view
@@ -40,6 +40,6 @@ darcs obliterate --dry-run --patch 'patch Y' | not grep 'patch Z' -echo 'yy' | darcs amend-rec --ask-deps+echo 'yYyY' | tr '[A-Z]' '[a-z]' | darcs amend --ask-deps darcs obliterate --dry-run --patch 'patch Y' | grep 'patch Z'
tests/issue1210-no-global-cache-in-sources.sh view
@@ -23,9 +23,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev--. lib+. ./lib cacheDir=$HOME/.darcs/cache
tests/issue1248.sh view
@@ -8,5 +8,5 @@ gunzip -c $TESTDATA/oldfashioned-compressed.tgz | tar xf - cd oldfashioned-compressed-darcs optimize --upgrade+darcs optimize upgrade darcs check
+ tests/issue1266_init_inside_a_repo.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash+## Test for issue1266 - attempting to initialize a repository inside+## another repository should cause a warning, because while perfectly+## legitimate, it is likely to be accidental.+##+## Copyright (C) 2009 Trent W. Buck+##+## 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++rm -rf temp1 out # Another script may have left a mess.+darcs init --repodir temp1+darcs init --repodir temp1/temp2 2>&1 | tee out+grep -i WARNING out # A warning should be printed.
tests/issue1269_setpref_predist.sh view
@@ -1,6 +1,6 @@ #!/bin/sh -set -ev+. ./lib not () { "$@" && exit 1 || :; }
tests/issue1290-diff-index.sh view
@@ -36,7 +36,10 @@ darcs record -lam 'three' echo '4' > f darcs record -lam 'four'- darcs diff --no-unified --from-patch one --to-patch two > d1- darcs diff --no-unified --index=3-4 > d2 # the numbers go backwards+ # in the following outputs of `darcs diff`, we delete the+ # lines "diff -rN old-... new-..." since they can be different+ # if tests are run in parallel+ darcs diff --no-unified --from-patch one --to-patch two | sed /^diff/d > d1+ darcs diff --no-unified --index=3-4 |sed /^diff/d > d2 # the numbers go backwards diff -q d1 d2 cd ..
− tests/issue1332_add_r_boring.sh
@@ -1,45 +0,0 @@-#!/usr/bin/env bash-## Test for issue1332 - add -r ignores --boring-##-## Copyright (C) 2009 Eric Kow-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib # Load some portability helpers.-rm -rf R # Another script may have left a mess.-darcs init --repo R # Create our test repos.--cd R-mkdir d-touch core f-# this is already known to work-darcs add --boring core f-darcs whatsnew > log-grep 'addfile ./f' log-grep 'addfile ./core' log-rm _darcs/patches/pending-# this fails for issue1332-darcs add -r --boring .-darcs whatsnew > log-grep 'addfile ./f' log-grep 'addfile ./core' log-rm _darcs/patches/pending-cd ..
tests/issue1344_abort_early_cant_send.sh view
@@ -24,9 +24,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev--. lib+. ./lib # The mail sending code on Windows uses the MAPI API unconditionally # so this test fails.@@ -68,6 +66,6 @@ darcs send --author=me -a --to=random@random -O ../temp2 darcs send --author=me -a --to=random@random -o test.patch ../temp2 # Otherwise, fail early-darcs send --author=me -a --to=random@random ../temp2 | grep "No working sendmail"+(darcs send --author=me -a --to=random@random ../temp2 || true) | grep "No working sendmail" cd ..
tests/issue1427_apply_gz.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1 temp2
tests/issue1473_annotate_repodir.sh view
@@ -1,7 +1,6 @@ #!/usr/bin/env bash-set -ev+. ./lib -. lib rm -rf temp mkdir temp cd temp
+ tests/issue1514-send-minimize.sh view
@@ -0,0 +1,59 @@+#!/usr/bin/env bash+## Test for issue1514: send --minimize+##+## Copyright (C) 2014 G. Hoffmann+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.+darcs init --repo SCREENED # Create our test repos.++cd SCREENED+touch a+darcs rec -lam a+touch b+darcs rec -lam b+cd ..++darcs clone SCREENED LOCAL+darcs clone SCREENED REVIEWED++cd LOCAL+touch c+darcs rec -lam c+darcs push --all # so SCREENED has c++# now create a patch we'll send as bundle with full context+touch d+darcs rec -lam d+darcs send --all -o bundle --no-minimize++# check it cannot be applied to REVIEWED (which lacks patch c)+not darcs apply bundle --all --repodir=../REVIEWED++# now create bundle with minimal context (default option)+darcs send --all -o bundle.min++# this one lacks c in its context so it can be applied to REVIEWED+darcs apply bundle.min --all --repodir=../REVIEWED++cd ..+
− tests/issue157_rollback_conflict.sh
@@ -1,44 +0,0 @@-#!/usr/bin/env bash--# issue157: A test for how rollback handles dependencies and conflicts.--. lib--rm -rf temp1 temp2--# set up the repository-mkdir temp1-cd temp1-darcs init --darcs-2-cd ..--# do some work here-cd temp1-echo a > foo-# Create three patches-darcs record -lam AA-echo b > foo-darcs record -lam BB-echo c > foo-darcs record -lam CC-# Rollback the last one-darcs rollback -a -p CC -m 'rollback CC'-grep b foo # reality check-cd ..--# Now get just the first two patches into a new repo...ignoring the third patch and the rollback.-darcs get --to-patch BB temp1 temp2-cd temp2-# Now in the second repo, rollback the second patch.-darcs rollback -a -p BB -m 'rollback BB'-grep a foo # reality check-# Finally, pull the third patch and the rollback of it.-# Because the two patches should cancel each other other, there should be no change here.-darcs pull -a ../temp1-# expect a conflict between the contents being 'a' or 'b'-grep "v v v" foo-grep a foo-grep b foo-cd ..--rm -rf temp1 temp2
tests/issue1584_optimize_upgrade.sh view
@@ -29,7 +29,7 @@ mv many-files--old-fashioned-inventory R echo x > R/foo # Unrecorded change-darcs optimize --repo R --upgrade+darcs optimize upgrade --repo R darcs check --repo R grep hashed R/_darcs/format not grep darcs-2 R/_darcs/format
tests/issue1599-automatically-expire-unused-caches.sh view
@@ -24,8 +24,6 @@ ## SOFTWARE. . lib -skip-formats old-fashioned- rm -rf R S log && mkdir R cd R darcs init@@ -46,7 +44,7 @@ echo "repo:$baseurl/dummyRepo" >> S/_darcs/prefs/sources echo "repo:~/test1599/S" >> S/_darcs/prefs/sources echo "repo:$baseurl/R" >> S/_darcs/prefs/sources-darcs changes --repo S --debug --verbose --no-cache 2>&1 | tee log+export DARCS_CONNECTION_TIMEOUT=1 && darcs changes --repo S --debug --verbose --no-cache 2>&1 | tee log if [ -z "$http_proxy" ]; then c=`grep -c "URL.waitUrl http://10.1.2.3/S" log` [ $c -eq 1 ]
tests/issue1618-amend-preserve-logfile.sh view
@@ -24,8 +24,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev-. lib+. ./lib rm -rf R; mkdir R; cd R darcs init
tests/issue1620-record-lies-about-leaving-logfile.sh view
@@ -24,8 +24,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev-. lib+. ./lib rm -rf R; mkdir R; cd R export DARCS_EDITOR="echo 'a log' > " darcs init
tests/issue1645-ignore-symlinks-case-fold.sh view
@@ -59,8 +59,8 @@ ln -s "`pwd`"/non-recorded-file2 ./Non-ReCoRdEd-File2 darcs w -l >log 2>&1 # should report only "non-recorded-file" darcs rec -alm "added ./non-recorded-file2" >>log 2>&1 # should add only file, not symlink-darcs changes -s --patch="added ./non-recorded-file2" >>log 2>&1 # should report only file, not symlink-not grep -vE "(^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-file2)" log+darcs changes -s --patches="added ./non-recorded-file2" >>log 2>&1 # should report only file, not symlink+not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-file2)" log rm Non-Recorded-File2 ./Non-ReCoRdEd-File2 # Case 16: case-folding link to recorded file
tests/issue1645-ignore-symlinks.sh view
@@ -56,8 +56,8 @@ ln -s "`pwd`"/non-recorded-dir ./non-recorded-dir/loop2 # absolute symlink darcs w -l >log 2>&1 # should not loop darcs rec -alm "added ./non-recorded-dir" >>log 2>&1 # should not loop-darcs changes -s --patch="added ./non-recorded-dir" >>log 2>&1 # should report only dir, not symlink-not grep -vE "(^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-dir)" log+darcs changes -s --patches="added ./non-recorded-dir" >>log 2>&1 # should report only dir, not symlink+not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-dir)" log # Case 2: looping symlink to recorded dir mkdir recorded-dir@@ -84,8 +84,8 @@ ln -s "`pwd`"/non-recorded-dir2 ./link2 darcs w -l >log 2>&1 # should report only "non-recorded-dir2" darcs rec -alm "added ./non-recorded-dir2" >>log 2>&1 # should add only dir, not symlink-darcs changes -s --patch="added ./non-recorded-dir2" >>log 2>&1 # should report only dir, not symlink-not grep -vE "(^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-dir2)" log+darcs changes -s --patches="added ./non-recorded-dir2" >>log 2>&1 # should report only dir, not symlink+not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-dir2)" log rm link link2 # Case 5: non-looping symlink to recorded dir@@ -118,8 +118,8 @@ ln -s "`pwd`"/non-recorded-file ./link2 darcs w -l >log 2>&1 # should report only "non-recorded-file" darcs rec -alm "added ./non-recorded-file" >>log 2>&1 # should add only file, not symlink-darcs changes -s --patch="added ./non-recorded-file" >>log 2>&1 # should report only file, not symlink-not grep -vE "(^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-file)" log+darcs changes -s --patches="added ./non-recorded-file" >>log 2>&1 # should report only file, not symlink+not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-file)" log rm link link2 # Case 9: symlink to recorded file
tests/issue1739-escape-multibyte-chars-correctly.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-## Test for issue1739 - "Char.intToDigit: not a digit" in darcs changes +## Test for issue1739 - "Char.intToDigit: not a digit" in darcs changes ## ## Copyright (C) 2010 Reinier Lamers ##@@ -25,6 +25,11 @@ . lib +# TODO: get this working on Windows+# Seems to be a real bug - darcs doesn't record a patch with the+# right characters.+abort_windows+ # First, try to see if character set is UTF-8. If we can't find out or if it # isn't, we skip this test. if ! which locale ; then@@ -45,6 +50,7 @@ # we want escaping, otherwise output of non-ASCII characters is unreliable export DARCS_DONT_ESCAPE_ANYTHING=0+export DARCS_DONT_ESCAPE_8BIT=0 rm -rf R mkdir R
tests/issue1749-rmdir.sh view
@@ -34,7 +34,7 @@ darcs add dir/file # adds dir too (which is fine) darcs rec -a -m"add dir and file" -darcs remove dir+not darcs remove dir # removed dir but not file - should be nothing to add not darcs rec -a -m"remove dir"
+ tests/issue1845-paths-working-copy.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for issue1845 - darcs wants file paths from root of working copy+##+## Copyright (C) 2010 Guillaume Hoffmann+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.+rm -rf R S # Another script may have left a mess.+darcs init --repo R # Create our test repos.+cd R+mkdir subdir+touch subdir/subfile+darcs add subdir subdir/subfile+darcs record -am"add subdir and subfile"+cd subdir+rm subfile+darcs record subfile -am"delete file in subdirectory" # fails because darcs wants subdir/subfile +
tests/issue1845-record-removed.sh view
@@ -11,6 +11,6 @@ echo 'Example content.' > f darcs rec -lam "first" rm -f f-echo n | darcs record f 2>&1 | tee log+echo ny | darcs record f 2>&1 | tee log not grep "None of the files" log cd ..
tests/issue1871-record-dot.sh view
@@ -33,7 +33,7 @@ mkdir d # Change the working tree. echo 'Example content.' > d/f darcs add d/f-echo n | darcs record-echo n | darcs record . > log+echo ny | darcs record+echo ny | darcs record . > log not grep "None of the files" log cd ..
tests/issue1873-apply-failed-to-read-patch.sh view
@@ -47,7 +47,7 @@ darcs get R S darcs unpull -p x -a --repo R-darcs send -p x -a --repo S -o R/x.dpatch+darcs send --no-minimize -p x -a --repo S -o R/x.dpatch darcs unpull -p y -a --repo R not darcs apply --repo R R/x.dpatch 2>&1 | tee log
tests/issue1909-unrecord-O-misses-tag.sh view
@@ -14,7 +14,7 @@ echo c > R/a darcs rec -lam c --repo R --ignore-times -darcs unpull -p c -a --repo R -O+darcs unpull -p c -a --repo R -O --no-minimize cat c.dpatch grep '^\[b' c.dpatch grep TAG c.dpatch
+ tests/issue1921-missing-tag-in-apply-bundle.sh view
@@ -0,0 +1,69 @@+#!/usr/bin/env bash++## Attempting to apply a patch which depends on a missing tag should not cause+## darcs to die.+##+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf R S T patch.dpatch++darcs init --repo R++cd R++# Setup a repo with a tagged patch, and another patch ontop, so we have a split+# inventory+touch file1+darcs rec -alm 'Add file1'+darcs tag -m 'file1 tag'+touch file2+darcs rec -alm 'Add file2'++# Take a copy of the repo at this point+darcs get . ../S++# Add the tag which we will fail on+darcs tag -m 'file2 tag'++# Take a copy with the tag+darcs get . ../T++# Add our patch which will depend only on the last tag.+echo 'file1' > file1+darcs rec -am 'file1 content'++# Create a patch bundle with the new patch (by sending against the repo we+# copied, with the last tag)+darcs send ../T -a -o ../patch.dpatch --no-edit-description++cd ../S++# Try to apply to the patch which depends on the missing tag (we expect darcs+# to fail gracefully here)+not darcs apply ../patch.dpatch &> apply_output.txt++# A best-attempt at ensuring darcs warns about the missing tag:+grep "tagged file2 tag" apply_output.txt+grep "FATAL: Cannot apply this bundle. We are missing the above patches." apply_output.txt
tests/issue1922-obliterate-o-context.sh view
@@ -43,5 +43,5 @@ rm -f foo.dpatch darcs unpull -a -o foo.dpatch --match 'name a2' --repo x --last 3 cat foo.dpatch-darcs chan --context --repo x+darcs changes --context --repo x darcs apply foo.dpatch --repo x
tests/issue1923-cache-warning.sh view
@@ -24,8 +24,6 @@ ## SOFTWARE. . lib -skip-formats old-fashioned- darcs init --repo R cd R echo a > a
+ tests/issue1932-colon-breaks-add.sh view
@@ -0,0 +1,80 @@+#!/usr/bin/env bash+## Test for issue1932 - "darcs add -qr ." should not break on files with colons+##+## Copyright(C) 2010 Dmitry Astapov+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++rm -rf R # Another script may have left a mess.+mkdir -p R # Create our test repo.++cd R+darcs init+darcs --version++# Colons could be in repo names and in file name.+# Colon in repo name is an indication of special case - remote repo.+# Colon in the file could be there under unix and requires no special treatment.++# Repo name with ':' is either scp repo or http repo.+# Let's check scp repo first.+( darcs get user@invalid:path || true ) > log 2>&1+[ -n "$(fgrep 'ssh: Could not resolve hostname invalid: Name or service not known' log)" ]++# HTTP repo+( darcs get http://www.bogus.domain.so.it.will.surely.fail.com || true ) 2>&1 | tee log+egrep 'CouldNotResolveHost|host lookup failure' log++abort_windows # Windows doesn't support ':' in filenames at all++# All following files should not be added unless "--reserved-ok" is specified,+# but should be added with "--reserved-ok" just fine+mkdir funny+touch funny/0401:19d2+touch funny/c:src+touch funny/c:\\src+touch funny/user@invalid:path +touch funny/droundy@invalid: +touch funny/invalid:path++# Try to add those files. None should be added, darcs should not fail+darcs add -qr funny+darcs wh -l > log 2>&1++# Check that darcs didn't drop dead as 2.4.4 does+[ -z "$(fgrep 'fromJust: Nothing' log)" ]++# Check that no funny files were added+[ -z "$(grep '^A \./funny/.' log)" ]++# Now let's allow colons and add those files+darcs add --reserved-ok -qr funny +darcs wh -l > log 2>&1++# This should add all those files+[ -n "$(grep '^A \./funny/0401:19d2' log)" ]+[ -n "$(grep '^A \./funny/c:src' log)" ]+[ -n "$(grep '^A \./funny/c:\\src' log)" ]+[ -n "$(grep '^A \./funny/user@invalid:path' log)" ]+[ -n "$(grep '^A \./funny/droundy@invalid:' log)" ]+[ -n "$(grep '^A \./funny/invalid:path' log)" ]
tests/issue194.sh view
@@ -1,4 +1,4 @@-set -ev+. ./lib rm -rf temp1 temp2
tests/issue1977-darcs-repair.sh view
@@ -1,7 +1,7 @@ #!/usr/bin/env bash # Issue1977 darcs repair complains when there is no pristine.hashed directory-set -ev+. ./lib mkdir temp1 cd temp1 darcs init
tests/issue1978.sh view
@@ -1,5 +1,7 @@ #!/usr/bin/env bash +#pragma repo-format darcs-2+ . lib mkdir future@@ -15,11 +17,7 @@ cat _darcs/format cd .. -if grep 'old-fashioned' .darcs/defaults; then- exit 200-fi--if grep hashed .darcs/defaults; then+if grep darcs-1 .darcs/defaults; then exit 200 fi
+ tests/issue1987.sh view
@@ -0,0 +1,235 @@+#!/usr/bin/env bash+## Test for issue1987 - Garbage collection for inventories and patches+##+## Copyright (C) 2014 Marcio Diaz+##+## 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.++# This script test that 'darcs optimize' cleans+# the directories _darcs/patches/ and _darcs/inventories/+# from unnecesary files.++. lib++# The script will read the following directories:+PATCHES_DIR='_darcs/patches/'+INV_DIR='_darcs/inventories/'+PRISTINE_DIR='_darcs/pristine.hashed/'++#################################################+# Testing garbage collection on _darcs/patches/ #+#################################################++rm -rf R++darcs init --repo R+cd R++touch f+darcs add f++# In the next line, 'ls -1' list files in a single column,+# so that $PENDING_FILES should looks like:+# pending+# pending.tentative+PENDING_FILES=$(ls -1 $PATCHES_DIR)+darcs record -am 'Add f.'++# After doing 'record', the contents of $PATCHES_DIR+# should looks like (the hash will be different):+# 0000000120-8462241e685a983cff956f05a6a32f3ff6b27a485e67d19b84b2b5fef31fab84+# pending+# pending.tentative+PATCHES_DIR_AFTER_RECORD=$(ls -1 $PATCHES_DIR)++# The following line gets the names of files added to $INV_DIR after doing+# record, i.e., the name of the new patch.+# Then $PATCH should looks like:+# 0000000120-8462241e685a983cff956f05a6a32f3ff6b27a485e67d19b84b2b5fef31fab84+PATCH=`comm -13 <(echo "$PENDING_FILES") <(echo "$PATCHES_DIR_AFTER_RECORD")`++touch g+darcs add g+echo y | darcs amend-record -a++# $PATCHES_DIR_AFTER_AMEND should looks like:+# 0000000120-8462241e685a983cff956f05a6a32f3ff6b27a485e67d19b84b2b5fef31fab84+# 0000000132-23ee2a79b097dd4a134c50d196c6f7ecd5c85655ad44d34f6c1732f4b491ca35+# pending+# pending.tentative+PATCHES_DIR_AFTER_AMEND=$(ls -1 $PATCHES_DIR)++# This is one of the important parts of the script. If issue1987 is+# correctly solved, 'darcs optimize' should delete the patch:+# 0000000120-8462241e685a983cff956f05a6a32f3ff6b27a485e67d19b84b2b5fef31fab84+darcs optimize clean++# Then $PATCHES_DIR_AFTER_OPTIMIZE should looks like:+# 0000000132-23ee2a79b097dd4a134c50d196c6f7ecd5c85655ad44d34f6c1732f4b491ca35+# pending+# pending.tentative+PATCHES_DIR_AFTER_OPTIMIZE=$(ls -1 $PATCHES_DIR)++# If issue1987 is solved $REMOVED_PATCH should looks like:+# 0000000120-8462241e685a983cff956f05a6a32f3ff6b27a485e67d19b84b2b5fef31fab84,+# i.e., must be equal to $PATCH.+# Otherwise $REMOVED_PATCH == '', and then $REMOVED_PATCH != $PATCH.+REMOVED_PATCH=`comm -13 <(echo "$PATCHES_DIR_AFTER_OPTIMIZE") \+ <(echo "$PATCHES_DIR_AFTER_AMEND")`++[ "$PATCH" == "$REMOVED_PATCH" ]++cd ..++#####################################################+# Testing garbage collection on _darcs/inventories/ #+#####################################################++rm -rf R++darcs init --repo R+cd R++touch f+darcs add f+darcs record -am 'Add f.'++# $INV_DIR_AFTER_RECORD should looks like:+# 0000000192-3863012ed1377e2d80e0f97bccbad0260d9e186bc28080549563f22d8b968e33+INV_DIR_AFTER_RECORD=$(ls -1 $INV_DIR)++touch g+darcs add g+darcs record -am 'Add g.'++# $INV_DIR_AFTER_SND_RECORD should looks like:+# 0000000192-3863012ed1377e2d80e0f97bccbad0260d9e186bc28080549563f22d8b968e33+# 0000000384-e5683733407c4aae642604adf29d582a8fbbb6c50a96d6e8bba20058f7892b68+INV_DIR_AFTER_SND_RECORD=$(ls -1 $INV_DIR)++# $SND_PATCH should looks like:+# 0000000384-e5683733407c4aae642604adf29d582a8fbbb6c50a96d6e8bba20058f7892b68+SND_PATCH=`comm -13 <(echo "$INV_DIR_AFTER_RECORD") \+ <(echo "$INV_DIR_AFTER_SND_RECORD")`++# We don't need any of the files in $INV_DIR (since we have not done+# 'darcs tag', all the information is in _darcs/hashed_inventory),+# therefore 'darcs optimize' can delete all the files in $INV_DIR.+darcs optimize clean++# $INV_DIR_AFTER_OPTIMIZE should be equal to ''.+INV_DIR_AFTER_OPTIMIZE=$(ls -1 $INV_DIR)++[ "$INV_DIR_AFTER_OPTIMIZE" == "" ]++cd ..++#####################################################+# Testing garbage collection on _darcs/inventories/ #+# (this time using 'darcs tag')+#####################################################++rm -rf R++darcs init --repo R+cd R++touch f+darcs add f+darcs record -am 'Add f.'++# $INV_DIR_AFTER_RECORD should looks like:+# 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018+INV_DIR_AFTER_RECORD=$(ls -1 $INV_DIR)++darcs tag -m 'Add f.'++# $INV_DIR_AFTER_FST_TAG should looks like:+# 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018+# 0000000297-eed3c68ee2d145f499f00d8367ec09a2cebdf79de7341e873e7bc68088236fc6+INV_DIR_AFTER_TAG=$(ls -1 $INV_DIR)++# $SND_PATCH should looks like:+# 0000000297-eed3c68ee2d145f499f00d8367ec09a2cebdf79de7341e873e7bc68088236fc6+SND_PATCH=`comm -13 <(echo "$INV_DIR_AFTER_RECORD") \+ <(echo "$INV_DIR_AFTER_TAG")`++touch g+darcs add g+darcs record -am 'Add g.'++# $INV_DIR_AFTER_SND_RECORD should looks like:+# 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018+# 0000000297-eed3c68ee2d145f499f00d8367ec09a2cebdf79de7341e873e7bc68088236fc6+# 0000000489-6892c56cd7ec4381ad7d8bbcf10ed5a3366d3ac40f2a569d9bf7d2e5633fe32a+# The last file contains the data of the second so that the second file is+# useless.+# The latest file points to the first, so that 'optimize' should not delete+# the first file.+# The content of the last file is in _darcs/hashed_inventory+# so it can be deleted.+INV_DIR_AFTER_SND_RECORD=$(ls -1 $INV_DIR)++darcs optimize clean++# $INV_DIR_AFTER_OPTIMIZE should looks like:+# 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018+INV_DIR_AFTER_OPTIMIZE=$(ls -1 $INV_DIR)++[ "$INV_DIR_AFTER_OPTIMIZE" == "$INV_DIR_AFTER_RECORD" ]++cd ..++#########################################################+# Testing garbage collection on _darcs/pristine.hashed/ #+# (this should work even before issue1987) #+#########################################################++rm -rf R+darcs init --repo R+cd R++# $PRISTINE_DIR_AFTER_INIT should looks like:+# e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855+PRISTINE_DIR_AFTER_INIT=$(ls -1 $PRISTINE_DIR)++echo "Hello darcs" > f+darcs add f+darcs record -am 'Hello darcs.'++# $PRISTINE_DIR_AFTER_RECORD should looks like:+# 34e7e68e2ba4d79facc7ddffdab700608d4abceebbc8ff98d77479b8a5127820+# a8c49fa16eaed0a0a601834c98132a32c24f078e58fcba4d9e036fadb92ca91d+# e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855+# The third file represents the empty working copy and is no longer+# needed. Therefore 'optimize' must remove it.+PRISTINE_DIR_AFTER_RECORD=$(ls -1 $PRISTINE_DIR)++EXPECTED_PRISTINE_AFTER_OPTIMIZE=`comm -13 <(echo "$PRISTINE_DIR_AFTER_INIT") \+ <(echo "$PRISTINE_DIR_AFTER_RECORD")`+darcs optimize clean++PRISTINE_DIR_AFTER_OPTIMIZE=$(ls -1 $PRISTINE_DIR)++[ "$PRISTINE_DIR_AFTER_OPTIMIZE" == "$EXPECTED_PRISTINE_AFTER_OPTIMIZE" ]++cd ..+rm -rf R
tests/issue2012_send_output_no_address.sh view
@@ -24,9 +24,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev--. lib+. ./lib DARCS_EDITOR=echo export DARCS_EDITOR
tests/issue2013_send_to_context.sh view
@@ -23,9 +23,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev--. lib+. ./lib DARCS_EDITOR=echo export DARCS_EDITOR@@ -48,10 +46,10 @@ darcs record -alm add_foo_bar -A x # Test that --to works with send --context-darcs send --author=me -a --to=random@random --sendmail-command='grep "^To: random@random$" %<' --context context+darcs send --mail --author=me -a --to=random@random --sendmail-command='grep "^To: random@random$" %<' --context context # Test that a default preference will NOT be used when no --to value is specified echo "default@email" > ../temp2/_darcs/prefs/email-not darcs send --author=me -a --sendmail-command='grep "^To: default@email$" %<' --context context+not darcs send --mail --author=me -a --sendmail-command='grep "^To: default@email$" %<' --context context cd ..
tests/issue2052-default-unified-diff.sh view
@@ -23,7 +23,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev+. ./lib . lib # Load some portability helpers. rm -rf R
− tests/issue2066-record-file-not-exist.sh
@@ -1,13 +0,0 @@-set -ev--rm -rf temp-mkdir -p temp-cd temp--darcs init-touch a b-darcs add a-darcs record -a -m "record a" a-rm a-darcs add b-darcs record -a -m "record a" a
+ tests/issue2066_add_and_remove.sh view
@@ -0,0 +1,41 @@+#!/usr/bin/env bash+## Test for issue2066 - darcs record fails when deleted file and added file are specified on the command line+##+## Copyright (C) 2011 David Caldwell <david@porkrind.org>+##+## 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+rm -rf R+mkdir R++cd R+darcs init+echo a > a+darcs add a+darcs record --all -m "a"+rm -f a+echo b > b+darcs add b+darcs record --all -m "-a+b" a b+darcs changes -v | grep 'rmfile ./a' # the remove doesn't get recorded even though we told it to.++cd ..
+ tests/issue2125-always-warn-forced-replace.sh view
@@ -0,0 +1,75 @@+#!/usr/bin/env bash+## Test for issue2125 - darcs should not warn about forced replaces, if nothing+## needed to be forced.+##+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf R+darcs init --repo R++cd R++echo -e 'first line of file\nsecond line of file' > file+darcs rec -alm 'Add file'++# No occurences of 'entry' - shouldn't warn.+darcs replace line entry file | not grep surprised++# We have an occurrence of 'second' - should fail, but not change anything (no+# --force)+noForce=$(darcs replace first second file)+echo "$noForce" | grep 'Skipping file'+echo "$noForce" | not grep 'surprised'++# Make sure nothing changed...+whatsnew=$(darcs wh)+echo "$whatsnew" | grep 'replace \./file \[A-Za-z_0-9\] line entry'+[[ $(echo "$whatsnew" | wc -l) -eq 1 ]]++force=$(darcs replace --force first second file) +echo "$force" | grep 'surprised'+darcs wh++! read -r -d '' EXPECTED <<'EOF'+hunk ./file 2+-second line of file++first line of file+replace ./file [A-Za-z_0-9] first second+replace ./file [A-Za-z_0-9] line entry++EOF++echo "$EXPECTED" > expected_whatsnew.txt+darcs wh > actual_whatsnew.txt++# Ensure we have the right changes in working/pending.+diff expected_whatsnew.txt actual_whatsnew.txt++darcs rev -a++# Test that unrecorded changes require --force, too.+echo 'third line of file' >> file+workingChangeNoForce=$(darcs replace second third file)+echo "$workingChangeNoForce" | grep 'Skipping file'
tests/issue2136-changes_created_as_for_multiple_files.sh view
@@ -63,8 +63,8 @@ darcs rec -am 'Move d4 -> d5' # Ensure all original names are reported, both forwards, and reversed.-xmlChanges=$(darcs cha --xml tldir/f2 f5 tldir/d2 d5 f6)-xmlChangesRev=$(darcs cha --reverse --xml tldir/f2 f5 tldir/d2 d5 f6)+xmlChanges=$(darcs changes --xml tldir/f2 f5 tldir/d2 d5 f6)+xmlChangesRev=$(darcs changes --reverse --xml tldir/f2 f5 tldir/d2 d5 f6) # xmlChanges needs to be quoted everywhere, otherwise this hack to retrieve the # 2 following lines won't work.
+ tests/issue2153-allow-skipping-backwards-through-depended_upon-patches.sh view
@@ -0,0 +1,35 @@+#!/usr/bin/env bash++# Testing amend++. lib++rm -rf temp1+# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++# do some work here+cd temp1++touch foo+darcs add foo+echo -e 'line1\nline2\nline3' > foo+darcs record -a -m add_lines+echo -e 'line1ch\nline2\nline3' > foo+darcs record -a -m changedline1+echo -e 'line1ch\nline2changed\nline3' > foo+darcs record -a -m changed_line2+echo -e 'line1ch\nline2changedagain\nline3' > foo+darcs record -a -m changed_line2again++echo successmarker >> foo+echo jkya | darcs amend+echo FOOOOOO+darcs changes -v --patch "changed_line2again"|grep successmarker++cd ..++rm -rf temp1 temp2
+ tests/issue2179-diff-with-dir-path.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash+## Test for issue2179 - darcs diff on a dir should diff everything in and below+## that directory.+## needed to be forced.+##+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf R+darcs init --repo R++cd R+mkdir dir+touch dir/file+darcs rec -alm 'Add dir/file'++echo testing > dir/file++darcs wh | grep testing++darcs diff | grep testing++darcs diff dir/file | grep testing++darcs diff dir | grep testing
+ tests/issue2193-apply-runs-test-twice.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue2193 - "darcs apply --test runs the test twice.+##+## Copyright (C) 2012 Ilya Perminov+##+## 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+darcs get R S++# Create a patch bundle+cd R+echo 'Example content.' >file1+darcs add file1+darcs rec -a --name patch1+darcs send --dont-edit-description --output=./patch1 -a ../S++# Setup a test that prints a unique string, apply the patch set, check that the unique +# string occurs in the output once.+cd ../S +darcs setpref test 'echo 2a427e65f322be754dce67c829e5f8a3'+darcs apply --test ../R/patch1 > log 2>&1+[ `fgrep -c 2a427e65f322be754dce67c829e5f8a3 log` -eq 1 ]
+ tests/issue2200-darcs-replace-no-paths.sh view
@@ -0,0 +1,44 @@+#!/usr/bin/env bash+## Test for issue2200 - darcs should warn if no paths are given to replace+##+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf R+darcs init --repo R++cd R++touch file++darcs rec -alm 'Add file'++# Missing tokens+not darcs replace+not darcs replace foo++# No files to replace in+not darcs replace foo bar &> output.txt++grep 'You need to supply a list of files to replace in!' output.txt
+ tests/issue2204-send-mail.sh view
@@ -0,0 +1,64 @@+#!/usr/bin/env bash+## Test for issue2204 - darcs send --mail vs --output+##+## Copyright (C) 2012 Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.+darcs init --repo R # Create our test repos.++# copied from issue2186+# Create a script that will be used instead of sendmail. It simply saves its+# input to file "message".+cat <<FAKE > dummy-sendmail.hs+import System.IO+main = hGetContents stdin >>= writeFile "message"+FAKE+ghc -o dummy-sendmail --make dummy-sendmail.hs++cd R+echo 'foo@example.com' > _darcs/prefs/email+cd ..++darcs get R S+cd S+echo 'send sendmail-command ../dummy-sendmail' > _darcs/prefs/defaults+echo 'Example content.' > f+darcs add f+darcs record -lam p++# no options (should generate a bundle)+darcs send -a+[ ! -e message ]+[ -e p.dpatch ]++# just --mail+darcs send -a --mail+[ -e message ]+rm message++# both mail and output+darcs send -a --mail -O+[ ! -e message ]+[ -e p.dpatch ]++cd ..
+ tests/issue2207-annotate-directory.sh view
@@ -0,0 +1,39 @@+#!/usr/bin/env bash+## Test for issue2207 - <SYNOPSIS: simple test for annotate+## on directories.>+##+## Copyright (C) 2012 BSRK Aditya+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++rm -rf R+darcs init --repo R++cd R++mkdir d+touch d/f++darcs record -lam 'p1'++darcs annotate d | grep 'p1'
+ tests/issue2209-look_for_replaces.sh view
@@ -0,0 +1,323 @@+#!/usr/bin/env bash+## Test for issue2209 - Automatically detect replace patch.+##+## Copyright (C) 2013 Jose Neder+##+## 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++rm -rf R+mkdir R+cd R+# simple full complete replace (record)+darcs init+echo "foo" > file+darcs record -al -m "add file"+echo "bar_longer" > file # replace by token of different length+echo yy | darcs record --look-for-replaces -m "replace foo bar_longer file"+darcs changes --last 1 -v 2>&1 | tail -n +4 > log+cat > log.expected <<EOF+ * replace foo bar_longer file+ replace ./file [A-Za-z_0-9] foo bar_longer+EOF+diff -u log log.expected+rm -rf *++# simple full complete replace (amend-record)+darcs init+echo "foo" > file+darcs record -al -m "add file"+echo "bar" > file+echo yyy | darcs amend-record --look-for-replaces+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^ {\| }$" > log+cat > log.expected <<EOF+ * add file+ addfile ./file+ hunk ./file 1+ +foo+ replace ./file [A-Za-z_0-9] foo bar+EOF+diff -u log log.expected+rm -rf *++# simple full complete replace (whatsnew)+darcs init+echo "foo" > file+darcs record -al -m "add file"+echo "bar" > file+darcs whatsnew --look-for-replaces 2>&1 > log+cat > log.expected <<EOF+replace ./file [A-Za-z_0-9] foo bar+EOF+diff -u log log.expected+rm -rf *++# partial replace (only some of the words/chunks replaced) (record)+darcs init+echo "foo foo" > file+darcs record -al -m "add file"+echo "bar foo" > file+echo yyy | darcs record --look-for-replaces -m "replace foo bar file"+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^ {\| }$" > log+cat > log.expected <<EOF+ * replace foo bar file+ replace ./file [A-Za-z_0-9] foo bar+ hunk ./file 1+ -bar bar+ +bar foo+EOF+diff -u log log.expected+rm -rf *++# partial replace (only some of the words/chunks replaced) (amend-record)+darcs init+echo "foo foo" > file+darcs record -al -m "add file"+echo "bar foo" > file+echo yyyy | darcs amend-record --look-for-replaces+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^ {\| }$" > log+cat > log.expected <<EOF+ * add file+ addfile ./file+ hunk ./file 1+ +foo foo+ replace ./file [A-Za-z_0-9] foo bar+ hunk ./file 1+ -bar bar+ +bar foo+EOF+diff -u log log.expected+rm -rf *++# partial replace (only some of the words/chunks replaced) (whatsnew)+darcs init+echo "foo foo" > file+darcs record -al -m "add file"+echo "bar foo" > file+darcs whatsnew --look-for-replaces > log+cat > log.expected <<EOF+replace ./file [A-Za-z_0-9] foo bar+hunk ./file 1+-bar bar++bar foo+EOF+diff -u log log.expected+rm -rf *++# forced replace (the word is in the file) (record)+darcs init+cat > file <<EOF+foo+foo+bar+EOF+darcs record -al -m "add file"+cat > file <<EOF+bar+bar+bar+EOF+echo yyy | darcs record --look-for-replaces -m "replace foo bar file"+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^ {\| }$" > log+cat > log.expected <<EOF+ * replace foo bar file+ hunk ./file 3+ -bar+ +foo+ replace ./file [A-Za-z_0-9] foo bar+EOF+diff -u log log.expected+rm -rf *++# forced replace (the word is in the file) (amend-record)+darcs init+cat > file <<EOF+foo+foo+bar+EOF+darcs record -al -m "add file" --ignore-times+cat > file <<EOF+foo+bar+bar+EOF+darcs record -a -m "change file" --ignore-times+cat > file <<EOF+bar+bar+bar+EOF+echo yyyy | darcs amend-record --look-for-replaces --ignore-times+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^ {\| }$" > log+cat > log.expected <<EOF+ * change file+ hunk ./file 3+ -bar+ +foo+ replace ./file [A-Za-z_0-9] foo bar+EOF+diff -u log log.expected+rm -rf *++# forced replace (the word is in the file) (whatsnew)+darcs init+cat > file <<EOF+foo+foo+bar+EOF+darcs record -al -m "add file"+cat > file <<EOF+bar+bar+bar+EOF+darcs whatsnew --look-for-replaces 2>&1 > log+cat > log.expected <<EOF+hunk ./file 3+-bar++foo+replace ./file [A-Za-z_0-9] foo bar+EOF+diff -u log log.expected+rm -rf *++# multiple replaces (record)+darcs init+cat > file <<EOF+foo+bar+ser+EOF+darcs record -al -m "add file"+cat > file <<EOF+ter+rur+kee+EOF+echo yyyy | darcs record --look-for-replaces -m "multiple replaces"+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^ {\| }$" > log+cat > log.expected <<EOF+ * multiple replaces+ replace ./file [A-Za-z_0-9] bar rur+ replace ./file [A-Za-z_0-9] foo ter+ replace ./file [A-Za-z_0-9] ser kee+EOF+diff -u log log.expected+rm -rf *++# multiple replaces (amend-record)+darcs init+cat > file <<EOF+foo+bar+ser+EOF+darcs record -al -m "add file"+cat > file <<EOF+ter+rur+kee+EOF+echo yyyyy | darcs amend-record --look-for-replaces+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^ {\| }$" > log+cat > log.expected <<EOF+ * add file+ addfile ./file+ hunk ./file 1+ +foo+ +bar+ +ser+ replace ./file [A-Za-z_0-9] bar rur+ replace ./file [A-Za-z_0-9] foo ter+ replace ./file [A-Za-z_0-9] ser kee+EOF+diff -u log log.expected+rm -rf *++# multiple replaces (whatsnew)+darcs init+cat > file <<EOF+foo+bar+ser+EOF+darcs record -al -m "add file"+cat > file <<EOF+ter+rur+kee+EOF+darcs whatsnew --look-for-replaces 2>&1 > log+cat > log.expected <<EOF+replace ./file [A-Za-z_0-9] bar rur+replace ./file [A-Za-z_0-9] foo ter+replace ./file [A-Za-z_0-9] ser kee+EOF+diff -u log log.expected+rm -rf *++# conflicting replaces (whatsnew)+darcs init+cat > file <<EOF+foo+foo+EOF+darcs record -al -m "add file"+cat > file <<EOF+bar+ber+EOF+darcs whatsnew --look-for-replaces 2>&1 > log+cat > log.expected <<EOF+hunk ./file 1+-foo+-foo++bar++ber+EOF+diff -u log log.expected+rm -rf *++# same line replaces+darcs init+cat > file <<EOF+foo foo2 foo3+fee fee2 fee3+EOF+darcs record -al -m "add file"+cat > file <<EOF+bar bar2 bar3+bor bor2 bor3+EOF+darcs whatsnew --look-for-replaces 2>&1 > log+cat > log.expected <<EOF+replace ./file [A-Za-z_0-9] fee bor+replace ./file [A-Za-z_0-9] fee2 bor2+replace ./file [A-Za-z_0-9] fee3 bor3+replace ./file [A-Za-z_0-9] foo bar+replace ./file [A-Za-z_0-9] foo2 bar2+replace ./file [A-Za-z_0-9] foo3 bar3+EOF+diff -u log log.expected+rm -rf *
+ tests/issue2212-add-changes-pending-for-other-files.sh view
@@ -0,0 +1,53 @@+#!/usr/bin/env bash+## Test for issue2212 - darcs updates pending when add is called for a distinct+## file.+##+## Copyright (C) 2012 Owen Stephens+##+## 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++rm -rf R+darcs init --repo R++cd R++touch a b++darcs add a+darcs rec -am 'Add a'++rm a+darcs add b++# Darcs shouldn't have updated anything to do with (despite the fact that it+# has indeed been deleted.)+cat _darcs/patches/pending | not grep 'rmfile \./a'++# The same should be true for other commands that have to recompute pending+# from the working directory+darcs revert -a+touch b+darcs add b+rm a+darcs revert b -a+cat _darcs/patches/pending | not grep 'rmfile \./a'
+ tests/issue2225-obliterate-not-in.sh view
@@ -0,0 +1,58 @@+#!/usr/bin/env bash+##+## Obliterate patches not in other repo(s)+##+## Copyright (C) 2014 Owen Stephens+##+## 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++for i in {1..4}+do+ rm -rf R$i+ darcs init --repo R$i+done++recFile() {+touch $1+darcs rec -lam "add $1"+}++cd R1++recFile file1+recFile file2+recFile file3+recFile file4+recFile file5++# Should fail, we haven't specified a repo, and we don't have a default repo+not darcs ob -a --not-in-remote++darcs push -a -p file2 --set-default ../R2+darcs push -a -p file3 ../R3+darcs push -a -p file4 ../R4++darcs ob -a --not-in-remote=../R3 --not-in-remote=../R4 --not-in-remote++# Confirm that the only patches that were deleted were file1 and file5+[[ -f file2 && -f file3 && -f file4 && ! -f file1 && ! -f file5 ]]
+ tests/issue2227-rebase-amend-record.sh view
@@ -0,0 +1,49 @@+#!/bin/sh -e+##+## amend-record needs to pull the rebase patch to the head+## of the repo so that 'withManualRebaseUpdate' can work+##+## Copyright (C) 2013 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++rm -rf R++mkdir R+cd R++darcs init++touch file1+darcs rec -lam "add file1"++touch file2+darcs rec -lam "add file2"++echo ydy | darcs rebase suspend++touch file3+darcs rec -lam "add file3"++echo 'contents' > file1+echo nyyy | darcs amend
+ tests/issue2230-invalid-context-too-late.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash+## Test for issue2230 - darcs get --context checks the validity of the context+## file too late.+##+## Copyright (C) 2012 Owen Stephens+##+## 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++touch fake_context.txt++not darcs get --context fake_context.txt R S++# The get should fail, so we shouldn't have an S repo+[[ ! -e S ]]
+ tests/issue2244-dup-tag-warning.sh view
@@ -0,0 +1,13 @@+#!/usr/bin/env bash+. lib # Load some portability helpers.++t=`(dd if=/dev/urandom count=1 | tr -cd "a-zA-Z0-9" | head -c 10)` # Create de tag name.+darcs init --repo R # Create our test repos.++# Test about issue 2244: darcs tag should warn about duplicate tags.++cd R+darcs tag "$t"+darcs show tag | grep "$t"+darcs tag "$t" | grep 'WARNING'+cd ..
+ tests/issue2248-rebase-zero-suspended.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash+## Test for issue2248 - can get into state of "0 suspended patches"+##+## Copyright (C) 2012 Owen Stephens, 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++rm -rf R+darcs init --repo R++cd R+touch foo+darcs rec -lam "add foo"+echo foo > foo+darcs rec -am "change foo"+echo bar > foo+echo yd | not darcs rebase suspend++darcs whatsnew | not grep suspended++echo d | darcs rebase suspend+darcs whatsnew | not grep suspended++echo q | darcs rebase suspend+darcs whatsnew | not grep suspended
+ tests/issue2253-make-patch-index-oldfashioned.sh view
@@ -0,0 +1,32 @@+#!/usr/bin/env bash+## Test for issue2253 - darcs changes FILE tries (and fails) to build a patch index+## on an oldfashioned repo+##+## Copyright (C) 2012 Owen Stephens+##+## 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++gunzip -c $TESTDATA/oldfashioned.tgz | tar xf -++cd oldfashioned+darcs changes x
+ tests/issue2270-changes-interactive-only-to-files.sh view
@@ -0,0 +1,139 @@+#!/usr/bin/env bash+## Test for issue2270 - +## darcs changes should only show changes to relevant files+##+## Copyright (C) 2013 Sebastian Fischer+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++rm -rf R+mkdir R+cd R+darcs init++echo irrelevant > irrelevant+darcs add irrelevant+darcs record -am "recorded irrelevant file"++echo relevant-initial > relevant+echo other > other+darcs add relevant other+darcs record -am "recorded relevant and other file"+++# --interactive --only-to-files should only show relevant+(echo y | darcs changes -i --only-to-files relevant > out) || true+cat out+not grep "addfile ./irrelevant" out+grep "addfile ./relevant" out+not grep "addfile ./other" out++# --verbose --only-to-files should only show relevant+(darcs changes -v --only-to-files relevant > out) || true+cat out+not grep "addfile ./irrelevant" out+grep "addfile ./relevant" out+not grep "addfile ./other" out++# --interactive should only show relevant and other+(echo yy | darcs changes -i relevant > out) || true+cat out+not grep "addfile ./irrelevant" out+grep "addfile ./relevant" out+grep "addfile ./other" out++# --verbose should only show relevant and other+(darcs changes -v relevant > out) || true+cat out+not grep "addfile ./irrelevant" out+grep "addfile ./relevant" out+grep "addfile ./other" out++# --interactive --only-to-files should show old name of moved+darcs move relevant renamed-relevant+darcs record -am "renamed relevant file"++(echo yy | darcs changes -i --only-to-files renamed-relevant > out) || true+cat out+grep "addfile ./relevant" out+not grep "addfile ./irrelevant" out+not grep "addfile ./other" out++# --verbose --only-to-files should show old name of moved+(darcs changes -v --only-to-files renamed-relevant > out) || true+cat out+grep "addfile ./relevant" out+not grep "addfile ./irrelevant" out+not grep "addfile ./other" out++# --interactive should show old name of moved+(echo yy | darcs changes -i renamed-relevant > out) || true+cat out+grep "addfile ./relevant" out+not grep "addfile ./irrelevant" out+grep "addfile ./other" out++# --verbose should show old name of moved+(darcs changes -v renamed-relevant > out) || true+cat out+grep "addfile ./relevant" out+not grep "addfile ./irrelevant" out+grep "addfile ./other" out++# adding a new file called 'relevant' :+# changes should now relate to that file and not to the original one+echo relevant-new > relevant+darcs add relevant+echo other-new > other+darcs record -am "recorded new add of relevant"++(echo yy | darcs changes -i --only-to-files relevant > out) || true+cat out+grep "addfile ./relevant" out+grep 'relevant-new' out+not grep 'other-new' out+not grep 'relevant-initial' out++(echo yy | darcs changes -v --only-to-files relevant > out) || true+cat out+grep "addfile ./relevant" out+grep 'relevant-new' out+not grep 'other-new' out+not grep 'relevant-initial' out++(echo yy | darcs changes -i relevant > out) || true+cat out+grep "addfile ./relevant" out+grep 'relevant-new' out+grep 'other-new' out+not grep 'relevant-initial' out++(echo yy | darcs changes -v relevant > out) || true+cat out+grep "addfile ./relevant" out+grep 'relevant-new' out+grep 'other-new' out+not grep 'relevant-initial' out++cd ..+rm -rf R
+ tests/issue2271-disable-patch-index.sh view
@@ -0,0 +1,39 @@+#!/usr/bin/env bash+## Test for issue2271 - --disable-patch-index should really work+##+## Copyright (C) 2013 Mark Stosberg+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++darcs init --repo R # Create our test repos.+cd R+touch t.txt+darcs add t.txt+darcs record -am 'initial record' t.txt+darcs optimize enable-patch-index++chmod -w _darcs/patch_index++not darcs optimize disable-patch-index 2>&1 | grep 'Could not delete patch index'++cd ../
tests/issue2286-metadata-encoding.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-## Test for issue2286 - darcs cha fails when reading non-UTF8 encoded+## Test for issue2286 - darcs changes fails when reading non-UTF8 encoded ## metadata ## ## Copyright (C) 2012 Ganesh Sittampalam
+ tests/issue2287_obliterate_overwrite.sh view
@@ -0,0 +1,59 @@+#!/usr/bin/env bash+## Test for issue2287 - Obliterate overwrites the existing file +## when the parameter -O is used.+##+## Copyright (C) YEAR AUTHOR+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.+darcs init --repo R # Create our test repos.++cd R+echo 'Example content 1.' > f+darcs record -lam 'Add f.'+echo 'Example content for obliterate.' >> f+darcs record -am 'content obliterate'++# Create 'existing useful dpatch'+p='content-obliterate.dpatch'+p1='content-obliterate_0.dpatch'+touch $p++# This command should finish with error, since file already exists.+not darcs obliterate -a -p 'content obliterate' -o $p++if [ ! -z "$(cat $p)" ]; then+ exit 2+fi++# This command create autogenerate non-conflict file+darcs obliterate -a -p 'content obliterate' -O++# Assert file was not overwritten+if [ ! -z "$(cat $p)" ]; then+ exit 2+fi++# Assert new file was created+if [ ! -f $p1 ]; then+ exit 2+fi
+ tests/issue2311_posthook_for_get_should_run_in_created_repo.sh view
@@ -0,0 +1,48 @@+#!/usr/bin/env bash+## Test for issue2311 - +## posthook for 'get' should run in created repo+##+## Copyright (C) 2013 Sebastian Fischer+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++rm -rf repos+mkdir repos+cd repos+mkdir origin+cd origin+darcs init+cd ..++# The output of the posthook `pwd` should include "branch"+# if "branch" is passed as repo name+darcs get origin branch --posthook=pwd > out+head -n 1 out | grep branch++# The output of the posthook `pwd` should include "origin_0"+# if no name for the created repo is passed+darcs get origin --posthook=pwd > out+head -n 1 out | grep origin_0++cd ..+rm -rf repos
+ tests/issue2312_posthooks_for_record_and_amend-record_should_receive_DARCS_PATCHES.sh view
@@ -0,0 +1,94 @@+#!/usr/bin/env bash+## Test for issue2312 - +## posthooks for 'record' and 'amend-record' should receive DARCS_PATCHES+##+## Copyright (C) 2013 Sebastian Fischer+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.++# passing environment variables to posthooks isn't supported at+# all in Windows+abort_windows++# even though the test doesn't work on Windows at the moment,+# might as well future proof it by using a Haskell program instead+# of a script for the post hook.++cat <<FAKE > echo_darcs_patches.hs # create a posthoook that echos $DARCS_PATCHES+import System.Environment+main = do+ [outFile] <- getArgs+ darcsPatches <- getEnv "DARCS_PATCHES"+ writeFile outFile (darcsPatches ++ "\n")+FAKE+ghc --make -o echo_darcs_patches echo_darcs_patches.hs+ECHO_DARCS_PATCHES=`pwd`/echo_darcs_patches++rm -rf R+mkdir R+cd R+darcs init++touch some.file+darcs add some.file++# posthook for darcs record should receive DARCS_PATCHES with correct change+darcs record -am msg1 --posthook="$ECHO_DARCS_PATCHES out"+cat out+grep msg1 out+grep "A ./some.file" out++# posthook for amend-record should receive DARCS_PATCHES with correct change+echo contents > some.file+echo y | darcs amend-record -a --posthook="$ECHO_DARCS_PATCHES out"+cat out+grep msg1 out+grep "A ./some.file" out++# newly added file should appear after amend+echo more contents >> some.file+touch new.file+darcs record -am msg2 --posthook="$ECHO_DARCS_PATCHES out"+cat out+grep msg2 out+grep "M ./some.file" out+not grep "A ./new.file" out+darcs add new.file+echo y | darcs amend-record -a --posthook="$ECHO_DARCS_PATCHES out"+cat out+not grep msg1 out+grep msg2 out+grep "M ./some.file" out+grep "A ./new.file" out++# no change should appear if it is not recorded+echo > out # clear out file, in case posthook is not called+echo contents >> new.file+echo ny | darcs record -m msg3 --posthook="$ECHO_DARCS_PATCHES out"+not grep msg1 out+not grep msg2 out+not grep msg3 out+not grep "M ./new.file" out++cd ..+rm -rf R
+ tests/issue2313-trailing-newlines-stack-overflow.sh view
@@ -0,0 +1,17 @@+#!/usr/bin/env bash+. lib++rm -rf temp && mkdir temp++cd temp+darcs init+echo "one line" > test_file.txt+for i in {1..18}+ do cat test_file.txt test_file.txt > test_file2.txt && mv -f test_file2.txt test_file.txt+done+echo -n "last line without newline" >> test_file.txt++darcs add test_file.txt+darcs wh -l | grep "A ./test_file.txt"++cd .. && rm -rf temp
+ tests/issue2333.sh view
@@ -0,0 +1,16 @@+#!/usr/bin/env bash+## Test for issue2333 - <SYNOPSIS: Error message when pushing and darcs not in path.>++. lib # Load some portability helpers.++require_ghc 706++darcs init --repo R # Create our test repos.+darcs init --repo S++cd R+echo 'Example content.' > f+darcs record -lam 'Add f.'+thedarcs=$(type -P darcs)+PATH='' $thedarcs push ../S -a # Try to push patches between repos.+cd ..
+ tests/issue2343.sh view
@@ -0,0 +1,65 @@+#!/usr/bin/env bash+## Test for issue2343 - 'darcs amend-record does not record my change'+##+## Copyright (C) 2013 José Neder+##+## 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++rm -rf temp1+mkdir temp1+cd temp1+darcs init+cat > file << FOO+{+ foo(foovar);++}++FOO+# The issue happens when the last line not common was a "boring" line. The diff+# algorithm was wrongly checking one line above and therefore it wasn't working+# right.+darcs record -m 'add' --all --look-for-adds+cat > file << FOO+{+ foo(foovar2);+}++FOO+# Here the last line in common is "}". The empty line between "foo(foovar;)""+# and "}" is checked and since it is a "boring" line the last line number is+# incremented, but the line "foo(foovar2);" isn't so the last line number in+# the "newfile" is not incremented and so it makes a bad diff later.+# is important to make a different line from the top+# "foo(foobar);" -> "foo(foovar2);" because if not it will only be an deleted+# line and the algorithm will skip the check of boring lines.+darcs wh >log 2>&1+cat > log.expected <<EOF+hunk ./file 2+- foo(foovar);+-++ foo(foovar2);+EOF+diff -u log log.expected+cd ..+rm -rf temp1
+ tests/issue2365-whatsnew-fails-get-no-working-dir.sh view
@@ -0,0 +1,40 @@+#!/usr/bin/env bash+## Test for issue2365 - whatsnew fails in repos made with get --no-working-dir+##+## Copyright (C) 2014 Guillaume Hoffmann+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.+darcs init --repo R # Create our test repos.++cd R+touch file+darcs rec -lam addfile++cd ..++darcs get R S --no-working-dir++cd S+not darcs whatsnew | grep "No changes"++cd ..
+ tests/issue2382-mv-dir-to-file-confuses-darcs.sh view
@@ -0,0 +1,179 @@+#!/usr/bin/env bash+## Test for issue2382 - we can confuse darcs by moving a directory to where a+## file previously was.+##+## Copyright (C) 2014 Owen Stephens+##+## 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.++function getRecordedChanges () {+darcs rec -am 1+# Ignore patch details and unindent - we should have the same contents as wh+darcs changes --last 1 -v | tail -n+5 | sed -e 's/^\s\+//' > $1+darcs unrecord --last 1 -a+}++function rmOutputFiles () {+ rm recoutput* expected* whoutput*+}++. lib+darcs init --repo R+cd R++# foo is recorded as a file+echo foo > foo+darcs rec -alm 'Add foo'++rm foo++darcs wh++# foo is now a dir in working, with a file within+mkdir foo+touch foo/bar++darcs wh > whoutput1+cat << EOF > expected1+hunk ./foo 1+-foo+rmfile ./foo+EOF++diff whoutput1 expected1++# Ensure recording everything isn't any different to asking whatsnew+getRecordedChanges recoutput1+diff recoutput1 expected1+rmOutputFiles++# To avoid the output file appearing in the output of wh -l+whl=$(darcs wh -l)+echo "$whl" > whoutput2+cat << EOF > expected2+R ./foo+a ./foo/+a ./foo/bar+EOF++diff whoutput2 expected2++darcs add foo++darcs wh > whoutput3+cat << EOF > expected3+hunk ./foo 1+-foo+rmfile ./foo+adddir ./foo+EOF++diff whoutput3 expected3+getRecordedChanges recoutput3+diff recoutput3 expected3+rmOutputFiles++darcs add foo/bar++darcs wh > whoutput4+cat << EOF > expected4+hunk ./foo 1+-foo+rmfile ./foo+adddir ./foo+addfile ./foo/bar+EOF++diff whoutput4 expected4+getRecordedChanges recoutput4+diff recoutput4 expected4++# Make sure we can remove the directory, without modifying working+darcs remove foo/bar+darcs remove foo++darcs add -r foo+darcs wh > whoutput4a+getRecordedChanges recoutput4a++diff whoutput4a expected4+diff recoutput4a expected4+rmOutputFiles++# Make sure foo is now recorded as a directory+darcs rec -alm 'Make foo a dir'++# Evil. Poor darcs, having to work all this out. We've made foo back into a+# file in working+rm -r foo+touch foo++darcs wh > whoutput5+cat << EOF > expected5+rmfile ./foo/bar+rmdir ./foo+EOF++diff whoutput5 expected5+getRecordedChanges recoutput5+diff recoutput5 expected5+rmOutputFiles++darcs rev -a++mkdir bar+darcs rec -alm 'Add bar dir'+rmdir bar++touch bar++darcs wh > whoutput6+cat << EOF > expected6+rmdir ./bar+EOF++diff whoutput6 expected6+getRecordedChanges recoutput6+diff recoutput6 expected6+rmOutputFiles++whl=$(darcs wh -l)+echo "$whl" > whoutput7++cat << EOF > expected7+R ./bar/+a ./bar+EOF++diff whoutput7 expected7++darcs add bar++darcs wh > whoutput8+cat << EOF > expected8+rmdir ./bar+addfile ./bar+EOF++diff whoutput8 expected8+getRecordedChanges recoutput8+diff recoutput8 expected8+rmOutputFiles
+ tests/issue2388-optimize-fails-no-changes.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash+## Test for issue2388 - optimize fails if no patches have been recorded+##+## Copyright (C) 2014 Owen Stephens+##+## 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++darcs optimize clean
+ tests/issue2432-pull-reorder-commute.sh view
@@ -0,0 +1,47 @@+#!/usr/bin/env bash+## Test for issue2432 - pull --reorder fails to commute patches+##+## Copyright (C) 2015 G. Hoffmann+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.+darcs init --repo R # Create our test repos.++cd R+echo X > x+darcs record -lam 'Add x with one line'++darcs clone . ../S++sed -i "1iNEW FIRST LINE" x+darcs record -am 'insert line at beginning'++cd ../S++echo "NEW LAST LINE" >> x+darcs record -am 'insert line at the end'++darcs log -p "insert line at the end" --last 1 -v |grep "hunk ./x 2"++# darcs pull --all+darcs pull --all --reorder+darcs check
tests/issue244_changes.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # Issue244 # darcs changes should be able to pull up the history for a file
tests/issue27.sh view
@@ -1,6 +1,6 @@ #!/bin/sh -set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1 temp2
tests/issue279_get_extra.sh view
@@ -15,7 +15,7 @@ cd .. for r in a b c d; do- darcs put --repodir temp1 temp_$r+ darcs get temp1 temp_$r cd temp_$r; echo $r > f darcs record -am "patch:$r";
tests/issue381.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # for issue381: "darcs send -o message --edit-description doesn't work"
tests/issue436.sh view
@@ -1,5 +1,8 @@ #!/usr/bin/env bash-set -ev++#pragma repo-format darcs-2++. ./lib rm -rf temp1 temp2 mkdir temp1
tests/issue458.sh view
@@ -1,7 +1,7 @@ #!/usr/bin/env bash ### http://bugs.darcs.net/issue458 ### darcs get --set-scripts-executable ignores umask-set -ev+. ./lib ## Windows doesn't support proper permissions.
+ tests/issue494-pending-sort.sh view
@@ -0,0 +1,41 @@+#!/usr/bin/env bash+## Test for issue494: pending patch when files are renamed+##+## Copyright (C) 2007 Eric Kow+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++mkdir R+cd R+darcs init+echo abc > b+darcs add b+darcs record --all -m patch1 -A moi+darcs mv b a+echo def > a+darcs record --all -m patch2 -A moi+cd ..++mkdir S+cd S+darcs init+darcs pull --all ../R+darcs whatsnew | grep 'No changes'
tests/issue525_amend_duplicates.sh view
@@ -1,6 +1,6 @@ #!/bin/sh -set -ev+. ./lib ## I would use the builtin !, but that has the wrong semantics. not () { "$@" && exit 1 || :; }
tests/issue538.sh view
@@ -2,7 +2,7 @@ # A test for issue 538 - that an executable test script will run successfully if # it is recorded with --set-scripts-executable. -set -ev+. ./lib if echo $OS | grep -i windows; then echo I do not know how to run a test program under windows@@ -70,10 +70,10 @@ fi cd .. -# trackdown with --set-scripts-executable+# test --linear with --set-scripts-executable rm -rf temp1 make_repo_with_test-if darcs trackdown --set-scripts-executable | grep 'Success!' ; then+if darcs test --linear --set-scripts-executable | grep 'Success!' ; then echo "ok 5" else echo "not ok 5 tracking down with --set-scripts-executable failed (because test failed?)"@@ -81,10 +81,10 @@ fi cd .. -# trackdown without --set-scripts-executable+# test --linear without --set-scripts-executable rm -rf temp1 make_repo_with_test-if darcs trackdown --dont-set-scripts-executable | grep 'Noone passed the test!' ; then+if darcs test --linear --dont-set-scripts-executable | grep 'Noone passed the test!' ; then echo "ok 6" else echo "not ok 6 tracking down did not find failure even though --dont-set-scripts-executable was given"@@ -92,7 +92,7 @@ fi cd .. -# check trackdown with files that become scripts during trackdown+# check test --linear with files that become scripts during trackdown rm -rf temp1 mkdir temp1 ; cd temp1 ; darcs init echo "#!/bin/sh" > test.sh@@ -105,7 +105,7 @@ echo 'this is definitely not a valid script' > helper.sh darcs record -am 'invalid helper' -A test darcs setpref test './test.sh'-darcs trackdown --set-scripts-executable > trackdown-out+darcs test --linear --set-scripts-executable > trackdown-out if grep 'Test failed!' trackdown-out && grep 'Success!' trackdown-out ; then echo "ok 7" else
tests/issue588.sh view
@@ -2,7 +2,7 @@ # For issue588, "amend-record --look-for-adds end up with two "addfile" entries" -set -ev+. ./lib rm -rf temp1 darcs init --repodir temp1@@ -27,6 +27,6 @@ darcs changes --repodir temp1 --last 1 -v -darcs check --repodir temp1 --no-test+darcs check --repodir temp1 rm -rf temp1
tests/issue691.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp mkdir temp
tests/issue706.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # for issue706: "Filenames with spaces issue"
tests/issue709_pending_look-for-adds.sh view
@@ -1,7 +1,5 @@ #!/bin/sh-set -ve--. lib+. ./lib rm -rf temp1 mkdir temp1
+ tests/issue761-fail-early-bad-pull-match.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash++# This is a test for issue761, which pointed out that we didn't check the+# syntax of --match patterns until after having spent considerable time+# doing considerable work. So here we construct a very invalid repository,+# and check that darcs fails *before* it notices that it's pulling from a+# bad repository. Thus we verify that we aren't doing any work prior to+# checking the flags.++. ./lib++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+touch foo bar+darcs add foo bar+darcs record -a -m 'add two files'+darcs tag -m tag+rm foo bar+darcs record -a -m 'rm two files'+darcs tag -m tag2++rm -rf _darcs/inventories/*+rm -rf _darcs/patches/*++cd ..++mkdir temp2+cd temp2+darcs init+! darcs pull --match 'foobar' ../temp1 2> error+cat error++grep foobar error++rm -rf temp1 temp2+
tests/issue844_gzip_crc.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1 cd temp1@@ -13,7 +13,7 @@ cd temp2 darcs init darcs pull ../temp1 -a-darcs optimize --compress+darcs optimize compress for f in _darcs/patches/*-*; do gzip -t < "$f" done
− tests/issue864_replace_in_moved.sh
@@ -1,57 +0,0 @@-#!/usr/bin/env bash--# Issue 864--# darcs mv file1 file2-# edit file2-# darcs replace fails if new token includes some existing edits--# Regression in darcs2 - it works in darcs1 1.0.9--set -ev--rm -rf temp-mkdir temp-cd temp-darcs init-cat <<EOF > file1-aa-bb-cc-aa-bb-cc-EOF-darcs add file1-darcs record -a -m "0" --author X--cat <<EOF > file1-aaaa-bb-cc-aa-bb-cc-EOF--darcs replace aa aaaa file1 > out-cat out-grep 'Skipping file' out && exit 1--darcs mv file1 file2--cat <<EOF > file2-aaaa-beebee-cc-aa-bb-cc-EOF--darcs replace bb beebee file2 > out-cat out-grep 'Skipping file' out && exit 1--cd ..-rm -rf temp
tests/issue966_diff.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp mkdir temp; cd temp@@ -14,7 +14,7 @@ darcs diff --patch "bbb" | grep "bbb diff" darcs tag release-1-darcs optimize+darcs optimize clean echo "ccc diff" >> file darcs record -a -m "ccc"
tests/justrm.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
+ tests/latin9-input.sh view
@@ -0,0 +1,193 @@+#!/usr/bin/env bash+## Test for issue64 - Should store patch metadata in UTF-8+##+## Copyright (C) 2009 Reinier Lamers+##+## 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 ++# Helper function: do a darcs changes --xml and grep the result for the first+# argument. If it is not found, exit with status 1. Otherwise, continue. The+# second argument is a text that describes what we're grepping for.+# If a third argument is given, it is used as the value for a --last option for+# darcs changes.+grep_changes () {+ switch_to_utf8_locale+ if [ -z "$3" ]; then+ last=""+ else+ last="--last $3"+ fi++ darcs changes $last --xml > changes.xml+ if grep "$1" changes.xml ; then+ echo "$2 OK"+ else+ cat changes.xml+ echo "$2 not UTF-8-encoded!"+ exit 1+ fi+ switch_to_latin9_locale+}+++# This file is encoded in ISO-8859-15 aka latin9. It was crafted with a hex editor.+# Please leave it this way :-)+switch_to_latin9_locale++# This test clobbers the global darcs author+-f $HOME/.darcs/author && exit 200++rm -rf temp1+mkdir temp1+cd temp1++darcs init++# Test recording non-UTF-8-encoded non-latin1 ("funny") metadata from+# interactive input++echo 'Selbstverständlich überraschend' > something.txt+darcs add something.txt++echo 'l33tking¸0r@example.org' > interaction_script.txt+echo y >> interaction_script.txt+echo y >> interaction_script.txt+echo y >> interaction_script.txt+echo '¤uroh4xx0rz' >> interaction_script.txt+echo n >> interaction_script.txt++unset DARCSEMAIL+unset EMAIL+set+darcs record -i --skip-long-comment < interaction_script.txt+grep_changes 'l33tkingž0r@example.org' 'patch author from interactive prompt'+grep_changes 'â¬uroh4xx0rz' 'patch name from interactive prompt'++# Test recording funny metadata from command line ++echo 'Sogar überraschender' >> something.txt++darcs record -a -A 'Jérôme Leb½uf' -m 'that will be ¤ 15, sir'++grep_changes 'that will be ⬠15, sir' 'patch name from command line'+grep_changes 'Jérôme LebÅuf' 'patch author from command line'++# Test recording funny metadata from a log file++echo 'Am allerüberraschendsten' >> something.txt++echo 'darcs is soms wat naïef aangaande tekstcodering' > log.txt+echo 'en zulke naïviteit is tegenwoordig passé, aldus ´i¸ek' >> log.txt+darcs record -a -A 'Jérôme Leb½uf' --logfile=log.txt++grep_changes 'darcs is soms wat naïef aangaande tekstcodering' 'patch name from log file'+grep_changes 'en zulke naïviteit is tegenwoordig passé, aldus Žižek' 'patch log from log file'++# Test recording funny metadata from environment, +export EMAIL='Slavoj ´i¸ek <zizek@example.edu>'+rm $HOME/.darcs/author+echo 'La la la, the more lines the better!' >> something.txt+darcs record -a -m 'Patch names are overrated'++grep_changes 'Slavoj Žižek' 'author name from environment'++# Test recording funny metadata from prefs files+echo '´ed is dead' > _darcs/prefs/author+echo '483 bottles of beer on the wall' >> something.txt+darcs record -a -m 'Patch by ´ed'++grep_changes 'Žed is dead' 'author name from prefs file'++# Test amend-recording funny metadata+echo 'No, it is really 484' >> something.txt+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'++cat <<FAKE > 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 DARCS_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'+grep_changes 'Žed is even deader' 'author name taken from draft in amend'++# Test tag recording funny metadata+rm _darcs/prefs/author # Make tag be taken from EMAIL env variable+darcs tag -m '´ is my favorite letter'+grep_changes 'Slavoj Žižek' 'author name from environment with tag command' 1+grep_changes 'Ž is my favorite letter' 'Tag name from command line'++unset EMAIL+printf "´ors\ninitialcomment\n" | darcs tag --edit-long-comment+grep_changes Žors 'Author name from interactive prompt from tag command'+grep_changes 'All my â¬s are gone' 'Tag name from editor from tag command' 1++if grep ´ors $HOME/.darcs/author ; then+ echo 'Author name stored locale-encoded in prefs file after tag command, OK'+else+ echo 'No locale-encoded author in prefs file after tag command!'+ exit 1+fi+rm $HOME/.darcs/author++darcs tag -A Ad¸e -m 'La¸t call'+grep_changes Adže 'Author name from tag command line' 1+grep_changes 'Lažt call' 'Tag name from tag command line (take 2)' 1++cd ..++# test that UTF-8 metadata doesn't get mangled on get+rm -rf temp2+darcs get temp1 temp2+darcs changes --repodir temp1 --xml > temp1/changes.xml+darcs changes --repodir temp2 --xml > temp2/changes.xml+diff temp1/changes.xml temp2/changes.xml++# and that it doesn't get mangled on push+rm -rf temp2+mkdir temp2; darcs init --repodir temp2+darcs push --repodir temp1 -a temp2 --set-default+darcs changes --repodir temp1 --xml > temp1/changes.xml+darcs changes --repodir temp2 --xml > temp2/changes.xml+diff temp1/changes.xml temp2/changes.xml++# and that it doesn't get mangled on pull+rm -rf temp2+mkdir temp2; darcs init --repodir temp2+darcs pull --repodir temp2 -a temp1+darcs changes --repodir temp1 --xml > temp1/changes.xml+darcs changes --repodir temp2 --xml > temp2/changes.xml+diff temp1/changes.xml temp2/changes.xml++# and that it doesn't get mangled on send+rm -rf temp2+mkdir temp2; darcs init --repodir temp2+darcs send --repodir temp1 -a -o temp2/patch.dpatch+darcs apply --repodir temp2 -a temp2/patch.dpatch+darcs changes --repodir temp1 --xml > temp1/changes.xml+darcs changes --repodir temp2 --xml > temp2/changes.xml+diff temp1/changes.xml temp2/changes.xml
tests/lazy-optimize-reorder.sh view
@@ -5,7 +5,7 @@ rm -rf temp1 temp2 temp3 mkdir temp1 cd temp1-darcs init+darcs init --no-patch-index # this test only applies to hashed formats if cat _darcs/inventory; then exit 0; fi@@ -54,7 +54,7 @@ # Here's the point of this test: we should be able to optimize # --reorder without being able to read all the patches in the # repository.-darcs optimize --reorder+darcs optimize reorder # Just a double-check: we shouldn't be able to check in this case. not darcs check
tests/lib view
@@ -16,6 +16,10 @@ "./hspwd" } +which() {+ type -P "$@" | cut -d' ' -f 3-+}+ # switch locale to one supporting the latin-9 (ISO 8859-15) character set if possible, otherwise skip test no_latin9_locale_warning () {@@ -84,7 +88,16 @@ for f in "$@"; do grep $f $HOME/.darcs/defaults && exit 200 || true; done } +# check that the specified string appears precisely once in the output+grep-once() {+ grep -c "$@" | grep -w 1+}++require_ghc() {+ test $GHC_VERSION -ge $1 || exit 200+}+ grep -q darcs-2 .darcs/defaults && format=darcs-2-grep -q hashed .darcs/defaults && format=hashed+grep -q darcs-1 .darcs/defaults && format=darcs-1 set -vex -o pipefail
tests/look_for_add.sh view
@@ -11,7 +11,7 @@ [ -z _darcs/patches/pending ] || cmp _darcs/patches/pending ../empty_pending } -set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1 temp2
+ tests/look_for_moves.sh view
@@ -0,0 +1,179 @@+#!/usr/bin/env bash++. ./lib++rm -rf temp1 temp2+mkdir temp1 temp2+cd temp1++# simple add and move++darcs init+touch foo+darcs record -a -m add_file -A x --look-for-adds+mv foo foo2+darcs wh --summary --look-for-moves >log 2>&1+cat > log.expected <<EOF+ ./foo -> ./foo2+EOF+diff -u log log.expected+rm log log.expected+darcs record -a -m move_file -A x --look-for-moves+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# simple add and move dir++darcs init+mkdir foo+darcs record -a -m add_dir -A x --look-for-adds+mv foo foo2+darcs wh --summary --look-for-moves >log 2>&1+cat > log.expected <<EOF+ ./foo -> ./foo2+EOF+diff -u log log.expected+rm log log.expected+darcs record -a -m move_file -A x --look-for-moves+darcs wh --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# add, move and add same name++darcs init+touch foo+darcs record -a -m add_file -A x --look-for-adds+mv foo foo2+touch foo+darcs wh --summary --look-for-moves >log 2>&1+cat > log.expected <<EOF+ ./foo -> ./foo2+EOF+diff -u log log.expected+rm log log.expected+darcs wh --summary --look-for-moves --look-for-adds >log 2>&1+cat > log.expected <<EOF+ ./foo -> ./foo2+a ./foo+EOF+darcs record -a -m move_file_add_file -A x --look-for-moves --look-for-adds+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# amend-record++darcs init+touch foo+darcs record -a -m add_file -A x --look-for-adds+mv foo foo2+echo 'yyy' | darcs amend-record -p add_file -A x --look-for-moves+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+darcs annotate --patch add_file | grep "] addfile ./foo2"+rm -rf *++# add, move, add same name and amend-record++darcs init+touch foo+darcs record -a -m add_file -A x --look-for-adds+mv foo foo2+touch foo+echo 'yyyy' | darcs amend-record -p add_file -A x --look-for-moves --look-for-adds+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+darcs annotate --patch add_file >log 2>&1+grep "addfile ./foo" log+grep "addfile ./foo2" log+rm -rf *++# add, move, amend-record, move, amend-record++darcs init+touch foo+darcs record -a -m add_file -A x --look-for-adds+mv foo foo2+echo 'yyy' | darcs amend-record -p add_file -A x --look-for-moves+mv foo2 foo+echo 'yyy' | darcs amend-record -p add_file -A x --look-for-moves+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# move dir with content++darcs init+touch foo # created before dir to get a lower inode+mkdir dir+mv foo dir+darcs record -a -m add_files -A x --look-for-adds+mv dir dir2+darcs wh --summary --look-for-moves > log 2>&1+cat > log.expected <<EOF+ ./dir -> ./dir2+EOF+diff -u log log.expected+rm log log.expected+darcs record -a -m move_dir -A x --look-for-moves+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# name swapping -- unsupported thus ignored++darcs init+touch foo foo2+darcs record -lam add_file -A x+mv foo foo.tmp+mv foo2 foo+mv foo.tmp foo2+not darcs wh --look-for-moves+rm -rf *++# dir swapping -- ignored++darcs init+mkdir dir dir2+touch dir/foo dir2/foo2+darcs record -a -m add_files_and_dirs -A x --look-for-adds+mv dir dir.tmp+mv dir2 dir+mv dir.tmp dir2+not darcs wh --summary --look-for-moves+rm -rf *++# darcs mv before a plain mv++darcs init+touch foo+darcs record -a -m add_files_and_dirs -A x --look-for-adds+darcs mv foo foo2+mv foo2 foo3+darcs wh --summary --look-for-moves > log 2>&1+cat > log.expected <<EOF+ ./foo -> ./foo3+EOF+diff -u log log.expected+rm log log.expected+darcs record -a -m move_dirs -A x --look-for-moves+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# mv to a boring filename++darcs init+touch foo+darcs record -a -m add_files_and_dirs -A x --look-for-adds+mv foo foo~+darcs wh --summary --look-for-moves > log 2>&1+cat > log.expected <<EOF+R ./foo+EOF+diff -u log log.expected+rm -rf *++cd ..+rm -rf temp1
tests/match-date.sh view
@@ -28,12 +28,12 @@ create_entry () { echo $1 >> bar- echo "$1/tester/a///" | tr / \\012 | darcs record -m "" --pipe bar+ echo "$1/tester/a///" | tr / \\012 | darcs record -m "does not matter" --pipe bar } create_entry_now () { echo today >> bar- darcs record -m "" bar -a -A tester+ darcs record -m "does not matter" bar -a -A tester } # parse_date just checks for parsing, while match_date checks for an actual match.
tests/match.sh view
@@ -92,6 +92,16 @@ grep author1 log not grep author2 log grep author3 log++# an empty pattern should just match all patches+[[ $(darcs changes --match '' --count) -eq 3 ]]++# check the error message for an invalid matcher+not darcs changes --match invalid_matcher > log 2>&1+grep "unexpected 'i'" log+grep 'expecting valid expressions over' log+grep 'for more help, see `darcs help patterns`' log+ cd .. rm -rf temp1
tests/merge_three_patches.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf tempOld tempA tempB mkdir tempOld tempA
tests/mergeresolved.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf fooOld tempA tempB mkdir fooOld tempA tempB
tests/mv-test-suite.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/mv.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp mkdir temp
tests/mv_and_remove_tests.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp mkdir temp
tests/mv_then_add.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp mkdir temp
− tests/network/changes.sh
@@ -1,5 +0,0 @@-#!/usr/bin/env bash-set -ev--# Demonstrates issue385-darcs changes --repo=http://darcs.net GNUmakefile --last 300
+ tests/network/clone.sh view
@@ -0,0 +1,19 @@+#!/usr/bin/env bash+set -ev++rm -rf temp temp2 temp3++#"$DARCS" clone http://hub.darcs.net/kowey/tabular temp++darcs clone --lazy http://hub.darcs.net/kowey/tabular temp2++darcs clone --lazy --tag . http://hub.darcs.net/kowey/tabular temp3++cd temp2+darcs obliterate --from-tag . -a+darcs pull --tag . -a+cd ..++diff -u temp2/_darcs/hashed_inventory temp3/_darcs/hashed_inventory++rm -rf temp temp2 temp3
tests/network/external.sh view
@@ -20,7 +20,7 @@ echo 'echo hello > fakessh' > $touch_fakessh chmod u+x $touch_fakessh # first test the DARCS_SSH environment variable-not darcs get example.com:foo+not darcs clone example.com:foo grep hello fakessh rm -f fakessh @@ -29,9 +29,9 @@ cd temp1 darcs init cd ..-darcs get temp1 > log+darcs clone temp1 > log not grep fakessh log-not darcs get http://darcs.net/nonexistent+not darcs clone http://darcs.net/nonexistent not grep fakessh log cd .. rm -rf temp1
− tests/network/get.sh
@@ -1,19 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp temp2 temp3--#"$DARCS" get http://darcs.net temp--darcs get --lazy http://darcs.net temp2--darcs get --lazy --tag . http://darcs.net temp3--cd temp2-darcs obliterate --from-tag . -a-darcs pull --tag . -a-cd ..--diff -u temp2/_darcs/hashed_inventory temp3/_darcs/hashed_inventory--rm -rf temp temp2 temp3
tests/network/issue1503_prefer_local_caches_to_remote_one.sh view
@@ -26,8 +26,8 @@ . lib rm -rf S T-darcs get --lazy http://darcs.net/testing/repo1 S+darcs clone --lazy http://darcs.net/testing/repo1 S darcs tag --repo S -m 2-darcs get --lazy http://darcs.net/testing/repo1 T+darcs clone --lazy http://darcs.net/testing/repo1 T darcs pull --repo T S -a --debug --verbose 2>&1 | tee log not grep repo1 log
tests/network/issue2090-transfer-mode.sh view
@@ -40,11 +40,10 @@ touch f g darcs add f g darcs record f g -a --ignore-times -m 'add some files' -A moi-darcs put $REMOTE:$REMOTE_DIR/R+darcs clone . $REMOTE:$REMOTE_DIR/R cd .. -# Now try darcs get-darcs get $REMOTE:$REMOTE_DIR/R S --debug > log 2>&1+darcs clone $REMOTE:$REMOTE_DIR/R S --debug > log 2>&1 COUNT=$(grep -c 'darcs transfer-mode' log) # with issue2090, this was 6! test $COUNT -eq 1
+ tests/network/lazy-clone.sh view
@@ -0,0 +1,22 @@+#!/usr/bin/env bash+set -ev++rm -rf temp temp2 temp3++darcs clone --lazy http://hub.darcs.net/kowey/tabular temp++darcs clone --lazy temp temp2++rm -rf temp++cd temp2++test ! -f _darcs/patches/0000005705-178beaf653578703e32346b4d68c8ee2f84aeef548633b2dafe3a5974d763bf2++darcs annotate -p 'Initial version'++test -f _darcs/patches/0000005705-178beaf653578703e32346b4d68c8ee2f84aeef548633b2dafe3a5974d763bf2++cd ..++rm -rf temp temp2 temp3
− tests/network/lazy-get.sh
@@ -1,22 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp temp2 temp3--darcs get --lazy http://darcs.net/repos/franchise temp--darcs get --lazy temp temp2--rm -rf temp--cd temp2--test ! -f _darcs/patches/0000003700-fb09ec6a61b35ac7aa77e65388b1a0c182fddca9a908f1a08d0bc5653f2f2d2a--darcs annotate -p 'initial minimal version'--test -f _darcs/patches/0000003700-fb09ec6a61b35ac7aa77e65388b1a0c182fddca9a908f1a08d0bc5653f2f2d2a--cd ..--rm -rf temp temp2 temp3
+ tests/network/log.sh view
@@ -0,0 +1,5 @@+#!/usr/bin/env bash+set -ev++# Demonstrates issue385+darcs log --repo=http://darcs.net GNUmakefile --last 300
tests/network/ssh.sh view
@@ -17,15 +17,15 @@ echo 'first line' > a; darcs record a --ignore-times -am 'add first line to a'; \ cd ..; \ \-darcs get testrepo testrepo-pull; \+darcs clone testrepo testrepo-pull; \ cd testrepo-pull; \ echo moi > _darcs/prefs/author; \ touch b; darcs add b; darcs record b --ignore-times -am 'add file b'; \ echo 'other line' > b; darcs record b --ignore-times -am 'add other line to b'; \ cd ..; \ \-darcs get testrepo testrepo-push; \-darcs get testrepo testrepo-send; \+darcs clone testrepo testrepo-push; \+darcs clone testrepo testrepo-send; \ " # ================ Settings ===============@@ -34,8 +34,8 @@ echo ${DARCS_SCP} echo ${DARCS_SFTP} -# ================ Checking darcs get ==================-darcs get ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo ${DARCS_SSH_FLAGS}+# ================ Checking darcs clone ==================+darcs clone ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo ${DARCS_SSH_FLAGS} # check that the test repo made it over [ -d testrepo ] [ -d testrepo/_darcs ]@@ -51,7 +51,7 @@ fi # ================ Checking darcs pull =================-darcs get ${DARCS_SSH_FLAGS} testrepo testrepo-pull+darcs clone ${DARCS_SSH_FLAGS} testrepo testrepo-pull cd testrepo-pull echo yyy | darcs pull ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-pull # see if the changes got pulled over@@ -60,7 +60,7 @@ cd .. # ================ Checking darcs push and send ================="-darcs get ${DARCS_SSH_FLAGS} testrepo testrepo-push+darcs clone ${DARCS_SSH_FLAGS} testrepo testrepo-push cd testrepo-push echo moi > _darcs/prefs/author echo "second line" >> a; darcs record a --ignore-times -am "add second line to a"@@ -74,16 +74,16 @@ grep "add file c" mybundle.dpatch cd .. -# ================ Checking darcs put =================="+# ================ Checking darcs clone to ssh destination ==================" cd testrepo-darcs put ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-put-# check that the put was successful-${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/testrepo-put/_darcs ]"-${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-put/a ]"+darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-clone+# check that the clone was successful+${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/testrepo-clone/_darcs ]"+${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-clone/a ]" cd .. # ======== Checking push over ssh with a conflict ========="-${SSH} ${REMOTE} "echo apply no-allow-conflicts >> ${REMOTE_DIR}/testrepo-put/_darcs/prefs/defaults"+${SSH} ${REMOTE} "echo apply no-allow-conflicts >> ${REMOTE_DIR}/testrepo-clone/_darcs/prefs/defaults" cd testrepo echo moi > _darcs/prefs/author
tests/nfs-failure.sh view
@@ -1,6 +1,6 @@ #!/bin/sh -set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1
tests/nodeps.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # Test the --no-deps option with Send, Push, Pull, Obliterate and Unrecord. #
tests/nonewline.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1 temp2
tests/obliterate-formerly-pl.sh view
@@ -21,11 +21,11 @@ # extra confirmation for --all echo an | darcs obliterate -p add | grep -i "really obliterate" # --last=1-echo n | darcs obliterate --last 1 | grep -i adding+echo nyy | darcs obliterate --last 1 | grep -i adding # automatically getting dependencies date >> a.txt darcs record -a -m 'modifying a' a.txt-echo n | darcs obliterate -p 'adding a' > log+echo ny | darcs obliterate -p 'adding a' > log grep -i "modifying a" log grep -i "No patches selected" log cd ..
tests/obliterate.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf tempA mkdir tempA@@ -28,21 +28,21 @@ darcs replace baz world foo darcs record -a -m baz2world -darcs whatsnew | grep 'No changes'+not darcs whatsnew grep 'love the world' foo -echo y | darcs obliterate -p baz2world+echo yy | darcs obliterate -p baz2world -darcs whatsnew | grep 'No changes'+not darcs whatsnew grep 'love the baz' foo -echo y | darcs obliterate -p bar2baz+echo yy | darcs obliterate -p bar2baz grep 'love the bar' foo -echo y | darcs obliterate -p nolove+echo yy | darcs obliterate -p nolove grep 'love' foo && exit 1 || true
tests/oldfashioned_refusal.sh view
@@ -36,14 +36,12 @@ not darcs amend not darcs annotate not darcs apply-not darcs check not darcs diff not darcs dist not darcs mark not darcs move not darcs pull not darcs push-not darcs put not darcs record not darcs remove not darcs repair@@ -53,6 +51,6 @@ not darcs send not darcs setpref not darcs tag-not darcs trackdown+not darcs test not darcs unrecord not darcs unrevert
tests/optimize.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # tests for "darcs optimize" @@ -10,7 +10,7 @@ touch foo darcs add foo darcs record -a -m add_foo-darcs optimize --reorder-patches| grep -i "done optimizing"+darcs optimize reorder| grep -i "done" cd .. rm -rf temp1
tests/optimize_relink.sh view
@@ -3,7 +3,7 @@ # For issue600, testing optimize --relink -set -ev+. ./lib ## We don't support hard links on Windows. @@ -47,11 +47,11 @@ ## Now try relinking using darcs. rm -rf z-darcs optimize --verbose --relink --repodir x --sibling y+darcs optimize relink --verbose --repodir x --sibling y rm -rf x/_darcs/patches/pend* y/_darcs/patches/pend* if compare x/_darcs/patches y/_darcs/patches-then echo darcs --relink is working, hard links were done.-else echo darcs --relink is not working, it did not make any hard links.+then echo darcs optimize relink is working, hard links were done.+else echo darcs optimize relink is not working, it did not make any hard links. exit 2 fi
tests/output.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 temp3 mkdir temp2@@ -13,24 +13,24 @@ touch foo bar darcs add foo bar darcs record -a -m foobar -A author-darcs send -a --dont-edit-description -o ../temp3 ../temp2+darcs send --no-minimize -a --dont-edit-description -o ../temp3 ../temp2 test -f ../temp3 -darcs send -a --dont-edit-description -o ../temp2/patchfile ../temp2+darcs send --no-minimize -a --dont-edit-description -o ../temp2/patchfile ../temp2 test -f ../temp2/patchfile mkdir subdir-darcs send -a --dont-edit-description -o subdir/../../temp2/patchfile1 ../temp2+darcs send --no-minimize -a --dont-edit-description -o subdir/../../temp2/patchfile1 ../temp2 test -f ../temp2/patchfile1 cp ../temp3 correct cd subdir-darcs send -a --dont-edit-description -o ../patchfile ../../temp2+darcs send --no-minimize -a --dont-edit-description -o ../patchfile ../../temp2 diff -u ../patchfile ../correct rm ../patchfile-darcs send -a --set-default --dont-edit-description -o - ../../temp2 > ../patchfile+darcs send --no-minimize -a --set-default --dont-edit-description -o - ../../temp2 > ../patchfile grep -v Creating ../patchfile | diff -u ../correct - darcs apply --repodir=../../temp2 --dry-run ../patchfile > out
tests/overriding-defaults.sh view
@@ -9,21 +9,22 @@ darcs setpref test false darcs record --no-test -a -m 'add failing test' -# should pass with --no-test-darcs check --no-test- # should fail when test is run-not darcs check --test+not darcs test # should pass with --no-test in defaults-echo check --no-test > _darcs/prefs/defaults-darcs check-not darcs check --test+echo record --no-test > _darcs/prefs/defaults+touch a+darcs record -alm a+touch b+not darcs record --test -alm b # should fail with --test in defaults-echo check --test > _darcs/prefs/defaults-not darcs check-darcs check --no-test+echo record --test > _darcs/prefs/defaults+touch c+not darcs record -alm c+touch d+darcs record --no-test -alm d # check global defaults cp ~/.darcs/defaults defaults.backup@@ -31,28 +32,36 @@ rm _darcs/prefs/defaults # --no-test works in global defaults-echo check --no-test > ~/.darcs/defaults-darcs check-not darcs check --test+echo record --no-test > ~/.darcs/defaults+touch e+darcs record -alm e+touch f+not darcs record --test -alm f # --test works in global defaults-echo check --test > ~/.darcs/defaults-not darcs check-darcs check --no-test+echo record --test > ~/.darcs/defaults+touch g+not darcs record -alm g+touch h+darcs record --no-test -alm h # Verify that per-repository defaults override global defaults # --no-test in repository defaults overrides global --test-echo check --test > ~/.darcs/defaults-echo check --no-test > _darcs/prefs/defaults-darcs check-not darcs check --test+echo record --test > ~/.darcs/defaults+echo record --no-test > _darcs/prefs/defaults+touch i+darcs record -alm i+touch j+not darcs record --test -alm j # --test in repository defaults overrides global --no-test-echo check --no-test > ~/.darcs/defaults-echo check --test > _darcs/prefs/defaults-not darcs check-darcs check --no-test+echo record --no-test > ~/.darcs/defaults+echo record --test > _darcs/prefs/defaults+touch k+not darcs record -alm k+touch l+darcs record --no-test -alm l trap - EXIT cp defaults.backup ~/.darcs/defaults
+ tests/patch-index-annotate.sh view
@@ -0,0 +1,46 @@+. lib+rm -rf R+darcs init --repo R+cd R++echo 'revision 1' > f+darcs record -lam 'p1'++echo 'revision 2' > f+darcs record -am 'p2'++echo 'revision 3' > f+darcs record -am 'p3'+++darcs annotate f > out # creates patch index on annotate+grep p3 out+not grep p2 out+not grep p1 out++darcs annotate f --patch 'p2' > out+grep p2 out+not grep p3 out+not grep p1 out++darcs annotate f --patch 'p1' > out+grep p1 out+not grep p2 out+not grep p3 out++darcs optimize disable-patch-index++darcs annotate f > out+grep p3 out+not grep p2 out+not grep p1 out++darcs annotate f --patch 'p2' > out+grep p2 out+not grep p3 out+not grep p1 out++darcs annotate f --patch 'p1' > out+grep p1 out+not grep p2 out+not grep p3 out
+ tests/patch-index-creation.sh view
@@ -0,0 +1,99 @@+#!/usr/bin/env bash+## Test for patch index automation - Patch index should+## be recreated when running:+## * annotate on a file or directory+## * non-interative log on a file+## * init, clone and convert with flag --with-patch-index+##+## It should NOT be created when running:+## * annotate or log with --no-patch-index+## * init, clone and convert, without flags+##+## Copyright (C) 2012 BSRK Aditya, 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+rm -rf R S++darcs init --repo R+cd R+darcs show patch-index-status | grep 'Patch Index is not yet created.' # init++cd ..+rm -rf R++darcs init --repo R --with-patch-index+cd R+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # init --patch-index++cd ..++darcs clone R S+cd S+darcs show patch-index-status | grep 'Patch Index is not yet created.' # clone++cd ..+rm -rf S++darcs clone R S --with-patch-index+cd S+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # clone --patch-index++cd ..++rm -rf repo repo2+gunzip -c $TESTDATA/simple-v1.tgz | tar xf -+echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 +cd repo2+darcs show patch-index-status | grep 'Patch Index is not yet created.' # convert++cd ..+rm -rf repo repo2++gunzip -c $TESTDATA/simple-v1.tgz | tar xf -+echo 'I understand the consequences of my action' | darcs convert darcs-2 repo repo2 --with-patch-index+cd repo2+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # convert --patch-index++cd ../R++mkdir d+echo 'New line.' >> d/f+darcs record -lam "Change d/f"+rm -rf _darcs/patch_index+darcs annotate d/f+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # annotate++rm -rf _darcs/patch_index+darcs annotate d/f --no-patch-index+darcs show patch-index-status | grep 'Patch Index is not yet created.' # annotate --no-patch-index++rm -rf _darcs/patch_index+darcs log -a d/f+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # log -a file++rm -rf _darcs/patch_index+darcs log -a d/f --no-patch-index+darcs show patch-index-status | grep 'Patch Index is not yet created.' # log -a file --no-patch-index++cd ..+rm -rf R S repo repo2
+ tests/patch-index-enabled-and-disabled.sh view
@@ -0,0 +1,62 @@+#!/usr/bin/env bash+## Test for patch index self-healing after used non-patch-index-enabled darcs+## Copyright (C) 2012 Mark Stosberg+##+## 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+rm -rf R+darcs init --repo R --with-patch-index+cd R++#Record some example content+echo 'Example content.' > f+darcs record -lam 'create file.'++# Simulate use by an older darcs binary, by backup in the index and disabling patch index.+mv _darcs/patch_index _darcs/patch_index.bak+touch _darcs/no_patch_index++# Now record Some new changes.+echo 'Example content updated.' > f+echo 'Example content updated.' > f2+darcs record -lam 'Update by older darcs.'++# Now return the repo to the state that the patch-index-enabled darcs would see it.+rm _darcs/no_patch_index+mv _darcs/patch_index.bak _darcs/patch_index++# Now, perform an action with the this darcs. ( and make sure we see the changes from the older darcs. ) +darcs changes f | grep 'older darcs'++# Now, check: Did the patch-index self heal?+darcs show patch-index-status | grep 'Patch Index is in sync with repo.'++# Another check, just to be sure.+echo 'Example content updated again.' > f+darcs record -lam 'Another update by newer darcs'++# Still good?+darcs show patch-index-status | grep 'Patch Index is in sync with repo.'++# Clean up.+cd ..+rm -rf R
+ tests/patch-index-log.sh view
@@ -0,0 +1,77 @@+. lib +rm -rf R+darcs init --repo R+cd R++[[ $(darcs log FOO --count | tail -n 1) -eq 0 ]]++touch f0+darcs record -lam 'p0'++mkdir d1+darcs record -lam 'p1'++touch d1/f1+darcs record -lam 'p2'++darcs move f0 d1/f0+darcs record -am 'p3'++touch d1/f2+darcs record -lam 'p4'++rm d1/f1+darcs record -am 'p5'++darcs move d1/f0 f0+darcs record -am 'p6'++darcs move d1 d2+darcs record -am 'p7'++mkdir d1+darcs record -lam 'p8'++touch d1/f3+darcs record -lam 'p9'++echo "f0" > f0+darcs record -am 'p10'++# log on directories gives all patches+# that touched any sub path (including itself)++# Note that the path of the directory varies+# as you move backward in history.++# The sub path comparision is with the path+# the directory had when the patch which is is being+# tested has been just applied.++# d1 <-> p8-p9+[[ $(darcs log d1 --count | tail -n 1) -eq 2 ]]+for i in 8 9+do+ darcs log d1 | grep p$i+done+++# d2 <-> p1-p7+[[ $(darcs log d2 --count | tail -n 1) -eq 7 ]]+for i in {1..7}+do+ darcs log d2 | grep p$i+done++darcs optimize disable-patch-index+[[ $(darcs log FOO --count | tail -n 1) -eq 0 ]]+[[ $(darcs log d1 --count | tail -n 1) -eq 2 ]]+for i in 8 9+do+ darcs log d1 | grep p$i+done+[[ $(darcs log d2 --count | tail -n 1) -eq 7 ]]+for i in {1..7}+do+ darcs log d2 | grep p$i+done
+ tests/patch-index-rename.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash+## Test that the patch index passes its self-test on a repository+## with a rename.+##+## Copyright (C) 2014 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++mkdir R+cd R+darcs init --with-patch-index+echo initial contents > file1+darcs rec -lam "initial"+darcs mv file1 file2+darcs rec -am "move"++darcs show patch-index-test+
+ tests/patch-index-spans.sh view
@@ -0,0 +1,69 @@+#!/usr/bin/env bash+## Test for patch index integrity of spans - <SYNOPSIS: Test correctness+## of fid_map, fp_map>+##+## Copyright (C) YEAR AUTHOR+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.+darcs init --repo R --with-patch-index # Create our test repos.++cd R+mkdir d e # Change the working tree.+echo 'Example content.' > d/f+darcs record -lam 'Add d/f and e.'+darcs show patch-index-all > pi++grep -F "./d -> 1#./d" pi+grep -F "./d/f -> 1#./d/f" pi+grep -F "./e -> 1#./e" pi+grep -F "1#./d -> ./d" pi+grep -F "1#./d/f -> ./d/f" pi+grep -F "1#./e -> ./e" pi++darcs mv d/f e/+darcs record -am 'Move d/f to e/f.'+darcs show patch-index-all > pi++grep -F "./d -> 1#./d" pi+grep -F "./d/f -> 1#./d/f" pi+grep -F "./e -> 1#./e" pi+grep -F "./e/f -> 1#./d/f" pi+grep -F "1#./d -> ./d" pi+grep -F "1#./d/f -> ./e/f" pi+grep -F "1#./d/f -> ./d/f" pi+grep -F "1#./e -> ./e" pi++echo 'File 2' > d/f+darcs record -lam 'Add d/f'+darcs show patch-index-all > pi++grep -F "./d -> 1#./d" pi+grep -F "./d/f -> 2#./d/f" pi+grep -F "./d/f -> 1#./d/f" pi+grep -F "./e -> 1#./e" pi+grep -F "./e/f -> 1#./d/f" pi+grep -F "1#./d -> ./d" pi+grep -F "1#./d/f -> ./e/f" pi+grep -F "1#./d/f -> ./d/f" pi+grep -F "2#./d/f -> ./d/f" pi+grep -F "1#./e -> ./e" pi
+ tests/patch-index-sync.sh view
@@ -0,0 +1,70 @@+#!/usr/bin/env bash+## Test for patch index automation - <SYNOPSIS: Patch index should+## always be in sync with repo after execution of any command.>+##+## Copyright (C) 2012 BSRK Aditya+##+## 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+rm -rf R S+darcs init --repo R --with-patch-index+darcs init --repo S --with-patch-index+cd R+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test init++mkdir d e+echo 'Example content.' > d/f+darcs record -lam 'Add d/f and e.'+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test record+echo 'New line.' >> d/f+echo "y" | darcs amend-record -p 'Add d/f and e.' -a+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test amend-record++darcs push -a ../S+cd ../S+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test push++echo 'Changed Content' > d/f+darcs record -am 'Change d/f'+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test record 2+darcs send -ao test.dpatch ../R++cd ..+darcs clone R T --with-patch-index+cd T+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test clone++darcs pull -a ../S+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test pull+darcs obliterate -p 'Add d/f and e.' -a+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test obliterate++cd ../R+darcs apply -a ../S/test.dpatch+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test apply+darcs unrecord -a -p 'Change d/f'+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test unrecord+darcs tag -m 'tag R'+darcs show patch-index-status | grep 'Patch Index is in sync with repo.' # test tag++cd ..+rm -rf R S T
tests/pending.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp temp_0 mkdir temp
tests/perms.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib uname | grep "MINGW" > /dev/null && exit 0
tests/posthook.sh view
@@ -1,8 +1,6 @@ #!/usr/bin/env bash -set -ev--. lib+. ./lib rm -rf temp1 mkdir temp1
tests/prefs.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1
tests/prefs_binary.sh view
@@ -12,11 +12,11 @@ darcs add d/t.t darcs record -am "initial record" echo 'some change' >> d/t.t-echo n | darcs record --interactive > log+echo ny | darcs record --interactive > log # pre-test: plain text files are not binary not grep binary log echo 'd/t' >> _darcs/prefs/binaries-echo n | darcs record --interactive > log+echo ny | darcs record --interactive > log grep binary log cd ..
tests/prehook.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/pull-dont-prompt-deps.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib # Check that the right patches get pulled using --dont-prompt-for-dependencies @@ -22,12 +22,12 @@ echo bar2 > b darcs record -Ax -alm bar2 cd ../temp2-echo y | darcs pull ../temp1 -i --dont-prompt-for-dependencies -p foo2 --dry-run > toto+echo yy | darcs pull ../temp1 -i --dont-prompt-for-dependencies -p foo2 --dry-run > toto #on the previous line, we get asked about foo2, and we take it grep foo2 toto | wc -l | grep 2 #we don't get asked about foo1, but we take it anyway, so grep foo1 toto | wc -l | grep 1 #and we don't send bar-grep bar toto | wc -l | grep 0+not grep bar toto cd .. rm -rf temp1 temp2
+ tests/pull-reorder.sh view
@@ -0,0 +1,66 @@+#!/usr/bin/env bash++## Test that pull --reorder moves to the top the uncommon set of patches between+## the current repository and remote repository which we are pulling.++. lib # Load some portability helpers.++check_patches_order () {+ darcs changes | tr -d "\n" | grep $1.*$2.*$3+}++test_init () {+ rm -rf R1 R2+ + darcs init "R1"+ cd R1++ touch "r1_0"+ darcs add "r1_0"+ darcs record -a --author=me -m "Adding r1_0" "r1_0"++ cd ..++ darcs clone "R1" "R2"++ cd R2++ touch "r2_0"+ darcs add "r2_0"+ darcs record -a --author=me -m "Adding r2_0" "r2_0"++ cd ..++ cd R1++ touch "r1_1"+ darcs add "r1_1"+ darcs record -a --author=me -m "Adding r1_1" "r1_1"+ + cd ..+}+++test_init++cd R1++darcs pull -a -p "r2_0" "../R2"+# Without reorder the expected order is r2_0, r1_1, r1_0 .+check_patches_order r2_0 r1_1 r1_0++# Test that pull --reorder reorders even if there is nothing to pull.+darcs pull -a --reorder -p "r2_0" "../R2"+check_patches_order r1_1 r2_0 r1_0++cd ..++test_init++cd R1++darcs pull -a --reorder -p "r2_0" "../R2"+# With reorder the expected order is r1_1, r2_0, r1_0 .+check_patches_order r1_1 r2_0 r1_0++cd ..
tests/pull.sh view
@@ -84,14 +84,15 @@ darcs record -lam BB echo c > foo darcs record -lam CC-darcs rollback -p CC -a -m unC+darcs rollback -p CC -a+darcs record -am unC cd .. rm -rf temp2 darcs get --to-patch B temp1 temp2 cd temp2 sleep 1 # So that rollback won't have same timestamp as get.-darcs rollback -p BB -a -m unB-darcs revert -a+darcs rollback -p BB -a+darcs record -am unB darcs pull -a ../temp1 2> err2 not grep 'Error applying patch' err2 cd ..@@ -134,7 +135,7 @@ # Error applying patch to the working directory. rm -rf tmp;-darcs init --hashed --repodir=tmp+darcs init --darcs-1 --repodir=tmp touch tmp/t.t cd tmp darcs add t.t@@ -142,7 +143,7 @@ darcs record -am 'initial add' --ignore echo 'content: remote change'>t.t darcs record -am 'remote change' --ignore-darcs put tmp2+darcs get . tmp2 cd tmp2 darcs obliterate --last 1 --all; echo 'content: local change'> t.t
tests/pull_binary.sh view
@@ -26,7 +26,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev+. ./lib rm -rf temp1 temp2 @@ -42,7 +42,7 @@ mkdir temp2 cd temp2 darcs init-echo yn | darcs pull --set-default ../temp1+echo yny | darcs pull --set-default ../temp1 rm foo darcs pull -a cd ..
tests/pull_compl.sh view
@@ -26,7 +26,7 @@ ## SOFTWARE. -set -ev+. ./lib rm -rf temp1 temp2 temp3 temp4 temp5
tests/pull_many_files.sh view
@@ -1,13 +1,15 @@ #!/usr/bin/env bash . lib +#pragma repo-format darcs-1,darcs-2+ rm -rf temp1 temp2 -if grep old-fashioned .darcs/defaults; then-format=old-fashioned-inventory+if grep darcs-1 .darcs/defaults; then+format=hashed elif grep darcs-2 .darcs/defaults; then format=darcs-2-else format=hashed; fi+else format=ERROR; fi mkdir temp2 cd temp2
tests/pull_two.sh view
@@ -3,7 +3,7 @@ # This test script, originally written by David Roundy is in the public # domain. -set -ev+. ./lib rm -rf temp1 temp2
tests/push-dont-prompt-deps.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib # Check that the right patches get pushed using --dont-prompt-for-dependencies @@ -21,12 +21,12 @@ darcs record -Ax -alm foo2 echo bar2 > b darcs record -Ax -alm bar2-echo y | darcs push ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run -i > toto+echo yy | darcs push ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run -i > toto #on the previous line, we get asked about foo2, and we take it grep foo2 toto | wc -l | grep 2 #we don't get asked about foo1, but we take it anyway, so grep foo1 toto | wc -l | grep 1 #and we don't send bar-grep bar toto | wc -l | grep 0+not grep bar toto cd .. rm -rf temp1 temp2
tests/push-dry-run.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib # For issue855: wish: avoid taking lock if using --dry-run chmod -R u+w temp2 || :
tests/push.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp temp_0 mkdir temp
tests/push_lock.sh view
@@ -2,7 +2,7 @@ # For issue257: push => incorrect return code when couldn't get lock -set -ev+. ./lib rm -rf tempc mkdir tempc
− tests/put.sh
@@ -1,30 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-cd ..--# put should not set default repo-cd temp1-touch 1.txt-darcs add 1.txt-darcs record -a -m foo 1.txt-darcs put ../temp2-test ! -e _darcs/prefs/defaultrepo-cd ..--# put to self-cd temp1-not grep temp1 _darcs/prefs/defaultrepo-DIR=`pwd`-# return special message when you try to put put yourself-not darcs put "$DIR" 2> log-not grep temp1 _darcs/prefs/defaultrepo-grep -i "Can't put.*current repository" log-cd ..--rm -rf temp1 temp2
tests/query_manifest.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib check_manifest () { : > files.tmp
+ tests/rebase-amend.sh view
@@ -0,0 +1,45 @@+#!/bin/sh -e+##+## Test that amend doesn't leave the rebase in a bad state+##+## 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++rm -rf R+mkdir R+cd R+darcs init++echo 'wibble' > wibble+darcs rec -lam 'wibble'++echo 'wobble' > wibble+darcs rec -am 'wobble'++echo 'yd' | darcs rebase suspend++echo 'wubble' > wibble+echo 'ya' | darcs amend-record++darcs check
+ tests/rebase-apply.sh view
@@ -0,0 +1,89 @@+#!/bin/sh -e+##+## Basic test of rebase apply+##+## Copyright (C) 2011-2014 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++rm -rf R1 R2 R3+mkdir R1+cd R1+darcs init+echo '1' > foo+darcs rec -lam "add foo"+cd ..++darcs get R1 R2+cd R2+echo '2' > foo+darcs rec -am "2"+darcs send -a -o 2.dpatch ../R1+cd ..++darcs get R1 R3+cd R3+echo '3' > foo+darcs rec -am "3"++echo '4' > foo+darcs rec -am "4"++# TODO: figure out behaviour of --all and test it+# (should it answer 'yes' to both pulling and suspending?+echo yyy | darcs rebase apply -a ../R2/2.dpatch++darcs changes --count | grep "Rebase in progress: 2 suspended patches"+echo yny | darcs rebase unsuspend | grep "We have conflicts"+cat > expected <<EOF+v v v v v v v+1+=============+2+*************+3+^ ^ ^ ^ ^ ^ ^+EOF+diff -u expected foo++echo 23 > foo+echo yyy | darcs amend --patch '3'++echo yy | darcs rebase unsuspend | grep "We have conflicts"+cat > expected <<EOF+v v v v v v v+3+=============+23+*************+4+^ ^ ^ ^ ^ ^ ^+EOF+diff -u expected foo++echo 24 > foo+echo yyy | darcs amend --patch '4'++cd ..++
+ tests/rebase-basic.sh view
@@ -0,0 +1,39 @@+#!/bin/sh -e+##+## Basic test of rebase+##+## Copyright (C) 2011 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++rm -rf R+mkdir R+cd R+darcs init+echo 'wibble' > wibble+darcs rec -lam "add wibble"++echo 'yy' | darcs rebase suspend | grep-once "Rebase in progress: 1 suspended patch"+not test -f wibble+echo 'yy' | darcs rebase unsuspend | grep-once "Rebase finished"+test -f wibble
+ tests/rebase-count.sh view
@@ -0,0 +1,43 @@+#!/bin/sh -e+##+## Test that patches are counted properly when a rebase is in progress+##+## Copyright (C) 2015 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++rm -rf R+mkdir R+cd R+darcs init++echo 'wibble' > wibble+darcs rec -lam 'wibble'++echo 'wobble' > wibble+darcs rec -am 'wobble'++echo 'yd' | darcs rebase suspend++darcs log --last 1 | grep wibble+
+ tests/rebase-keeps-deps-on-amend.sh view
@@ -0,0 +1,68 @@+#!/usr/bin/env bash+##+## Check that explicit dependencies are preserved during rebase+##+## Copyright (C) 2011 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 # Load some portability helpers.++rm -rf t1+mkdir t1+cd t1+darcs init++echo 'A' > A+darcs add A+darcs rec -am"A" --ignore-times++echo 'B' > B+darcs add B+darcs rec -am"B" --ignore-times++echo 'C' > C+darcs add C+echo 'yyy' | darcs rec -am"C" --ignore-times --ask-deps++echo 'yyd' | darcs rebase suspend++echo 'A2' > A+echo 'y' | darcs amend -a++echo 'yyy' | darcs rebase unsuspend+darcs unpull --patch 'A' --no-deps | grep "No patches selected"+darcs unpull --patch 'B' --no-deps | grep "No patches selected"++# repeat the test with a tag+darcs unpull --patch 'C' -a+darcs tag T++# two stages because suspend stops at clean tags+# might need to change back to one stage if this changes+echo 'yy' | darcs rebase suspend+echo 'yd' | darcs rebase suspend++echo 'yyy' | darcs rebase unsuspend+# this offers 'T', seems to be a bug in darcs unpull --no-deps+# darcs unpull --patch 'A' --no-deps | grep "No patches selected"+darcs unpull --match 'not name T' | grep "No patches selected"+darcs unpull --patch 'B' --no-deps | grep "No patches selected"
+ tests/rebase-keeps-deps.sh view
@@ -0,0 +1,65 @@+#!/usr/bin/env bash+##+## Check that explicit dependencies are preserved during rebase+##+## Copyright (C) 2011 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 # Load some portability helpers.++rm -rf t1+mkdir t1+cd t1+darcs init++echo 'A' > A+darcs add A+darcs rec -am"A" --ignore-times++echo 'B' > B+darcs add B+darcs rec -am"B" --ignore-times++echo 'C' > C+darcs add C+echo 'yyy' | darcs rec -am"C" --ignore-times --ask-deps++echo 'yydy' | darcs rebase suspend++echo 'yyy' | darcs rebase unsuspend+darcs unpull --patch 'A' --no-deps | grep "No patches selected"+darcs unpull --patch 'B' --no-deps | grep "No patches selected"++# repeat the test with a tag+darcs unpull --patch 'C' -a+darcs tag T++# two stages because suspend stops at clean tags+# might need to change back to one stage if this changes+echo 'yy' | darcs rebase suspend+echo 'yd' | darcs rebase suspend++echo 'yyy' | darcs rebase unsuspend+# this offers 'T', seems to be a bug in darcs unpull --no-deps+# darcs unpull --patch 'A' --no-deps | grep "No patches selected"+darcs unpull --match 'not name T' | grep "No patches selected"+darcs unpull --patch 'B' --no-deps | grep "No patches selected"
+ tests/rebase-move-2.sh view
@@ -0,0 +1,53 @@+#!/usr/bin/env bash+##+## Check that rebase handles amended-in moves+##+## 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 # Load some portability helpers.++rm -rf R++darcs init --repo R++cd R++echo 'wibble' > wibble+darcs rec -lam "add"++darcs mv wibble wobble+darcs rec -am "rename"++echo 'wobble' > wobble+darcs rec -am "edit"++echo 'yyd' | darcs rebase suspend++darcs mv wibble wobble+echo 'yyy' | darcs amend++echo 'yd' | darcs rebase obliterate++echo 'yy' | darcs rebase unsuspend+not darcs wh+
+ tests/rebase-move.sh view
@@ -0,0 +1,47 @@+#!/usr/bin/env bash+##+## Check that rebase merges moves without conflicts+##+## Copyright (C) 2010 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 # Load some portability helpers.++rm -rf t1+mkdir t1+cd t1+darcs init+echo 'wibble' > wibble+darcs add wibble+darcs rec -am"wibble" --ignore-times+echo 'wobble' > wibble+darcs rec -am"wobble" --ignore-times++echo 'yd' | darcs rebase suspend+darcs mv wibble wobble+echo 'y' | darcs amend -a --patch 'wibble'+# there shouldn't be any conflicts+echo 'yy' | darcs rebase unsuspend # | not grep "We have conflicts"+not darcs wh+++
+ tests/rebase-nochanges.sh view
@@ -0,0 +1,62 @@+#!/bin/sh -e+##+## Test that having a rebase in progress doesn't impact+## the UI of other darcs commands.+##+## At the time of writing, rebase was represented by+## a special internal patch and so this test is specifically+## aimed at checked that this patch is not presented in the UI+## Even if this changes, it is still worth having tests of+## the general principle that normal commands should still+## work as usual.+##+## Copyright (C) 2011 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++rm -rf R+mkdir R+cd R+darcs init+echo 'wibble' > wibble+darcs rec -lam "add wibble"++echo 'yy' | darcs rebase suspend++darcs changes --count | grep 0+darcs unpull --dry-run | grep "No patches selected!"++echo 'wobble' > wobble+darcs rec -lam "add wobble" -A tester++darcs changes --count | grep 1+cat > expected <<EOF+ * add wobble++Making no changes: this is a dry run.+EOF+darcs unpull --dry-run | tail -n+5 | grep -v tester | diff -u expected -+++echo 'yy' | darcs rebase unsuspend | grep "Rebase finished"+test -f wibble
+ tests/rebase-obliterate.sh view
@@ -0,0 +1,43 @@+#!/bin/sh -e+##+## Test of rebase obliterate+##+## Copyright (C) 2011 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++rm -rf R+mkdir R+cd R+darcs init+echo 'wibble' > wibble+darcs rec -lam "add wibble"++echo 'wobble' > wobble+darcs rec -lam "add wobble"++echo 'yyy' | darcs rebase suspend+echo 'yd' | darcs rebase obliterate+echo 'yy' | darcs rebase unsuspend | grep 'Rebase finished'+test -f wobble+not test -f wibble
+ tests/rebase-pull-reorder.sh view
@@ -0,0 +1,48 @@+#!/usr/bin/env bash++. lib # Load some portability helpers.++check_patches_order () {+ darcs changes | tr -d "\n" | grep $1.*$2.*$3+}++test_init () {+ rm -rf R1 R2+ + darcs init "R1"+ cd R1++ touch "r1_0"+ darcs add "r1_0"+ darcs record -a --author=me -m "Adding r1_0" "r1_0"++ cd ..++ darcs clone "R1" "R2"++ cd R2++ touch "r2_0"+ darcs add "r2_0"+ darcs record -a --author=me -m "Adding r2_0" "r2_0"+ darcs send --author=me -a --no-edit-description -o ../R1/P ++ cd ..++ cd R1++ touch "r1_1"+ darcs add "r1_1"+ darcs record -a --author=me -m "Adding r1_1" "r1_1"+ + cd ..+}++test_init++cd R1++darcs rebase pull -a --reorder ../R2+check_patches_order r1_1 r2_0 r1_0++cd ..
+ tests/rebase-pull-tag.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+##+## Check that you can pull tags into a repo with rebase in progress+##+## Copyright (C) 2011 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 # Load some portability helpers.++rm -rf t1+mkdir t1+cd t1+darcs init+touch a+darcs add a+darcs rec -am"a"+darcs tag a+cd ..++rm -rf t2+mkdir t2+cd t2+darcs init+touch b+darcs add b+darcs rec -am"b"+echo 'yy' | darcs rebase suspend+darcs pull -a ../t1++darcs check+darcs changes # because darcs check doesn't complain about a corrupt rebase state :-(
+ tests/rebase-pull.sh view
@@ -0,0 +1,88 @@+#!/bin/sh -e+##+## Basic test of rebase pull+##+## Copyright (C) 2011 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++rm -rf R1 R2 R3+mkdir R1+cd R1+darcs init+echo '1' > foo+darcs rec -lam "add foo"+cd ..++darcs get R1 R2+cd R2+echo '2' > foo+darcs rec -am "2"+cd ..++darcs get R1 R3+cd R3+echo '3' > foo+darcs rec -am "3"++echo '4' > foo+darcs rec -am "4"++# TODO: figure out behaviour of --all and test it+# (should it answer 'yes' to both pulling and suspending?+echo yyy | darcs rebase pull -a ../R2++darcs changes --count | grep "Rebase in progress: 2 suspended patches"+echo yny | darcs rebase unsuspend | grep "We have conflicts"+cat > expected <<EOF+v v v v v v v+1+=============+2+*************+3+^ ^ ^ ^ ^ ^ ^+EOF+diff -u expected foo++echo 23 > foo+echo yyy | darcs amend --patch '3'++echo yy | darcs rebase unsuspend | grep "We have conflicts"+cat > expected <<EOF+v v v v v v v+3+=============+23+*************+4+^ ^ ^ ^ ^ ^ ^+EOF+diff -u expected foo++echo 24 > foo+echo yyy | darcs amend --patch '4'++cd ..++
+ tests/rebase-remote.sh view
@@ -0,0 +1,67 @@+#!/bin/sh -e+##+## Test that remote operations on rebase-in-progress repos fail+## or ignore the rebase patch+##+## Copyright (C) 2012-3 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++rm -rf R1 R2 R3 R4+mkdir R1+cd R1+darcs init+echo '1' > foo+darcs rec -lam "add foo"+echo '2' > foo+darcs rec -am "change foo"+echo yny | darcs rebase suspend+cd ..++not darcs get R1 R2+++mkdir R3+cd R3+darcs init+not darcs pull -a ../R1 2>&1 | grep "Cannot transfer patches from a repository where a rebase is in progress"+cd ..++mkdir R4+cd R4+darcs init+cd ../R1+darcs push -a ../R4+cd ../R4+not darcs rebase unsuspend+cd ..++mkdir R5+cd R5+darcs init+cd ../R1+darcs send -a ../R5 -o bundle.dpatch+not grep "DO NOT TOUCH" bundle.dpatch+grep "add foo" bundle.dpatch+not grep "change foo" bundle.dpatch+cd ..
+ tests/rebase-repull.sh view
@@ -0,0 +1,42 @@+#!/bin/sh -e+##+## Repulling a suspended patch+##+## 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++rm -rf R+mkdir R+cd R+darcs init+echo 'wibble' > wibble+darcs rec -lam "add wibble"+cd ..++darcs get R R2++cd R+echo 'yy' | darcs rebase suspend+darcs pull -a ../R2+echo 'yy' | darcs rebase obliterate
+ tests/rebase-skip-conflicts.sh view
@@ -0,0 +1,81 @@+#!/bin/sh -e+##+## Test of rebase unsuspend --skip-conflicts+##+## Copyright (C) 2011 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++rm -rf R+mkdir R+cd R+darcs init++cat > foo <<EOF+1+2+3+4+5+EOF+darcs rec -lam "initial foo"++cat > foo <<EOF+1+2A+3+4+5+EOF+darcs rec -am "change 2A"++cat > foo <<EOF+1+2A+3+4A+5+EOF+darcs rec -am "change 4A"++echo 'yyd' | darcs rebase suspend++cat > foo <<EOF+1+2B+3+4+5+EOF+darcs rec -am "change 2B"++echo 'yy' | darcs rebase unsuspend --skip-conflicts++cat > foo-expected <<EOF+1+2B+3+4A+5+EOF+diff -u foo-expected foo
+ tests/rebase-suspend-from-patch.sh view
@@ -0,0 +1,46 @@+#!/bin/sh -e+##+## Test rebase suspend --from-patch+##+## Copyright (C) 2011 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++rm -rf R+mkdir R+cd R+darcs init+touch foo+darcs rec -lam 'add foo'++touch bar+darcs rec -lam 'add bar'++touch baz+darcs rec -lam 'add baz'++darcs rebase suspend --from-patch 'bar' -a++darcs changes | grep 'add foo'+darcs changes | not grep 'add bar'+darcs changes | not grep 'add baz'
+ tests/rebase-tag.sh view
@@ -0,0 +1,39 @@+#!/usr/bin/env bash+##+## Check that you can't tag a rebase patch+##+## Copyright (C) 2011 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 # Load some portability helpers.++rm -rf t1+mkdir t1+cd t1+darcs init+echo 'wibble' > wibble+darcs add wibble+darcs rec -am"wibble" --ignore-times+echo 'yy' | darcs rebase suspend+darcs tag 'ugh'+darcs check+darcs changes # because darcs check doesn't complain about a corrupt rebase state :-(
+ tests/rebase-unsuspend-to-patch.sh view
@@ -0,0 +1,47 @@+#!/bin/sh -e+##+## Test rebase unsuspend --to-patch+##+## Copyright (C) 2011 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++rm -rf R+mkdir R+cd R+darcs init+touch foo+darcs rec -lam 'add foo'++touch bar+darcs rec -lam 'add bar'++touch baz+darcs rec -lam 'add baz'++echo 'yyyy' | darcs rebase suspend++darcs rebase unsuspend --to-patch 'bar' -a+darcs changes | grep 'add foo'+darcs changes | grep 'add bar'+darcs changes | not grep 'add baz'
+ tests/record-misc.sh view
@@ -0,0 +1,61 @@+#!/usr/bin/env bash++# Some tests for 'darcs record '++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init++# issue308 - no patches and no deps for record should abort+darcs record -am foo --ask-deps | grep -i "Ok, if you don't want to record anything, that's fine!"++# RT#476 - --ask-deps works when there are no patches+if echo $OS | grep -i windows; then+ echo This test does not work on Windows+else+ touch t.f+ darcs add t.f+ darcs record -am add+ echo a | darcs record -am foo --ask-deps | grep -i 'finished recording'+fi++# RT#231 - special message is given for nonexistent directories+not darcs record -am foo not_there.txt > log+grep -i 'not exist' log++# RT#231 - a nonexistent file before an existing file is handled correctly+touch b.t+darcs record -lam foo a.t b.t > log+grep -i 'WARNING:.*a.t' log+grep -iv 'WARNING:.*b.t' log++DIR="`pwd`"+touch date.t+darcs add date.t+darcs record -a -m foo "$DIR/date.t" | grep -i 'finished recording'++# issue396 - record -l ""+touch 'notnull.t'+darcs record -am foo -l "" notnull.t | grep -i 'finished recording'++# basic record+date >> date.t+darcs record -a -m basic_record date.t | grep -i 'finished recording'++# testing --logfile+date >> date.t+echo "second record\n" >> log.txt+darcs record -a -m 'second record' --logfile=log.txt date.t | grep -i 'finished recording'++# refuse empty patch name+export DARCS_EDITOR="cat -n"+date >> date.t+echo "patchname" | darcs record -a -m "" | grep WARNING+date >> date.t+darcs record -a -m "some name"++cd ..+rm -rf temp1
− tests/record.sh
@@ -1,54 +0,0 @@-#!/usr/bin/env bash--# Some tests for 'darcs record '--. lib--rm -rf temp1-mkdir temp1-cd temp1-darcs init--# issue308 - no patches and no deps for record should abort-darcs record -am foo --ask-deps | grep -i "Ok, if you don't want to record anything, that's fine!"--# RT#476 - --ask-deps works when there are no patches-if echo $OS | grep -i windows; then- echo This test does not work on Windows-else- touch t.f- darcs add t.f- darcs record -am add- echo a | darcs record -am foo --ask-deps | grep -i 'finished recording'-fi--# RT#231 - special message is given for nonexistent directories-not darcs record -am foo not_there.txt > log-grep -i 'not exist' log--# RT#231 - a nonexistent file before an existing file is handled correctly-touch b.t-darcs record -lam foo a.t b.t > log-grep -i 'WARNING:.*a.t' log-grep -iv 'WARNING:.*b.t' log--DIR="`pwd`"-touch date.t-darcs add date.t-darcs record -a -m foo "$DIR/date.t" | grep -i 'finished recording'--# issue396 - record -l ""-touch 'notnull.t'-darcs record -am foo -l "" notnull.t | grep -i 'finished recording'--# basic record-date >> date.t-darcs record -a -m basic_record date.t | grep -i 'finished recording'--# testing --logfile-date >> date.t-echo "second record\n" >> log.txt-darcs record -a -m 'second record' --logfile=log.txt date.t | grep -i 'finished recording'--cd ..-rm -rf temp1
tests/record_editor.sh view
@@ -4,8 +4,6 @@ . lib -abort_windows- rm -rf temp1 export DARCS_EDITOR="cat -n"@@ -15,7 +13,7 @@ darcs init touch file.t darcs add file.t-echo y | darcs record --edit-long-comment -a -m foo file.t | grep '2.*END OF DESCRIPTION'+echo y | darcs record --edit-long-comment -a -m foo file.t | grep '# Please enter' cd .. rm -rf temp1 @@ -25,7 +23,7 @@ darcs init touch file.t darcs add file.t-echo y | darcs record --edit-long-comment -a -m foo file.t | grep '2.*END OF DESCRIPTION'+echo y | darcs record --edit-long-comment -a -m foo file.t | grep '# Please enter' cd .. rm -rf temp2\ dir @@ -51,14 +49,14 @@ cd .. rm -rf temp2\ dir -export DARCS_EDITOR='grep "END OF"'+export DARCS_EDITOR='grep "# Please enter"' # editor: quoting in command mkdir temp1 cd temp1 darcs init touch file.t darcs add file.t-echo y | darcs record --edit-long-comment -a -m foo file.t | grep 'END OF'+echo y | darcs record --edit-long-comment -a -m foo file.t | grep '# Please enter' cd .. rm -rf temp1
tests/recordrace.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf foo1 foo2 mkdir foo1 foo2
tests/rename_shouldnt_affect_prefixes.sh view
@@ -39,7 +39,7 @@ darcs move a b darcs rec -am 'Move a -> b' -darcs cha --xml b bb > changes.xml+darcs changes --xml b bb > changes.xml grep "original_name='./a'" < changes.xml # Ensure we've not used a prefix of the filename for the move.
+ tests/renames.sh view
@@ -0,0 +1,29 @@+#!/usr/bin/env bash+## Test various renames+##+## Copyright (C) 2014 Owen Stephens+##+## 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++. lib++rm -rf R && darcs init --repo R+cd R+runhaskell $TESTBIN/renameHelper.hs
tests/repair-clean.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/repair-corrupt-add.sh view
@@ -28,7 +28,7 @@ rm -rf bad mkdir bad cd bad-darcs init+darcs init --no-patch-index echo foo > file darcs add file@@ -37,7 +37,7 @@ darcs rec -a -m 'initial' -darcs changes --verbose --patch 'initial'+darcs changes --verbose --patches 'initial' # produce a corrupt addfile patch echo 'addfile ./file' > _darcs/patches/pending
tests/repair-corrupt.sh view
@@ -3,7 +3,7 @@ rm -rf bad mkdir bad cd bad-darcs init+darcs init --no-patch-index echo foo > bar darcs add bar
tests/repair.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/replace.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp mkdir temp
tests/replace_after_pending_add.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -fr temp1
tests/replace_after_pending_mv.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -fr temp1
tests/repoformat.sh view
@@ -1,5 +1,7 @@ #!/usr/bin/env bash +#pragma repo-format darcs-1,darcs-2+ . lib rm -rf garbage future@@ -66,11 +68,7 @@ # alternative of a line of format # only look at future vs darcs2 -if grep 'old-fashioned' .darcs/defaults; then- exit 200-fi--if grep hashed .darcs/defaults; then+if grep darcs-1 .darcs/defaults; then exit 200 fi @@ -90,7 +88,7 @@ cd temp1 darcs init darcs pull ../future -a-darcs cha | grep titi+darcs changes | grep titi cd .. rm -rf temp1
tests/revert_interactive.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/revert_unrecorded_add.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp mkdir temp
tests/rmconflict.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf tempA tempB mkdir tempA tempB
tests/rmdir.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 temp3
− tests/rollback-no-record.sh
@@ -1,67 +0,0 @@-#!/usr/bin/env bash-## Test for rollback --no-record-##-## Copyright (C) 2010 Florent Becker-##-## Permission is hereby granted, free of charge, to any person-## obtaining a copy of this software and associated documentation-## files (the "Software"), to deal in the Software without-## restriction, including without limitation the rights to use, copy,-## modify, merge, publish, distribute, sublicense, and/or sell copies-## of the Software, and to permit persons to whom the Software is-## furnished to do so, subject to the following conditions:-##-## The above copyright notice and this permission notice shall be-## included in all copies or substantial portions of the Software.-##-## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,-## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF-## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND-## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS-## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN-## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN-## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-## SOFTWARE.--. lib # Load some portability helpers.-darcs init --repo R # Create our test repos.-darcs init --repo S--cd R-mkdir d e-echo 'Example content.' > d/f-darcs record -lam 'Add d/f and e.'-darcs mv d/f e/-darcs replace Example Kestatepa e/f-echo "Blih blah bloh" >> e/f-darcs record -am 'Some changes.'--cat <<EOF >> e/f--Kestatepa--EOF--cat e/f-darcs record -am 'one more line in f'-darcs changes --context > context-darcs rollback -a -p 'Some changes' -m 'rollback'-darcs send -a -o rollback.dpatch --context context ../S-darcs obliterate -a -p rollback-darcs rollback -a -p 'Some changes' --no-record-darcs record -am 'rollback'-darcs send -a -o rollback2.dpatch --context context ../S--#check the effects-not ls e/f-ls d/f-grep Example d/f-not grep "Blih" d/f--#check the content of the patches-#"diff rollback.dpatch rollback2.dpatch" fails because of-#the order of the hunks.-grep "replace .* Kestatepa Example" rollback2.dpatch-grep "move ./e/f ./d/f" rollback2.dpatch-grep -e "-Blih blah bloh" rollback2.dpatch-
tests/rollback-nothing.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -rf temp mkdir temp@@ -11,6 +11,6 @@ darcs record -am "test" rm file1 darcs record -am "rm"-echo yd | darcs rollback --last=1 -m 'oops' | grep 'No changes selected'+echo yYd | tr [A-Z] [a-z] | darcs rollback --last=1 | grep 'No changes selected' cd .. rm -rf temp
− tests/rollback.sh
@@ -1,34 +0,0 @@-#!/bin/bash--set -ev--range="0 1 2"--rm -rf temp1 temp2 # clean up when previous run crashed-mkdir temp1 && cd temp1 && darcs init-touch f && darcs add f-for i in $range-do- echo $i > f && darcs record -A me --ignore-time -m p$i --all f-done--cd .. && mkdir temp2 && cd temp2 && darcs init--set -x--: Demonstrate problem with regrem-for i in $range-do- darcs pull --patch p$i ../temp1 --all- if darcs whatsnew ; then- : Resolve conflict - rollback our patch- darcs revert --all- darcs rollback -a --name x0- darcs revert --all- fi- : Create local change and record it- echo X$i > f && darcs record -l -A me --ignore-time -m x$i --all f-done--cd ..-rm -rf temp1 temp2
tests/sametwice.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1
tests/send-dont-prompt-deps.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib # Check that the right patches get sent using --dont-prompt-for-dependencies @@ -21,12 +21,12 @@ darcs record -Ax -alm foo2 echo bar2 > b darcs record -Ax -alm bar2-echo y | darcs send ../temp2 -i --dont-prompt-for-dependencies -p foo2 --dry-run > toto+echo yy | darcs send ../temp2 -i --dont-prompt-for-dependencies -p foo2 --dry-run > toto #on the previous line, we get asked about foo2, and we take it grep foo2 toto | wc -l | grep 2 #we don't get asked about foo1, but we take it anyway, so grep foo1 toto | wc -l | grep 1 #and we don't send bar-grep bar toto | wc -l | grep 0+not grep bar toto cd .. rm -rf temp1 temp2
tests/send-encoding.sh view
@@ -37,6 +37,6 @@ darcs record -lam 'file1' LANG=en_GB.UTF-8 \- EDITOR='echo Non-ASCII chars: é è ề Ψ ޡ ߐ ह ჴ Ᏻ ‱ ⁂ ∰ ✈ ⢅ .. >' \+ DARCS_EDITOR='echo Non-ASCII chars: é è ề Ψ ޡ ߐ ह ჴ Ᏻ ‱ ⁂ ∰ ✈ ⢅ .. >' \ darcs send -a ../empty --to=invalid@invalid --edit \ --sendmail-command='grep "Content-Type: text/plain; charset=\"utf-8\"" %<'
tests/send-external.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib DARCS_EDITOR=echo export DARCS_EDITOR@@ -43,7 +43,8 @@ chmod +x saveit.sh # foobar-darcs send --author=me -a --to=random@random \+darcs send --mail\+ --author=me -a --to=random@random \ --sendmail-command='bash ./saveit.sh %s %t %c %b %f %a %S %t %C %B %F %A something' ../temp2 cat saved.out
tests/send-output-v1.sh view
@@ -24,9 +24,11 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. +#pragma repo-format darcs-1+ . lib # Load some portability helpers. -grep old-fashioned $HOME/.darcs/defaults || grep hashed $HOME/.darcs/defaults || exit 200+grep darcs-1 $HOME/.darcs/defaults || exit 200 rm -rf empty mkdir empty@@ -37,9 +39,9 @@ rm -rf repo gunzip -c $TESTDATA/simple-v1.tgz | tar xf - cd repo-darcs send -o repo.dpatch -a ../empty+darcs send --no-minimize -o repo.dpatch -a ../empty -day=$(grep "<.*@.*>" $TESTDATA/simple-v1.dpatch | head -n 1 | cut -f1-3 -d' ')+day=$(grep "Date: " $TESTDATA/simple-v1.dpatch | head -n 1 | cut -f1-3 -d' ') diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/simple-v1.dpatch repo.dpatch cd .. @@ -47,7 +49,7 @@ rm -rf repo gunzip -c $TESTDATA/context-v1.tgz | tar xf - cd repo-darcs send -o repo.dpatch -a ../empty-day=$(grep "<.*@.*>" $TESTDATA/context-v1.dpatch | head -n 1 | cut -f1-3 -d' ')+darcs send --no-minimize -o repo.dpatch -a ../empty+day=$(grep "Date: " $TESTDATA/context-v1.dpatch | head -n 1 | cut -f1-3 -d' ') diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/context-v1.dpatch repo.dpatch cd ..
tests/send-output-v2.sh view
@@ -24,6 +24,8 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. +#pragma repo-format darcs-2+ . lib # Load some portability helpers. grep darcs-2 $HOME/.darcs/defaults || exit 200@@ -37,9 +39,9 @@ rm -rf repo gunzip -c $TESTDATA/simple-v2.tgz | tar xf - cd repo-darcs send -o repo.dpatch -a ../empty+darcs send --no-minimize -o repo.dpatch -a ../empty -day=$(grep "<.*@.*>" $TESTDATA/simple-v2.dpatch | head -n 1 | cut -f1-3 -d' ')+day=$(grep "Date: " $TESTDATA/simple-v2.dpatch | head -n 1 | cut -f1-3 -d' ') diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/simple-v2.dpatch repo.dpatch cd .. @@ -47,8 +49,8 @@ rm -rf repo gunzip -c $TESTDATA/context-v2.tgz | tar xf - cd repo-darcs send -o repo.dpatch -a ../empty+darcs send --no-minimize -o repo.dpatch -a ../empty -day=$(grep "<.*@.*>" $TESTDATA/context-v2.dpatch | head -n 1 | cut -f1-3 -d' ')+day=$(grep "Date: " $TESTDATA/context-v2.dpatch | head -n 1 | cut -f1-3 -d' ') diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/context-v2.dpatch repo.dpatch cd ..
tests/send.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib DARCS_EDITOR=echo export DARCS_EDITOR
tests/send_apply.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1 temp2
tests/set-default-hint.sh view
@@ -35,17 +35,20 @@ cd R3 for command in pull push send do+ opt=+ test "$command" = "send" && opt=-O+ # R1 should be the default for R3- darcs $command ../R1 | not grep "$HINTSTRING"- darcs $command ../R2 | grep "$HINTSTRING"+ darcs $command $opt ../R1 | not grep "$HINTSTRING"+ darcs $command $opt ../R2 | grep "$HINTSTRING" # can disable message on the command-line- darcs $command --no-set-default ../R2 | not grep "$HINTSTRING"+ darcs $command $opt --no-set-default ../R2 | not grep "$HINTSTRING" # or using defaults echo "$command no-set-default" >> ../.darcs/defaults- darcs $command ../R2 | not grep "$HINTSTRING"+ darcs $command $opt ../R2 | not grep "$HINTSTRING" - darcs $command --set-default ../R2 | not grep "$HINTSTRING"- darcs $command --set-default ../R1 | not grep "$HINTSTRING"+ darcs $command $opt --set-default ../R2 | not grep "$HINTSTRING"+ darcs $command $opt --set-default ../R1 | not grep "$HINTSTRING" done
tests/several_commands.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/show-authors.sh view
@@ -1,23 +1,26 @@ #!/usr/bin/env bash-set -ev+. ./lib -darcs init+rm -rf R++darcs init --repo R+cd R+ echo zig > foo darcs add foo darcs record -a -m add_foo -A x+ echo zag >> foo darcs record -a -m mod_foo -A y+ echo bar > foo darcs record -a -m mod2 -A y darcs show authors > authors-grep x authors-grep y authors+grep "#1 2 y" authors+grep "#2 1 x" authors -head -1 authors > first-author-grep y first-author+head -1 authors | grep y darcs show authors --verbose-darcs show authors --verbose | grep y | wc -l > num-patches-cat num-patches-grep 2 num-patches+[[ $(darcs show authors --verbose | grep y | wc -l) -eq 2 ]]
tests/show_tags.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
− tests/sigPIPE.sh
@@ -1,34 +0,0 @@-#!/usr/bin/env bash-set -ev--DARCS_EDITOR=echo-export DARCS_EDITOR--rm -rf temp1-mkdir temp1--cd temp1-darcs init--echo hello world > foo-darcs add foo-darcs record -a --author=me -m "First patch"-i=1-while test $i -le 100; do- echo foo $i > foo;- darcs record --ignore-times -a --author=me -m "Patch $i" > bar- i=`expr $i + 1`-done-darcs tag --author=me -m 'silly tag'-i=1000-while test $i -le 1096; do- echo foo $i > foo;- darcs record --ignore-times -a --author=me -m "Patch $i" > bar- i=`expr $i + 1`-done--darcs --version-darcs changes | head--cd ..-# rm -rf temp1
tests/split-patches.sh view
@@ -24,15 +24,14 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. +#pragma repo-format darcs-1,darcs-2+ . lib # Load some portability helpers. -if grep old-fashioned .darcs/defaults; then-format=old-fashioned-inventory-patchtype=darcs-1-elif grep darcs-2 .darcs/defaults; then+if grep darcs-2 .darcs/defaults; then format=darcs-2 patchtype=darcs-2-elif grep hashed .darcs/defaults; then+elif grep darcs-1 .darcs/defaults; then format=hashed patchtype=darcs-1 else exit 200; fi
− tests/steve_and_monica_rollback.sh
@@ -1,38 +0,0 @@-#!/bin/bash--# Issue578: A conflict rollback case for Darcs2--set -ev--rm -rf tmp_steve tmp_monica--mkdir tmp_steve-mkdir tmp_monica--cd tmp_steve-darcs init --darcs-2-echo A >foo-darcs add foo-darcs record -Asteve -am 'Anote'--echo B >foo-darcs record -Asteve -am 'Bnote'--# Show the history as Steve sees it.-darcs changes -s-echo "######"--cd ../tmp_monica-darcs init --darcs-2-echo A>foo-darcs add foo-echo Z>bar-darcs add bar-darcs record -Amonica -am 'AZnote'-darcs pull -a ../tmp_steve-darcs changes-echo "######"-darcs rollback -a -m newpatch -A me --match 'exact Anote'--# previous failure result: darcs failed: cannot roll back a 'rollback' patch.-
+ tests/tag-ask-deps.sh view
@@ -0,0 +1,51 @@+#!/bin/sh -e+##+## Basic test of tag --ask-deps+##+## Copyright (C) 2014 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++rm -rf R S++mkdir R+cd R++darcs init++touch file1+darcs rec -lam 'file1'++touch file2+darcs rec -lam 'file2'++echo 'nyy' | darcs tag --ask-deps file1++cd ..++darcs get --tag file1 R S++cd S+test -f file1+test ! -f file2+
tests/tentative_revert.sh view
@@ -23,8 +23,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev-. lib+. ./lib rm -rf R darcs init --repo R touch R/foo
+ tests/test.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash+## Ensure that "darcs test" succeeds when run in a complete+## repository with a dummy test that always succeeds.+##+## Copyright (C) 2008 David Roundy+##+## Permission is hereby granted, free of charge, to any person+## obtaining a copy of this software and associated documentation+## files (the "Software"), to deal in the Software without+## restriction, including without limitation the rights to use, copy,+## modify, merge, publish, distribute, sublicense, and/or sell copies+## of the Software, and to permit persons to whom the Software is+## furnished to do so, subject to the following conditions:+##+## The above copyright notice and this permission notice shall be+## included in all copies or substantial portions of the Software.+##+## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+## SOFTWARE.++. lib # Load some portability helpers.+rm -rf R # Another script may have left a mess.+darcs init --repo R+darcs setpref --repo R test 'grep hello f'+not darcs record --repo R -am 'true test' --test+darcs record --repo R -am 'true test' --no-test++touch R/f+darcs record --repo R -lam 'added foo' --no-test+darcs tag --repo R -m 'got f?'++echo hello > R/f+darcs record --repo R -lam 'hellofoo' --test+darcs test --repo R++rm -rf R # Clean up after ourselves.
tests/three_way_conflict.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 temp3 mkdir -p temp1 temp2 temp3
tests/toolbox.sh view
@@ -4,8 +4,6 @@ DIR="`pwd`" -abort_windows- # set up the repository rm -rf temp1 # another script may have left a mess. mkdir temp1@@ -13,7 +11,6 @@ darcs init touch foo darcs add foo-# trick: hitting 'enter' in interactive darcs record-echo n/ | tr / \\012 | darcs record+echo ny | darcs record cd .. rm -rf temp1
tests/trackdown-bisect.sh view
@@ -1,14 +1,11 @@ #!/bin/env bash-# A test for trackdown --bisect option.+# A test for test --linear, test --bisect and test --backoff. # In general it construct various repositories and try # to find the last recent failing patch and match it with # expected position.-#-# It runs the same tests also for the trackdown without-# the --bisect. ################################################################ -set -ev+. ./lib if echo $OS | grep -i windows; then echo I do not know how to run a test program under windows@@ -32,15 +29,15 @@ rm -fr temp1 } -# You can remove --bisect for compare with linear trackdown-trackdown_args='--bisect' +# You can replace --bisect by --linear for compare with linear trackdown+test_args='--bisect' # Function return true if given patch was found. # It expects that last line has finish with <SPACE><patchname> # For the linear it is second last from the end, and last line-# is sentence if trackdown failed or succeed.+# is sentence if test failed or succeed. function is_found_good_patch {- if [ -z "$trackdown_args" ]; then+ if [ "$test_args" == "--linear" ]; then tail -n 2 | grep " $1\$" else tail -n 1 | grep " $1\$"@@ -58,7 +55,7 @@ # TEST01: Repo with success in the half testTrackdown() { make_repo_with_test $1-if darcs trackdown $trackdown_args "$test_cmd" | is_found_good_patch $2; then+if darcs test $test_args "$test_cmd" | is_found_good_patch $2; then echo "ok 1" else echo "not ok 1. the trackdown should find last failing patch = $2."@@ -72,70 +69,40 @@ testTrackdown '[1,1,0,0,0]' 3 } -# TEST02: Repo with without success condition+# TEST02: Repo without success condition test02() { testTrackdown '[0,0,0,0,0]' 1 } -# TEST03: Repo with with success condition at before last patch+# TEST03: Repo with success condition at before last patch test03() { testTrackdown '[1,1,1,1,0]' 5 } -# TEST04: Repo with with success condition as first patch ever+# TEST04: Repo with success condition as first patch ever test04() { testTrackdown '[1,0,0,0,0]' 2 } -# TEST05: Long repo with with success condition as first patch ever-test05() {-testTrackdown '[1,0,0,0,0,0,0,0,0,0,0]' 2-}--# TEST06: Long repo with with success condition as sixth patch-test06() {-testTrackdown '[1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0]' 7-}--# TEST07: Long repo with with success condition very nead the head-test07() {-testTrackdown '[1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0]' 54-}--# TEST08: Long repo with with success condition very nead the head-test08() {-testTrackdown '[1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0]' 55-}--# TEST09: Long repo with non-monotone errors / success distribution-# This test only tests that it will not crash... -test09() {-testTrackdown '[1,1,1,1,1,1,0,0,0,0,1,0,0,1,0,0,0,0,0,0]' 7-}- #############################################-# call test-cases for trackdown linear+# call test-cases for linear trackdown #############################################-trackdown_args=''+test_args='--linear' test01 test02+#############################################+# Call test-cases for bisect trackdown+#############################################+test_args='--bisect' +test01+test02 test03 test04-test05-test06-test07-test08 #############################################-# Call test-cases for trackdown bisect+# Call test-cases for backoff trackdown #############################################-trackdown_args='--bisect' +test_args='--backoff' test01 test02 test03 test04-test05-test06-test07-test08-test09 # only for --bisect-
tests/tricky_unrecord.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp mkdir temp
tests/uniqueoptions.sh view
@@ -3,7 +3,7 @@ echo Checking that each command expects each option only once echo -set -ev+. ./lib if echo $OS | grep -i windows; then echo Noone knows how to handle newlines under cygwin, so we skip this test
tests/unpull-formerly-pl.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf tempA mkdir tempA@@ -28,21 +28,21 @@ darcs replace baz world foo darcs record -a -m baz2world -darcs whatsnew | grep 'No changes'+not darcs whatsnew grep 'love the world' foo -echo y | darcs unpull -p baz2world+echo yy | darcs unpull -p baz2world -darcs whatsnew | grep 'No changes'+not darcs whatsnew grep 'love the baz' foo -echo y | darcs unpull -p bar2baz+echo yy | darcs unpull -p bar2baz grep 'love the bar' foo -echo y | darcs unpull -p nolove+echo yy | darcs unpull -p nolove grep 'love' foo && exit 1 || true
tests/unpull.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1@@ -17,7 +17,7 @@ one EOF darcs rec -Ax -am foo-echo y | darcs unpull -p foo+echo yy | darcs unpull -p foo cmp f g cd .. rm -rf temp1
tests/unrecord-add.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/unrecord-dont-prompt.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib # Check that the right patches get unrecorded using --dont-prompt-for-dependencies @@ -19,7 +19,7 @@ darcs unrec --no-deps -p foo1 darcs changes -p foo --count | grep 2 #foo1 is depended upon, we don't unpull it-echo y | darcs unrec --dont-prompt-for-dependencies -p foo1+echo yy | darcs unrec --dont-prompt-for-dependencies -p foo1 #on the previous line, we don't get asked about foo2. darcs changes -p foo --count | grep 0 #yet, it is unrecorded.
tests/unrecord-remove.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/unrecord-setpref.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/unrevert.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 mkdir temp1
tests/unrevert_cancel.sh view
@@ -2,7 +2,7 @@ # From issue366 bug report -set -ev+. ./lib rm -rf temp1 mkdir temp1@@ -14,9 +14,9 @@ darcs record -A moi -am init echo plim >> a echo plim >> b-echo y/y/y/ | tr / \\012 | darcs revert+echo yyyy | darcs revert echo ploum >> a -echo nyy | tr / \\012 | darcs unrevert+echo nyyy | darcs unrevert cd .. rm -rf temp1
+ tests/utf8-display.sh view
@@ -0,0 +1,46 @@+#!/bin/sh -e+##+## Basic test of displaying metadata in the UTF8 locale+##+## Copyright (C) 2014 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++abort_windows # TODO make this work++switch_to_utf8_locale++export DARCS_DONT_ESCAPE_8BIT=1++rm -rf R+mkdir R+cd R++darcs init+echo 'Société nationale des chemins de fer français' > f+darcs rec -lam 'creació de a i b' | grep 'creació de a i b'++darcs changes | grep 'creació de a i b'++darcs annotate f | grep 'creació de a i b'+darcs annotate f | grep 'Société nationale des chemins de fer français'
− tests/utf8.sh
@@ -1,193 +0,0 @@-#!/usr/bin/env bash-## Test for issue64 - Should store patch metadata in UTF-8-##-## Copyright (C) 2009 Reinier Lamers-##-## 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 --# Helper function: do a darcs changes --xml and grep the result for the first-# argument. If it is not found, exit with status 1. Otherwise, continue. The-# second argument is a text that describes what we're grepping for.-# If a third argument is given, it is used as the value for a --last option for-# darcs changes.-grep_changes () {- if [ -z "$3" ]; then- last=""- else- last="--last $3"- fi-- darcs changes $last --xml > changes.xml- if grep "$1" changes.xml ; then- echo "$2 OK"- else- cat changes.xml- echo "$2 not UTF-8-encoded!"- exit 1- fi-}---# This file is encoded in ISO-8859-15 aka latin9. It was crafted with a hex editor.-# Please leave it this way :-)-switch_to_latin9_locale--rm -rf temp1-mkdir temp1-cd temp1--darcs init--# Test recording non-UTF-8-encoded non-latin1 ("funny") metadata from-# interactive input--echo 'Selbstverständlich überraschend' > something.txt-darcs add something.txt--echo 'l33tking¸0r@example.org' > interaction_script.txt-echo y >> interaction_script.txt-echo y >> interaction_script.txt-echo '¤uroh4xx0rz' >> interaction_script.txt-echo n >> interaction_script.txt--unset DARCSEMAIL-unset EMAIL-set-darcs record -i < interaction_script.txt-grep_changes 'l33tkingž0r@example.org' 'patch author from interactive prompt'-grep_changes 'â¬uroh4xx0rz' 'patch name from interactive prompt'--# Test recording funny metadata from command line --echo 'Sogar überraschender' >> something.txt--darcs record -a -A 'Jérôme Leb½uf' -m 'that will be ¤ 15, sir'--grep_changes 'that will be ⬠15, sir' 'patch name from command line'-grep_changes 'Jérôme LebÅuf' 'patch author from command line'--# Test recording funny metadata from a log file--echo 'Am allerüberraschendsten' >> something.txt--echo 'darcs is soms wat naïef aangaande tekstcodering' > log.txt-echo 'en zulke naïviteit is tegenwoordig passé, aldus ´i¸ek' >> log.txt-darcs record -a -A 'Jérôme Leb½uf' --logfile=log.txt--grep_changes 'darcs is soms wat naïef aangaande tekstcodering' 'patch name from log file'-grep_changes 'en zulke naïviteit is tegenwoordig passé, aldus Žižek' 'patch log from log file'--# Test recording funny metadata from environment, -export EMAIL='Slavoj ´i¸ek <zizek@example.edu>'-rm _darcs/prefs/author-echo 'La la la, the more lines the better!' >> something.txt-darcs record -a -m 'Patch names are overrated'--grep_changes 'Slavoj Žižek' 'author name from environment'--# Test recording funny metadata from prefs files-echo '´ed is dead' > _darcs/prefs/author-echo '483 bottles of beer on the wall' >> something.txt-darcs record -a -m 'Patch by ´ed'--grep_changes 'Žed is dead' 'author name from prefs file'--# Test amend-recording funny metadata-echo 'No, it is really 484' >> something.txt-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'--cat <<FAKE > 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'-grep_changes 'Žed is even deader' 'author name taken from draft in amend'--# Test rollback recording funny metadata-printf "y\ny\n" | darcs rollback -p 's are gone' -A '´ee´ee' -m "No patch¤s by ´ed!"-grep_changes 'ŽeeŽee' 'Author name from rollback command line'-grep_changes 'No patchâ¬s by Žed' 'Patch name from rollback command line'-grep_changes 'All my â¬s are gone' 'Patch name of rolled back patch' 1-grep_changes 'Žed is even deader' 'Author name of rolled back patch' 1--# Test tag recording funny metadata-rm _darcs/prefs/author # Make tag be taken from EMAIL env variable-darcs tag -m '´ is my favorite letter'-grep_changes 'Slavoj Žižek' 'author name from environment with tag command' 1-grep_changes 'Ž is my favorite letter' 'Tag name from command line'--unset EMAIL-printf "´ors\ninitialcomment\n" | darcs tag --edit-long-comment-grep_changes Žors 'Author name from interactive prompt from tag command'-grep_changes 'All my â¬s are gone' 'Tag name from editor from tag command' 1--if grep ´ors _darcs/prefs/author ; then- echo 'Author name stored locale-encoded in prefs file after tag command, OK'-else- echo 'No locale-encoded author in prefs file after tag command!'- exit 1-fi--darcs tag -A Ad¸e -m 'La¸t call'-grep_changes Adže 'Author name from tag command line' 1-grep_changes 'Lažt call' 'Tag name from tag command line (take 2)' 1--cd ..--# test that UTF-8 metadata doesn't get mangled on get-rm -rf temp2-darcs get temp1 temp2-darcs changes --repodir temp1 --xml > temp1/changes.xml-darcs changes --repodir temp2 --xml > temp2/changes.xml-diff temp1/changes.xml temp2/changes.xml--# and that it doesn't get mangled on push-rm -rf temp2-mkdir temp2; darcs init --repodir temp2-darcs push --repodir temp1 -a temp2 --set-default-darcs changes --repodir temp1 --xml > temp1/changes.xml-darcs changes --repodir temp2 --xml > temp2/changes.xml-diff temp1/changes.xml temp2/changes.xml--# and that it doesn't get mangled on pull-rm -rf temp2-mkdir temp2; darcs init --repodir temp2-darcs pull --repodir temp2 -a temp1-darcs changes --repodir temp1 --xml > temp1/changes.xml-darcs changes --repodir temp2 --xml > temp2/changes.xml-diff temp1/changes.xml temp2/changes.xml--# and that it doesn't get mangled on send-rm -rf temp2-mkdir temp2; darcs init --repodir temp2-darcs send --repodir temp1 -a -o temp2/patch.dpatch-darcs apply --repodir temp2 -a temp2/patch.dpatch-darcs changes --repodir temp1 --xml > temp1/changes.xml-darcs changes --repodir temp2 --xml > temp2/changes.xml-diff temp1/changes.xml temp2/changes.xml
tests/v1-braced.sh view
@@ -24,9 +24,11 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. +#pragma repo-format darcs-1+ . lib # Load some portability helpers. -grep hashed $HOME/.darcs/defaults || exit 200+grep darcs-1 $HOME/.darcs/defaults || exit 200 rm -rf braced gunzip -c $TESTDATA/braced.tgz | tar xf -
tests/what_sl.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -rf temp1 mkdir temp1
+ tests/whatsnew-interactive.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash+## +## This tests the basic fascilities of `whatsnew --interactive`+##+## Copyright (C) 2014 Daniil Frumin+##+## 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++rm -rf wn-i++darcs init --repo wn-i+cd wn-i++echo lolz > foo+darcs add foo++echo n | darcs whatsnew -i > what+grep "Will not ask whether to view 1" what+rm what++echo yxgq | darcs whatsnew -i > what2+grep "M ./foo +1" what2+addfileCount=`grep -c "addfile" what2`+if [ "$addfileCount" -ne 3 ]; then+ exit 1+fi;