--  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 MagicHash, OverloadedStrings #-}

module Darcs.UI.Commands.Convert ( convert ) where

import Prelude ( lookup )
import Darcs.Prelude hiding ( readFile, lex )

import System.FilePath.Posix ( (</>) )
import System.Directory
    ( doesDirectoryExist
    , doesFileExist
    , removeFile
    )
import System.IO ( stdin )
import Data.IORef ( newIORef, modifyIORef, readIORef )
import Data.Char ( isSpace )
import Control.Arrow ( second, (&&&) )
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 System.Time ( toClockTime )
import Data.Maybe ( catMaybes, fromJust, 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 Darcs.Util.ByteString ( decodeLocale )
import qualified Darcs.Util.Tree as T
import qualified Darcs.Util.Tree.Monad as TM
import Darcs.Util.Tree.Monad hiding ( createDirectory, exists, rename )
import Darcs.Util.Tree.Hashed ( hashedTreeIO, darcsAddMissingHashes )
import Darcs.Util.Tree( Tree, treeHash, readBlob, TreeItem(..)
                      , emptyTree, listImmediate, findTree )
import Darcs.Util.Path( anchorPath, appendPath, floatPath
                      , parent, anchoredRoot
                      , AnchoredPath(..), makeName
                      , ioAbsoluteOrRemote, toPath, AbsolutePath )
import Darcs.Util.Hash( encodeBase16, sha256, Hash(..) )

import Darcs.Util.DateTime ( formatDateTime, fromClockTime, parseDateTime, startOfTime )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Exception ( clarifyErrors )
import Darcs.Util.Lock ( withNewDirectory )
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
    ( showPatch, ShowPatchFor(..), fromPrim, fromPrims
    , effect, RepoPatch, apply, listTouchedFiles, move )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Effect ( Effect )
import Darcs.Patch.Named
    ( patch2patchinfo
    , infopatch, adddeps, getdeps, patchcontents
    )
import Darcs.Patch.Named.Wrapped ( WrappedNamed(..) )
import qualified Darcs.Patch.Named.Wrapped as Wrapped ( getdeps )
import Darcs.Patch.Witnesses.Eq ( EqCheck(..), (=/\=) )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), RL(..), bunchFL, mapFL_FL,
    concatFL, mapRL, nullFL, (+>+), (+<+)
    , reverseRL, reverseFL, foldFL_M )
import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), Sealed(..), unFreeLeft
                                    , mapSeal, flipSeal, unsafeUnsealFlipped )

import Darcs.Patch.Info ( piRename, piTag, isTag, PatchInfo, patchinfo,
                          piName, piLog, piDate, piAuthor, makePatchname )
import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 )
import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )
import qualified Darcs.Patch.V2 as V2 ( RepoPatchV2 )
import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )
import Darcs.Patch.V1.Commute ( publicUnravel )
import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(PP), isMerger )
import Darcs.Patch.V2.RepoPatch ( mergeUnravelled )
import Darcs.Patch.Prim ( sortCoalesceFL )
import Darcs.Patch.Prim.Class ( PrimOf )
import Darcs.Patch.RepoType ( RepoType(..), IsRepoType(..), RebaseType(..) )
import Darcs.Patch.Set ( PatchSet(..), Tagged(..), patchSet2RL, patchSet2FL )
import Darcs.Patch.Progress ( progressFL )

import Darcs.Repository.Flags
    ( UpdateWorking(..)
    , Compression(..)
    , DiffAlgorithm(PatienceDiff) )
import Darcs.Repository
    ( Repository, RepoJob(..), withRepositoryLocation
    , createRepository, invalidateIndex, repoLocation
    , createPristineDirectoryTree, repoCache
    , revertRepositoryChanges, finalizeRepositoryChanges
    , applyToWorking, repoLocation, repoCache
    , readRepo, readTentativeRepo, cleanRepository
    , createRepositoryV2, EmptyRepository(..)
    , withUMaskFlag
    )
import qualified Darcs.Repository as R( setScriptsExecutable )
import Darcs.Repository.InternalTypes ( coerceR )
import Darcs.Repository.State( readRecorded )
import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) )
import Darcs.Repository.Hashed
    ( tentativelyAddPatch_
    , UpdatePristine(..)
    , readHashedPristineRoot
    , addToTentativeInventory )
import Darcs.Repository.HashedIO ( cleanHashdir )
import Darcs.Repository.Prefs( FileType(..), showMotd )
import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2))
import Darcs.Util.External ( fetchFilePS, Cachable(Uncachable) )
import Darcs.Repository.Diff( treeDiff )


import Darcs.UI.External ( catchall )
import Darcs.UI.Flags
    ( verbosity, useCache, umask, withWorkingDir, patchIndexNo
    , DarcsFlag ( NewRepo )
    , getRepourl, patchFormat, quiet
    )
import Darcs.UI.Commands ( DarcsCommand(..), amInRepository, nodefaults, putInfo
                         , normalCommand, withStdOpts )
import Darcs.UI.Commands.Util.Tree ( treeHasDir, treeHasFile )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O

type RepoPatchV1 = V1.RepoPatchV1 V1.Prim
type RepoPatchV2 = V2.RepoPatchV2 V2.Prim


convertDescription :: String
convertDescription :: String
convertDescription = "Convert repositories between various formats."

convertHelp :: String
convertHelp :: String
convertHelp = [String] -> String
unlines
 [ "This command converts a repository that uses the old patch semantics"
 , "`darcs-1` to a new repository with current `darcs-2` semantics."
 , ""
 , String
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' :: String
convertHelp' = [String] -> String
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 :: String
convertExportHelp = [String] -> String
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 :: String
convertImportHelp = [String] -> String
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 -M) | 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 :: DarcsCommand [DarcsFlag]
convert = SuperCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> ([DarcsFlag] -> IO (Either String ()))
-> [CommandControl]
-> DarcsCommand parsedFlags
SuperCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "convert"
    , commandHelp :: String
commandHelp = ""
    , commandDescription :: String
commandDescription = String
convertDescription
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInRepository
    , commandSubCommands :: [CommandControl]
commandSubCommands =
        [ DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
convertDarcs2
        , DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
convertExport
        , DarcsCommand [DarcsFlag] -> CommandControl
forall parsedFlags. DarcsCommand parsedFlags -> CommandControl
normalCommand DarcsCommand [DarcsFlag]
convertImport
        ]
    }

convertDarcs2 :: DarcsCommand [DarcsFlag]
convertDarcs2 :: DarcsCommand [DarcsFlag]
convertDarcs2 = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "darcs-2"
    , commandHelp :: String
commandHelp = String
convertHelp
    , commandDescription :: String
commandDescription = "Convert darcs-1 repository to the darcs-2 patch format"
    , commandExtraArgs :: Int
commandExtraArgs = -1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = ["<SOURCE>", "[<DESTINATION>]"]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
toDarcs2
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = \_ -> Either String () -> IO (Either String ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
forall a b. b -> Either a b
Right ()
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (NetworkOptions -> WithPatchIndex -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (NetworkOptions -> WithPatchIndex -> Any)
forall a.
OptSpec
  DarcsOptDescr DarcsFlag a (NetworkOptions -> WithPatchIndex -> a)
convertDarcs2AdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String -> SetScriptsExecutable -> WithWorkingDir -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String -> SetScriptsExecutable -> WithWorkingDir -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> SetScriptsExecutable -> WithWorkingDir -> a)
convertDarcs2BasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> PatchFormat
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags (DarcsOption
  (PatchFormat -> [DarcsFlag])
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> PatchFormat
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
convertDarcs2Opts DarcsOption
  (PatchFormat -> [DarcsFlag])
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> PatchFormat
   -> [DarcsFlag])
-> OptSpec
     DarcsOptDescr DarcsFlag [DarcsFlag] (PatchFormat -> [DarcsFlag])
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     [DarcsFlag]
     (Maybe String
      -> SetScriptsExecutable
      -> WithWorkingDir
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> NetworkOptions
      -> WithPatchIndex
      -> UseCache
      -> HooksConfig
      -> PatchFormat
      -> [DarcsFlag])
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr DarcsFlag [DarcsFlag] (PatchFormat -> [DarcsFlag])
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a PatchFormat
convertDarcs2SilentOpts)
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
convertDarcs2Opts
    , commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
convertDarcs2Opts
    }
  where
    convertDarcs2BasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> SetScriptsExecutable -> WithWorkingDir -> a)
convertDarcs2BasicOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (SetScriptsExecutable -> WithWorkingDir -> a)
  (Maybe String)
PrimDarcsOption (Maybe String)
O.reponame PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (SetScriptsExecutable -> WithWorkingDir -> a)
  (Maybe String)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithWorkingDir -> a)
     (SetScriptsExecutable -> WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithWorkingDir -> a)
     (Maybe String -> SetScriptsExecutable -> WithWorkingDir -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (WithWorkingDir -> a)
  (SetScriptsExecutable -> WithWorkingDir -> a)
PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable OptSpec
  DarcsOptDescr
  DarcsFlag
  (WithWorkingDir -> a)
  (Maybe String -> SetScriptsExecutable -> WithWorkingDir -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe String -> SetScriptsExecutable -> WithWorkingDir -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (WithWorkingDir -> a)
PrimDarcsOption WithWorkingDir
O.withWorkingDir
    convertDarcs2AdvancedOpts :: OptSpec
  DarcsOptDescr DarcsFlag a (NetworkOptions -> WithPatchIndex -> a)
convertDarcs2AdvancedOpts = PrimOptSpec
  DarcsOptDescr DarcsFlag (WithPatchIndex -> a) NetworkOptions
PrimDarcsOption NetworkOptions
O.network PrimOptSpec
  DarcsOptDescr DarcsFlag (WithPatchIndex -> a) NetworkOptions
-> OptSpec DarcsOptDescr DarcsFlag a (WithPatchIndex -> a)
-> OptSpec
     DarcsOptDescr DarcsFlag a (NetworkOptions -> WithPatchIndex -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (WithPatchIndex -> a)
PrimDarcsOption WithPatchIndex
O.patchIndexNo
    convertDarcs2Opts :: DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
convertDarcs2Opts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> SetScriptsExecutable -> WithWorkingDir -> a)
convertDarcs2BasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> SetScriptsExecutable
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> a)
     (NetworkOptions -> WithPatchIndex -> UseCache -> HooksConfig -> a)
-> DarcsOption
     a
     (Maybe String
      -> SetScriptsExecutable
      -> WithWorkingDir
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> NetworkOptions
      -> WithPatchIndex
      -> UseCache
      -> HooksConfig
      -> a)
forall b c a.
DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> a)
  (NetworkOptions -> WithPatchIndex -> UseCache -> HooksConfig -> a)
forall a.
OptSpec
  DarcsOptDescr DarcsFlag a (NetworkOptions -> WithPatchIndex -> a)
convertDarcs2AdvancedOpts
    convertDarcs2SilentOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a PatchFormat
convertDarcs2SilentOpts = PrimOptSpec DarcsOptDescr DarcsFlag a PatchFormat
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a PatchFormat
O.patchFormat

convertExport :: DarcsCommand [DarcsFlag]
convertExport :: DarcsCommand [DarcsFlag]
convertExport = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "export"
    , commandHelp :: String
commandHelp = String
convertExportHelp
    , commandDescription :: String
commandDescription = "Export a darcs repository to a git-fast-import stream"
    , commandExtraArgs :: Int
commandExtraArgs = 0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastExport
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (NetworkOptions -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (NetworkOptions -> Any)
PrimDarcsOption NetworkOptions
convertExportAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String -> Maybe String -> Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String -> Maybe String -> Maybe String -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> Maybe String -> Maybe String -> a)
convertExportBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> a)
convertExportOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> a)
convertExportOpts
    , commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> a)
convertExportOpts
    }
  where
    convertExportBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> Maybe String -> Maybe String -> a)
convertExportBasicOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> Maybe String -> a)
  (Maybe String)
PrimDarcsOption (Maybe String)
O.reponame PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> Maybe String -> a)
  (Maybe String)
-> OptSpec
     DarcsOptDescr DarcsFlag a (Maybe String -> Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe String -> Maybe String -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr DarcsFlag a (Maybe String -> Maybe String -> a)
forall a. DarcsOption a (Maybe String -> Maybe String -> a)
O.marks
    convertExportAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
convertExportAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a NetworkOptions
PrimDarcsOption NetworkOptions
O.network
    convertExportOpts :: DarcsOption
  a
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> a)
convertExportOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> Maybe String -> Maybe String -> a)
convertExportBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> Maybe String
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> NetworkOptions
   -> UseCache
   -> HooksConfig
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> a)
     (NetworkOptions -> UseCache -> HooksConfig -> a)
-> DarcsOption
     a
     (Maybe String
      -> Maybe String
      -> Maybe String
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> NetworkOptions
      -> UseCache
      -> HooksConfig
      -> a)
forall b c a.
DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> a)
  (NetworkOptions -> UseCache -> HooksConfig -> a)
PrimDarcsOption NetworkOptions
convertExportAdvancedOpts

convertImport :: DarcsCommand [DarcsFlag]
convertImport :: DarcsCommand [DarcsFlag]
convertImport = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "import"
    , commandHelp :: String
commandHelp = String
convertImportHelp
    , commandDescription :: String
commandDescription = "Import from a git-fast-export stream into darcs"
    , commandExtraArgs :: Int
commandExtraArgs = -1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = ["[<DIRECTORY>]"]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastImport
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = \_ -> Either String () -> IO (Either String ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
forall a b. b -> Either a b
Right ()
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (WithPatchIndex -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (WithPatchIndex -> Any)
PrimDarcsOption WithPatchIndex
convertImportAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
convertImportBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
convertImportOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
convertImportOpts
    , commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
convertImportOpts
    }
  where
    convertImportBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
convertImportBasicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
  (Maybe String)
PrimDarcsOption (Maybe String)
O.reponame
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
  (Maybe String)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (PatchFormat -> WithWorkingDir -> a)
     (SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (PatchFormat -> WithWorkingDir -> a)
     (Maybe String
      -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (PatchFormat -> WithWorkingDir -> a)
  (SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (PatchFormat -> WithWorkingDir -> a)
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithWorkingDir -> a)
     (PatchFormat -> WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WithWorkingDir -> a)
     (Maybe String
      -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (WithWorkingDir -> a)
  (PatchFormat -> WithWorkingDir -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a PatchFormat
O.patchFormat
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (WithWorkingDir -> a)
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (WithWorkingDir -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe String
      -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (WithWorkingDir -> a)
PrimDarcsOption WithWorkingDir
O.withWorkingDir
    convertImportAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a WithPatchIndex
convertImportAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a WithPatchIndex
PrimDarcsOption WithPatchIndex
O.patchIndexNo
    convertImportOpts :: DarcsOption
  a
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
convertImportOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> SetScriptsExecutable -> PatchFormat -> WithWorkingDir -> a)
convertImportBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> SetScriptsExecutable
   -> PatchFormat
   -> WithWorkingDir
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> WithPatchIndex
   -> UseCache
   -> HooksConfig
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> a)
     (WithPatchIndex -> UseCache -> HooksConfig -> a)
-> DarcsOption
     a
     (Maybe String
      -> SetScriptsExecutable
      -> PatchFormat
      -> WithWorkingDir
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> WithPatchIndex
      -> UseCache
      -> HooksConfig
      -> a)
forall b c a.
DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> a)
  (WithPatchIndex -> UseCache -> HooksConfig -> a)
PrimDarcsOption WithPatchIndex
convertImportAdvancedOpts

toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
toDarcs2 _ opts' :: [DarcsFlag]
opts' args :: [String]
args = do
  (inrepodir :: String
inrepodir, opts :: [DarcsFlag]
opts) <-
    case [String]
args of
      [arg1 :: String
arg1, arg2 :: String
arg2] -> (String, [DarcsFlag]) -> IO (String, [DarcsFlag])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
arg1, String -> DarcsFlag
NewRepo String
arg2DarcsFlag -> [DarcsFlag] -> [DarcsFlag]
forall a. a -> [a] -> [a]
:[DarcsFlag]
opts')
      [arg1 :: String
arg1] -> (String, [DarcsFlag]) -> IO (String, [DarcsFlag])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
arg1, [DarcsFlag]
opts')
      _ -> String -> IO (String, [DarcsFlag])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "You must provide either one or two arguments."
  AbsoluteOrRemotePath
typed_repodir <- String -> IO AbsoluteOrRemotePath
ioAbsoluteOrRemote String
inrepodir
  let repodir :: String
repodir = AbsoluteOrRemotePath -> String
forall a. FilePathOrURL a => a -> String
toPath AbsoluteOrRemotePath
typed_repodir

  RepoFormat
format <- String -> IO RepoFormat
identifyRepoFormat String
repodir
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
Darcs2 RepoFormat
format) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Repository is already in darcs 2 format."

  String -> IO ()
putStrLn String
convertHelp'
  let vow :: String
vow = "I understand the consequences of my action"
  String -> IO ()
putStrLn "Please confirm that you have read and understood the above"
  String
vow' <- String -> IO String
askUser ("by typing `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vow String -> String -> String
forall a. [a] -> [a] -> [a]
++ "': ")
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
vow' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
vow) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "User didn't understand the consequences."

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([DarcsFlag] -> Bool
quiet [DarcsFlag]
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
showMotd String
repodir

  String
mysimplename <- [DarcsFlag] -> String -> IO String
makeRepoName [DarcsFlag]
opts String
repodir
  UMask -> IO () -> IO ()
forall a. UMask -> IO a -> IO a
withUMaskFlag (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO () -> IO ()
withNewDirectory String
mysimplename (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Repository
  ('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
repo <- WithWorkingDir
-> WithPatchIndex
-> UseCache
-> IO
     (Repository
        ('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin)
createRepositoryV2
      (PrimDarcsOption WithWorkingDir
withWorkingDir PrimDarcsOption WithWorkingDir -> [DarcsFlag] -> WithWorkingDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption WithPatchIndex
patchIndexNo PrimDarcsOption WithPatchIndex -> [DarcsFlag] -> WithPatchIndex
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption UseCache
O.useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    Repository
  ('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
-> UpdateWorking -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> UpdateWorking -> IO ()
revertRepositoryChanges Repository
  ('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
repo UpdateWorking
NoUpdateWorking

    UseCache -> String -> RepoJob () -> IO ()
forall a. UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) String
repodir (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall wR wU.
 Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
 -> IO ())
-> RepoJob ()
forall a.
(forall wR wU.
 Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
 -> IO a)
-> RepoJob a
V1Job ((forall wR wU.
  Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
  -> IO ())
 -> RepoJob ())
-> (forall wR wU.
    Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
    -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \other :: Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
other -> do
      PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
theirstuff <- Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
-> IO (PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository ('RepoType 'NoRebase) (RepoPatchV1 Prim) wR wU wR
other
      let patches :: FL
  (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)) Origin wR
patches = (forall wW wY.
 PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim) wW wY
 -> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wW wY)
-> FL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim)) Origin wR
-> FL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)) Origin wR
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL (WrappedNamed ('RepoType 'NoRebase) (RepoPatchV1 Prim) wW wY
-> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wW wY
forall wX wY.
WrappedNamed ('RepoType 'NoRebase) (RepoPatchV1 Prim) wX wY
-> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY
convertNamed (WrappedNamed ('RepoType 'NoRebase) (RepoPatchV1 Prim) wW wY
 -> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wW wY)
-> (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim) wW wY
    -> WrappedNamed ('RepoType 'NoRebase) (RepoPatchV1 Prim) wW wY)
-> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim) wW wY
-> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wW wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim) wW wY
-> WrappedNamed ('RepoType 'NoRebase) (RepoPatchV1 Prim) wW wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully) (FL
   (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim)) Origin wR
 -> FL
      (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)) Origin wR)
-> FL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim)) Origin wR
-> FL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)) Origin wR
forall a b. (a -> b) -> a -> b
$ PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
-> FL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim)) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
theirstuff
          outOfOrderTags :: [(PatchInfo, [PatchInfo])]
outOfOrderTags = [Maybe (PatchInfo, [PatchInfo])] -> [(PatchInfo, [PatchInfo])]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (PatchInfo, [PatchInfo])] -> [(PatchInfo, [PatchInfo])])
-> [Maybe (PatchInfo, [PatchInfo])] -> [(PatchInfo, [PatchInfo])]
forall a b. (a -> b) -> a -> b
$ (forall wW wZ.
 PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim) wW wZ
 -> Maybe (PatchInfo, [PatchInfo]))
-> RL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim)) Origin wR
-> [Maybe (PatchInfo, [PatchInfo])]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL forall wW wZ.
PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim) wW wZ
-> Maybe (PatchInfo, [PatchInfo])
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
PatchInfoAnd rt p wX wY -> Maybe (PatchInfo, [PatchInfo])
oot (RL
   (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim)) Origin wR
 -> [Maybe (PatchInfo, [PatchInfo])])
-> RL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim)) Origin wR
-> [Maybe (PatchInfo, [PatchInfo])]
forall a b. (a -> b) -> a -> b
$ PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
-> RL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV1 Prim)) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
theirstuff
              where oot :: PatchInfoAnd rt p wX wY -> Maybe (PatchInfo, [PatchInfo])
oot t :: PatchInfoAnd rt p wX wY
t = if PatchInfo -> Bool
isTag (PatchInfoAnd rt p wX wY -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wX wY
t) Bool -> Bool -> Bool
&& PatchInfoAnd rt p wX wY -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wX wY
t PatchInfo -> [PatchInfo] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
-> [PatchInfo]
forall (rt :: RepoType) (p :: * -> * -> *) wS wX.
PatchSet rt p wS wX -> [PatchInfo]
inOrderTags PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
theirstuff
                            then (PatchInfo, [PatchInfo]) -> Maybe (PatchInfo, [PatchInfo])
forall a. a -> Maybe a
Just (PatchInfoAnd rt p wX wY -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wX wY
t, WrappedNamed rt p wX wY -> [PatchInfo]
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> [PatchInfo]
Wrapped.getdeps (WrappedNamed rt p wX wY -> [PatchInfo])
-> WrappedNamed rt p wX wY -> [PatchInfo]
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p wX wY -> WrappedNamed rt p wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully PatchInfoAnd rt p wX wY
t)
                            else Maybe (PatchInfo, [PatchInfo])
forall a. Maybe a
Nothing
          fixDep :: PatchInfo -> [PatchInfo]
fixDep p :: PatchInfo
p = case PatchInfo -> [(PatchInfo, [PatchInfo])] -> Maybe [PatchInfo]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PatchInfo
p [(PatchInfo, [PatchInfo])]
outOfOrderTags of
                     Just d :: [PatchInfo]
d -> PatchInfo
p PatchInfo -> [PatchInfo] -> [PatchInfo]
forall a. a -> [a] -> [a]
: (PatchInfo -> [PatchInfo]) -> [PatchInfo] -> [PatchInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatchInfo -> [PatchInfo]
fixDep [PatchInfo]
d
                     Nothing -> [PatchInfo
p]
          primV1toV2 :: Prim x y -> Prim x y
primV1toV2 = Prim x y -> Prim x y
forall x y. Prim x y -> Prim x y
V2.Prim (Prim x y -> Prim x y)
-> (Prim x y -> Prim x y) -> Prim x y -> Prim x y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prim x y -> Prim x y
forall x y. Prim x y -> Prim x y
V1.unPrim
          convertOne :: RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY
          convertOne :: RepoPatchV1 wX wY -> FL (RepoPatchV2 Prim) wX wY
convertOne x :: RepoPatchV1 wX wY
x | RepoPatchV1 wX wY -> Bool
forall (prim :: * -> * -> *) wA wB. RepoPatchV1 prim wA wB -> Bool
V1.isMerger RepoPatchV1 wX wY
x =
            let ex :: FL Prim wX wY
ex = (forall wW wY. Prim wW wY -> Prim wW wY)
-> FL Prim wX wY -> FL Prim wX wY
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall wW wY. Prim wW wY -> Prim wW wY
primV1toV2 (RepoPatchV1 wX wY -> FL (PrimOf (RepoPatchV1 Prim)) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect RepoPatchV1 wX wY
x) in
            case [Sealed (FL Prim wY)] -> Maybe (FlippedSeal (RepoPatchV2 Prim) wY)
forall (prim :: * -> * -> *) wX.
PrimPatch prim =>
[Sealed (FL prim wX)] -> Maybe (FlippedSeal (RepoPatchV2 prim) wX)
mergeUnravelled ([Sealed (FL Prim wY)]
 -> Maybe (FlippedSeal (RepoPatchV2 Prim) wY))
-> [Sealed (FL Prim wY)]
-> Maybe (FlippedSeal (RepoPatchV2 Prim) wY)
forall a b. (a -> b) -> a -> b
$ (Sealed (FL Prim wY) -> Sealed (FL Prim wY))
-> [Sealed (FL Prim wY)] -> [Sealed (FL Prim wY)]
forall a b. (a -> b) -> [a] -> [b]
map ((forall wX. FL Prim wY wX -> FL Prim wY wX)
-> Sealed (FL Prim wY) -> Sealed (FL Prim wY)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal ((forall wW wY. Prim wW wY -> Prim wW wY)
-> FL Prim wY wX -> FL Prim wY wX
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall wW wY. Prim wW wY -> Prim wW wY
primV1toV2)) ([Sealed (FL Prim wY)] -> [Sealed (FL Prim wY)])
-> [Sealed (FL Prim wY)] -> [Sealed (FL Prim wY)]
forall a b. (a -> b) -> a -> b
$ RepoPatchV1 wX wY -> [Sealed (FL Prim wY)]
forall (prim :: * -> * -> *) wX wY.
PrimPatch prim =>
RepoPatchV1 prim wX wY -> [Sealed (FL prim wY)]
publicUnravel RepoPatchV1 wX wY
x of
             Just (FlippedSeal y :: RepoPatchV2 Prim wX wY
y) ->
                 case RepoPatchV2 Prim wX wY -> FL (PrimOf (RepoPatchV2 Prim)) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect RepoPatchV2 Prim wX wY
y FL Prim wX wY -> FL Prim wX wY -> EqCheck wX wX
forall (p :: * -> * -> *) wA wC wB.
Eq2 p =>
p wA wC -> p wB wC -> EqCheck wA wB
=/\= FL Prim wX wY
ex of
                 IsEq -> RepoPatchV2 Prim wX wY
y RepoPatchV2 Prim wX wY
-> FL (RepoPatchV2 Prim) wY wY -> FL (RepoPatchV2 Prim) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (RepoPatchV2 Prim) wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
                 NotEq ->
                     Doc
-> (FL Prim wX wY -> FL (RepoPatchV2 Prim) wX wY)
-> FL Prim wX wY
-> FL (RepoPatchV2 Prim) wX wY
forall a. Doc -> a -> a
traceDoc (String -> Doc
text "lossy conversion:" Doc -> Doc -> Doc
$$
                               ShowPatchFor -> RepoPatchV1 wX wY -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForDisplay RepoPatchV1 wX wY
x)
                     FL Prim wX wY -> FL (RepoPatchV2 Prim) wX wY
forall (p :: * -> * -> *) wX wY.
FromPrims p =>
FL (PrimOf p) wX wY -> p wX wY
fromPrims FL Prim wX wY
ex
             Nothing -> Doc
-> (FL Prim wX wY -> FL (RepoPatchV2 Prim) wX wY)
-> FL Prim wX wY
-> FL (RepoPatchV2 Prim) wX wY
forall a. Doc -> a -> a
traceDoc (String -> Doc
text
                                  "lossy conversion of complicated conflict:" Doc -> Doc -> Doc
$$
                                  ShowPatchFor -> RepoPatchV1 wX wY -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForDisplay RepoPatchV1 wX wY
x)
                        FL Prim wX wY -> FL (RepoPatchV2 Prim) wX wY
forall (p :: * -> * -> *) wX wY.
FromPrims p =>
FL (PrimOf p) wX wY -> p wX wY
fromPrims FL Prim wX wY
ex
          convertOne (V1.PP x :: Prim wX wY
x) = PrimOf (RepoPatchV2 Prim) wX wY -> RepoPatchV2 wX wY
forall (p :: * -> * -> *) wX wY.
FromPrim p =>
PrimOf p wX wY -> p wX wY
fromPrim (Prim wX wY -> Prim wX wY
forall wW wY. Prim wW wY -> Prim wW wY
primV1toV2 Prim wX wY
x) RepoPatchV2 wX wY
-> FL (RepoPatchV2 Prim) wY wY -> FL (RepoPatchV2 Prim) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (RepoPatchV2 Prim) wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
          convertOne _ = FL (RepoPatchV2 Prim) wX wY
forall a. a
impossible
          convertFL :: FL RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY
          convertFL :: FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
convertFL = FL (FL (RepoPatchV2 Prim)) wX wY -> FL (RepoPatchV2 Prim) wX wY
forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL (FL (FL (RepoPatchV2 Prim)) wX wY -> FL (RepoPatchV2 Prim) wX wY)
-> (FL (RepoPatchV1 Prim) wX wY
    -> FL (FL (RepoPatchV2 Prim)) wX wY)
-> FL (RepoPatchV1 Prim) wX wY
-> FL (RepoPatchV2 Prim) wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall wW wY. RepoPatchV1 wW wY -> FL (RepoPatchV2 Prim) wW wY)
-> FL (RepoPatchV1 Prim) wX wY -> FL (FL (RepoPatchV2 Prim)) wX wY
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall wW wY. RepoPatchV1 wW wY -> FL (RepoPatchV2 Prim) wW wY
convertOne
          convertNamed :: WrappedNamed ('RepoType 'NoRebase) RepoPatchV1 wX wY
                       -> PatchInfoAnd ('RepoType 'NoRebase) RepoPatchV2 wX wY
          convertNamed :: WrappedNamed ('RepoType 'NoRebase) (RepoPatchV1 Prim) wX wY
-> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY
convertNamed (NormalP n :: Named (RepoPatchV1 Prim) wX wY
n)
                         = WrappedNamed ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY
-> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY
n2pia (WrappedNamed ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY
 -> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY)
-> WrappedNamed ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY
-> PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY
forall a b. (a -> b) -> a -> b
$ Named (RepoPatchV2 Prim) wX wY
-> WrappedNamed ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
Named p wX wY -> WrappedNamed rt p wX wY
NormalP (Named (RepoPatchV2 Prim) wX wY
 -> WrappedNamed ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY)
-> Named (RepoPatchV2 Prim) wX wY
-> WrappedNamed ('RepoType 'NoRebase) (RepoPatchV2 Prim) wX wY
forall a b. (a -> b) -> a -> b
$
                           Named (RepoPatchV2 Prim) wX wY
-> [PatchInfo] -> Named (RepoPatchV2 Prim) wX wY
forall (p :: * -> * -> *) wX wY.
Named p wX wY -> [PatchInfo] -> Named p wX wY
adddeps (PatchInfo
-> FL (RepoPatchV2 Prim) wX wY -> Named (RepoPatchV2 Prim) wX wY
forall (p :: * -> * -> *) wX wY.
PatchInfo -> FL p wX wY -> Named p wX wY
infopatch (PatchInfo -> PatchInfo
convertInfo (PatchInfo -> PatchInfo) -> PatchInfo -> PatchInfo
forall a b. (a -> b) -> a -> b
$ Named (RepoPatchV1 Prim) wX wY -> PatchInfo
forall (p :: * -> * -> *) wX wY. Named p wX wY -> PatchInfo
patch2patchinfo Named (RepoPatchV1 Prim) wX wY
n) (FL (RepoPatchV2 Prim) wX wY -> Named (RepoPatchV2 Prim) wX wY)
-> FL (RepoPatchV2 Prim) wX wY -> Named (RepoPatchV2 Prim) wX wY
forall a b. (a -> b) -> a -> b
$
                                              FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
forall wX wY.
FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
convertFL (FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY)
-> FL (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV2 Prim) wX wY
forall a b. (a -> b) -> a -> b
$ Named (RepoPatchV1 Prim) wX wY -> FL (RepoPatchV1 Prim) wX wY
forall (p :: * -> * -> *) wX wY. Named p wX wY -> FL p wX wY
patchcontents Named (RepoPatchV1 Prim) wX wY
n)
                                   ((PatchInfo -> PatchInfo) -> [PatchInfo] -> [PatchInfo]
forall a b. (a -> b) -> [a] -> [b]
map PatchInfo -> PatchInfo
convertInfo ([PatchInfo] -> [PatchInfo]) -> [PatchInfo] -> [PatchInfo]
forall a b. (a -> b) -> a -> b
$ (PatchInfo -> [PatchInfo]) -> [PatchInfo] -> [PatchInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PatchInfo -> [PatchInfo]
fixDep ([PatchInfo] -> [PatchInfo]) -> [PatchInfo] -> [PatchInfo]
forall a b. (a -> b) -> a -> b
$ Named (RepoPatchV1 Prim) wX wY -> [PatchInfo]
forall (p :: * -> * -> *) wX wY. Named p wX wY -> [PatchInfo]
getdeps Named (RepoPatchV1 Prim) wX wY
n)
          convertInfo :: PatchInfo -> PatchInfo
convertInfo n :: PatchInfo
n | PatchInfo
n PatchInfo -> [PatchInfo] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
-> [PatchInfo]
forall (rt :: RepoType) (p :: * -> * -> *) wS wX.
PatchSet rt p wS wX -> [PatchInfo]
inOrderTags PatchSet ('RepoType 'NoRebase) (RepoPatchV1 Prim) Origin wR
theirstuff = PatchInfo
n
                        | Bool
otherwise = PatchInfo -> (String -> PatchInfo) -> Maybe String -> PatchInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PatchInfo
n (\t :: String
t -> PatchInfo -> String -> PatchInfo
piRename PatchInfo
n ("old tag: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
t)) (Maybe String -> PatchInfo) -> Maybe String -> PatchInfo
forall a b. (a -> b) -> a -> b
$ PatchInfo -> Maybe String
piTag PatchInfo
n

      -- Note: we use bunchFL so we can commit every 100 patches
      Repository ('RepoType 'NoRebase) (RepoPatchV2 Prim) wR wR wR
_ <- [DarcsFlag]
-> Repository
     ('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
-> FL
     (FL (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)))
     Origin
     wR
-> IO
     (Repository ('RepoType 'NoRebase) (RepoPatchV2 Prim) wR wR wR)
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> Repository rt p wX wX wX
-> FL (FL (PatchInfoAnd rt p)) wX wY
-> IO (Repository rt p wY wY wY)
applyAll [DarcsFlag]
opts Repository
  ('RepoType 'NoRebase) (RepoPatchV2 Prim) Origin Origin Origin
repo (FL
   (FL (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)))
   Origin
   wR
 -> IO
      (Repository ('RepoType 'NoRebase) (RepoPatchV2 Prim) wR wR wR))
-> FL
     (FL (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)))
     Origin
     wR
-> IO
     (Repository ('RepoType 'NoRebase) (RepoPatchV2 Prim) wR wR wR)
forall a b. (a -> b) -> a -> b
$ Int
-> FL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)) Origin wR
-> FL
     (FL (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)))
     Origin
     wR
forall (a :: * -> * -> *) wX wY.
Int -> FL a wX wY -> FL (FL a) wX wY
bunchFL 100 (FL
   (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)) Origin wR
 -> FL
      (FL (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)))
      Origin
      wR)
-> FL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)) Origin wR
-> FL
     (FL (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)))
     Origin
     wR
forall a b. (a -> b) -> a -> b
$ String
-> FL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)) Origin wR
-> FL
     (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)) Origin wR
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL "Converting patch" FL
  (PatchInfoAnd ('RepoType 'NoRebase) (RepoPatchV2 Prim)) Origin wR
patches
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PrimDarcsOption SetScriptsExecutable
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable [DarcsFlag]
opts SetScriptsExecutable -> SetScriptsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== SetScriptsExecutable
O.YesSetScriptsExecutable)
        IO ()
R.setScriptsExecutable

      -- Copy over the prefs file
      let prefsRelPath :: String
prefsRelPath = String
darcsdir String -> String -> String
</> "prefs" String -> String -> String
</> "prefs"
      (String -> Cachable -> IO ByteString
fetchFilePS (String
repodir String -> String -> String
</> String
prefsRelPath) Cachable
Uncachable IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ByteString -> IO ()
B.writeFile String
prefsRelPath)
       IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Finished converting."
  where
    applyOne :: (RepoPatch p, ApplyState p ~ Tree)
             => [DarcsFlag]
             -> W2 (Repository rt p wR) wX
             -> PatchInfoAnd rt p wX wY
             -> IO (W2 (Repository rt p wR) wY)
    applyOne :: [DarcsFlag]
-> W2 (Repository rt p wR) wX
-> PatchInfoAnd rt p wX wY
-> IO (W2 (Repository rt p wR) wY)
applyOne opts :: [DarcsFlag]
opts (W2 r :: Repository rt p wR wX wX
r) x :: PatchInfoAnd rt p wX wY
x = do
      Repository rt p wR wX wY
r' <- UpdatePristine
-> Repository rt p wR wX wX
-> Compression
-> Verbosity
-> UpdateWorking
-> PatchInfoAnd rt p wX wY
-> IO (Repository rt p wR wX wY)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> PatchInfoAnd rt p wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatch_ ([DarcsFlag] -> UpdatePristine
updatePristine [DarcsFlag]
opts) Repository rt p wR wX wX
r
        Compression
GzipCompression (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ([DarcsFlag] -> UpdateWorking
updateWorking [DarcsFlag]
opts) PatchInfoAnd rt p wX wY
x
      Repository rt p wR wY wY
r'' <- IO (Repository rt p wR wY wY) -> IO (Repository rt p wR wY wY)
forall a. IO a -> IO a
withTryAgainMsg (IO (Repository rt p wR wY wY) -> IO (Repository rt p wR wY wY))
-> IO (Repository rt p wR wY wY) -> IO (Repository rt p wR wY wY)
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wX wY
-> Verbosity
-> FL (PrimOf p) wX wY
-> IO (Repository rt p wR wY wY)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking Repository rt p wR wX wY
r' (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PatchInfoAnd rt p wX wY -> FL (PrimOf (PatchInfoAnd rt p)) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect PatchInfoAnd rt p wX wY
x)
      Repository rt p wR wY wY -> IO ()
forall t. t -> IO ()
invalidateIndex Repository rt p wR wY wY
r''
      W2 (Repository rt p wR) wY -> IO (W2 (Repository rt p wR) wY)
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository rt p wR wY wY -> W2 (Repository rt p wR) wY
forall (r :: * -> * -> *) wX. r wX wX -> W2 r wX
W2 Repository rt p wR wY wY
r'')

    applySome :: [DarcsFlag]
-> W3 (Repository rt p) wR
-> FL (PatchInfoAnd rt p) wR wX
-> IO (W3 (Repository rt p) wX)
applySome opts :: [DarcsFlag]
opts (W3 r :: Repository rt p wR wR wR
r) xs :: FL (PatchInfoAnd rt p) wR wX
xs = do
      Repository rt p wR wX wX
r' <- W2 (Repository rt p wR) wX -> Repository rt p wR wX wX
forall (r :: * -> * -> *) wX. W2 r wX -> r wX wX
unW2 (W2 (Repository rt p wR) wX -> Repository rt p wR wX wX)
-> IO (W2 (Repository rt p wR) wX) -> IO (Repository rt p wR wX wX)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall wA wB.
 W2 (Repository rt p wR) wA
 -> PatchInfoAnd rt p wA wB -> IO (W2 (Repository rt p wR) wB))
-> W2 (Repository rt p wR) wR
-> FL (PatchInfoAnd rt p) wR wX
-> IO (W2 (Repository rt p wR) wX)
forall (m :: * -> *) (r :: * -> *) (p :: * -> * -> *) wX wY.
Monad m =>
(forall wA wB. r wA -> p wA wB -> m (r wB))
-> r wX -> FL p wX wY -> m (r wY)
foldFL_M ([DarcsFlag]
-> W2 (Repository rt p wR) wA
-> PatchInfoAnd rt p wA wB
-> IO (W2 (Repository rt p wR) wB)
forall (p :: * -> * -> *) (rt :: RepoType) wR wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> W2 (Repository rt p wR) wX
-> PatchInfoAnd rt p wX wY
-> IO (W2 (Repository rt p wR) wY)
applyOne [DarcsFlag]
opts) (Repository rt p wR wR wR -> W2 (Repository rt p wR) wR
forall (r :: * -> * -> *) wX. r wX wX -> W2 r wX
W2 Repository rt p wR wR wR
r) FL (PatchInfoAnd rt p) wR wX
xs
      -- commit after applying a bunch of patches
      Repository rt p wR wX wX -> UpdateWorking -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
finalizeRepositoryChanges Repository rt p wR wX wX
r' ([DarcsFlag] -> UpdateWorking
updateWorking [DarcsFlag]
opts) Compression
GzipCompression
      Repository rt p wR wX wX -> UpdateWorking -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> UpdateWorking -> IO ()
revertRepositoryChanges Repository rt p wR wX wX
r' ([DarcsFlag] -> UpdateWorking
updateWorking [DarcsFlag]
opts)
      -- finalizeRepositoryChanges and revertRepositoryChanges
      -- do not (yet?) return a repo with properly coerced witnesses.
      -- We should have
      --
      -- > finalizeRepositoryChanges :: ... wR wU wT -> ... wT wU wT
      --
      -- and
      --
      -- > revertRepositoryChanges :: ... wR wU wT -> ... wR wU wR
      --
      -- This is why we must coerce here:
      W3 (Repository rt p) wX -> IO (W3 (Repository rt p) wX)
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository rt p wX wX wX -> W3 (Repository rt p) wX
forall (r :: * -> * -> * -> *) wX. r wX wX wX -> W3 r wX
W3 (Repository rt p wR wX wX -> Repository rt p wX wX wX
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wR'.
Repository rt p wR wU wT -> Repository rt p wR' wU wT
coerceR Repository rt p wR wX wX
r'))

    applyAll :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
             => [DarcsFlag]
             -> Repository rt p wX wX wX
             -> FL (FL (PatchInfoAnd rt p)) wX wY
             -> IO (Repository rt p wY wY wY)
    applyAll :: [DarcsFlag]
-> Repository rt p wX wX wX
-> FL (FL (PatchInfoAnd rt p)) wX wY
-> IO (Repository rt p wY wY wY)
applyAll opts :: [DarcsFlag]
opts r :: Repository rt p wX wX wX
r xss :: FL (FL (PatchInfoAnd rt p)) wX wY
xss = W3 (Repository rt p) wY -> Repository rt p wY wY wY
forall (r :: * -> * -> * -> *) wX. W3 r wX -> r wX wX wX
unW3 (W3 (Repository rt p) wY -> Repository rt p wY wY wY)
-> IO (W3 (Repository rt p) wY) -> IO (Repository rt p wY wY wY)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall wA wB.
 W3 (Repository rt p) wA
 -> FL (PatchInfoAnd rt p) wA wB -> IO (W3 (Repository rt p) wB))
-> W3 (Repository rt p) wX
-> FL (FL (PatchInfoAnd rt p)) wX wY
-> IO (W3 (Repository rt p) wY)
forall (m :: * -> *) (r :: * -> *) (p :: * -> * -> *) wX wY.
Monad m =>
(forall wA wB. r wA -> p wA wB -> m (r wB))
-> r wX -> FL p wX wY -> m (r wY)
foldFL_M ([DarcsFlag]
-> W3 (Repository rt p) wA
-> FL (PatchInfoAnd rt p) wA wB
-> IO (W3 (Repository rt p) wB)
forall (rt :: RepoType) (p :: * -> * -> *) wR wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> W3 (Repository rt p) wR
-> FL (PatchInfoAnd rt p) wR wX
-> IO (W3 (Repository rt p) wX)
applySome [DarcsFlag]
opts) (Repository rt p wX wX wX -> W3 (Repository rt p) wX
forall (r :: * -> * -> * -> *) wX. r wX wX wX -> W3 r wX
W3 Repository rt p wX wX wX
r) FL (FL (PatchInfoAnd rt p)) wX wY
xss

    updatePristine :: [DarcsFlag] -> UpdatePristine
    updatePristine :: [DarcsFlag] -> UpdatePristine
updatePristine opts :: [DarcsFlag]
opts =
      case PrimDarcsOption WithWorkingDir
withWorkingDir PrimDarcsOption WithWorkingDir -> [DarcsFlag] -> WithWorkingDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
        O.WithWorkingDir -> UpdatePristine
UpdatePristine
        -- this should not be necessary but currently is, because
        -- some commands (e.g. send) cannot cope with a missing pristine
        -- even if the repo is marked as having no working tree
        O.NoWorkingDir -> {- DontUpdatePristineNorRevert -}UpdatePristine
UpdatePristine

    updateWorking :: [DarcsFlag] -> UpdateWorking
    updateWorking :: [DarcsFlag] -> UpdateWorking
updateWorking opts :: [DarcsFlag]
opts =
      case PrimDarcsOption WithWorkingDir
withWorkingDir PrimDarcsOption WithWorkingDir -> [DarcsFlag] -> WithWorkingDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
        O.WithWorkingDir -> UpdateWorking
YesUpdateWorking
        O.NoWorkingDir -> UpdateWorking
NoUpdateWorking

    withTryAgainMsg :: IO a -> IO a
    withTryAgainMsg :: IO a -> IO a
withTryAgainMsg x :: IO a
x = IO a
x IO a -> String -> IO a
forall a. IO a -> String -> IO a
`clarifyErrors` [String] -> String
unlines
      [ "An error occurred while applying patches to the working tree."
      , "You may have more luck if you supply --no-working-dir." ]

-- | Need this to make 'foldFL_M' work with a function that changes
-- the last two (identical) witnesses at the same time.
newtype W2 r wX = W2 {W2 r wX -> r wX wX
unW2 :: r wX wX}

-- | Similarly for when the function changes all three witnesses.
newtype W3 r wX = W3 {W3 r wX -> r wX wX wX
unW3 :: r wX wX wX}

makeRepoName :: [DarcsFlag] -> FilePath -> IO String
makeRepoName :: [DarcsFlag] -> String -> IO String
makeRepoName (NewRepo n :: String
n:_) _ =
    do Bool
exists <- String -> IO Bool
doesDirectoryExist String
n
       Bool
file_exists <- String -> IO Bool
doesFileExist String
n
       if Bool
exists Bool -> Bool -> Bool
|| Bool
file_exists
          then String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Directory or file named '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' already exists."
          else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
n
makeRepoName (_:as :: [DarcsFlag]
as) d :: String
d = [DarcsFlag] -> String -> IO String
makeRepoName [DarcsFlag]
as String
d
makeRepoName [] d :: String
d =
  case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='.') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
       (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '/' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ':') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
       (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='/') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
d of
  "" -> String -> IO String
modifyRepoName "anonymous_repo"
  base :: String
base -> String -> IO String
modifyRepoName String
base

modifyRepoName :: String -> IO String
modifyRepoName :: String -> IO String
modifyRepoName name :: String
name =
    if String -> Char
forall a. [a] -> a
head String
name Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/'
    then String -> Int -> IO String
mrn String
name (-1)
    else do String
cwd <- IO String
getCurrentDirectory
            String -> Int -> IO String
mrn (String
cwd String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) (-1)
 where
  mrn :: String -> Int -> IO String
  mrn :: String -> Int -> IO String
mrn n :: String
n i :: Int
i = do
    Bool
exists <- String -> IO Bool
doesDirectoryExist String
thename
    Bool
file_exists <- String -> IO Bool
doesFileExist String
thename
    if Bool -> Bool
not Bool
exists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
file_exists
       then do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= -1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Directory '"String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
                               "' already exists, creating repository as '"String -> String -> String
forall a. [a] -> [a] -> [a]
++
                               String
thename String -> String -> String
forall a. [a] -> [a] -> [a]
++"'"
               String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
thename
       else String -> Int -> IO String
mrn String
n (Int -> IO String) -> Int -> IO String
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1
    where thename :: String
thename = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -1 then String
n else String
nString -> String -> String
forall a. [a] -> [a] -> [a]
++"_"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
i

fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastExport _ opts :: [DarcsFlag]
opts _ = do
  let repodir :: String
repodir = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "." (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ [DarcsFlag] -> Maybe String
getRepourl [DarcsFlag]
opts
  Marks
marks <- case PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe String)
O.readMarks [DarcsFlag]
opts of
    Nothing -> Marks -> IO Marks
forall (m :: * -> *) a. Monad m => a -> m a
return Marks
emptyMarks
    Just f :: String
f  -> String -> IO Marks
readMarks String
f
  Marks
newMarks <- UseCache -> String -> RepoJob Marks -> IO Marks
forall a. UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) String
repodir (RepoJob Marks -> IO Marks) -> RepoJob Marks -> IO Marks
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO Marks)
-> RepoJob Marks
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO Marks)
 -> RepoJob Marks)
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO Marks)
-> RepoJob Marks
forall a b. (a -> b) -> a -> b
$ \repo :: Repository rt p wR wU wR
repo -> Repository rt p wR wU wR -> Marks -> IO Marks
forall (rt :: RepoType) (p :: * -> * -> *) r u.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p r u r -> Marks -> IO Marks
fastExport' Repository rt p wR wU wR
repo Marks
marks
  case PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe String)
O.writeMarks [DarcsFlag]
opts of
    Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just f :: String
f  -> String -> Marks -> IO ()
writeMarks String
f Marks
newMarks

fastExport' :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
            => Repository rt p r u r -> Marks -> IO Marks
fastExport' :: Repository rt p r u r -> Marks -> IO Marks
fastExport' repo :: Repository rt p r u r
repo marks :: Marks
marks = do
  String -> IO ()
putStrLn "progress (reading repository)"
  PatchSet rt p Origin r
patchset <- Repository rt p r u r -> IO (PatchSet rt p Origin r)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p r u r
repo
  IORef Marks
marksref <- Marks -> IO (IORef Marks)
forall a. a -> IO (IORef a)
newIORef Marks
marks
  let patches :: FL (PatchInfoAnd rt p) Origin r
patches = PatchSet rt p Origin r -> FL (PatchInfoAnd rt p) Origin r
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin r
patchset
      tags :: [PatchInfo]
tags = PatchSet rt p Origin r -> [PatchInfo]
forall (rt :: RepoType) (p :: * -> * -> *) wS wX.
PatchSet rt p wS wX -> [PatchInfo]
inOrderTags PatchSet rt p Origin r
patchset
      mark :: (PatchInfoAnd rt p) x y -> Int -> TreeIO ()
      mark :: PatchInfoAnd rt p x y -> Int -> TreeIO ()
mark p :: PatchInfoAnd rt p x y
p n :: Int
n = IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "mark :" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
                             IORef Marks -> (Marks -> Marks) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Marks
marksref ((Marks -> Marks) -> IO ()) -> (Marks -> Marks) -> IO ()
forall a b. (a -> b) -> a -> b
$ \m :: Marks
m -> Marks -> Int -> ByteString -> Marks
addMark Marks
m Int
n (PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p)
      -- apply a single patch to build the working tree of the last exported version
      checkOne :: (RepoPatch p, ApplyState p ~ Tree)
               => Int -> (PatchInfoAnd rt p) x y -> TreeIO ()
      checkOne :: Int -> PatchInfoAnd rt p x y -> TreeIO ()
checkOne n :: Int
n p :: PatchInfoAnd rt p x y
p = do PatchInfoAnd rt p x y -> TreeIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PatchInfoAnd rt p x y
p
                        Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PatchInfo] -> PatchInfoAnd rt p x y -> Bool
forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x y
p Bool -> Bool -> Bool
||
                                (Marks -> Int -> Maybe ByteString
getMark Marks
marks Int
n Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p))) (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$
                          String -> TreeIO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TreeIO ()) -> String -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ "FATAL: Marks do not correspond: expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                 Maybe ByteString -> String
forall a. Show a => a -> String
show (Marks -> Int -> Maybe ByteString
getMark Marks
marks Int
n) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack (PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash PatchInfoAnd rt p x y
p)
      -- build the working tree of the last version exported by convert --export
      check :: (RepoPatch p, ApplyState p ~ Tree)
            => Int -> FL (PatchInfoAnd rt p) x y -> TreeIO (Int,  FlippedSeal( FL (PatchInfoAnd rt p)) y) 
      check :: Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check _ NilFL = (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall (m :: * -> *) a. Monad m => a -> m a
return (1, FL (PatchInfoAnd rt p) y y
-> FlippedSeal (FL (PatchInfoAnd rt p)) y
forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd rt p) y y
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
      check n :: Int
n allps :: FL (PatchInfoAnd rt p) x y
allps@(p :: PatchInfoAnd rt p x wY
p:>:ps :: FL (PatchInfoAnd rt p) wY y
ps)
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Marks -> Int
lastMark Marks
marks = Int -> PatchInfoAnd rt p x wY -> TreeIO ()
forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int -> PatchInfoAnd rt p x y -> TreeIO ()
checkOne Int
n PatchInfoAnd rt p x wY
p TreeIO ()
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int
-> FL (PatchInfoAnd rt p) wY y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check ([PatchInfo] -> Int -> PatchInfoAnd rt p x wY -> Int
forall (p :: * -> * -> *) (rt :: RepoType) x y.
Effect p =>
[PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd rt p x wY
p) FL (PatchInfoAnd rt p) wY y
ps
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Marks -> Int
lastMark Marks
marks = (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n, FL (PatchInfoAnd rt p) x y
-> FlippedSeal (FL (PatchInfoAnd rt p)) y
forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd rt p) x y
allps)
        | Marks -> Int
lastMark Marks
marks Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall (m :: * -> *) a. Monad m => a -> m a
return (1, FL (PatchInfoAnd rt p) x y
-> FlippedSeal (FL (PatchInfoAnd rt p)) y
forall (a :: * -> * -> *) wX wY. a wX wY -> FlippedSeal a wY
flipSeal FL (PatchInfoAnd rt p) x y
allps)
        | Bool
otherwise = TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
forall a. HasCallStack => a
undefined
  ((n :: Int
n, patches' :: FlippedSeal (FL (PatchInfoAnd rt p)) r
patches'), tree' :: Tree IO
tree') <- TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) r)
-> Tree IO
-> String
-> IO ((Int, FlippedSeal (FL (PatchInfoAnd rt p)) r), Tree IO)
forall a. TreeIO a -> Tree IO -> String -> IO (a, Tree IO)
hashedTreeIO (Int
-> FL (PatchInfoAnd rt p) Origin r
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) r)
forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO (Int, FlippedSeal (FL (PatchInfoAnd rt p)) y)
check 1 FL (PatchInfoAnd rt p) Origin r
patches) Tree IO
forall (m :: * -> *). Tree m
emptyTree (String
 -> IO ((Int, FlippedSeal (FL (PatchInfoAnd rt p)) r), Tree IO))
-> String
-> IO ((Int, FlippedSeal (FL (PatchInfoAnd rt p)) r), Tree IO)
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> "pristine.hashed"
  let patches'' :: FL (PatchInfoAnd rt p) wX r
patches'' = FlippedSeal (FL (PatchInfoAnd rt p)) r
-> FL (PatchInfoAnd rt p) wX r
forall (a :: * -> * -> *) wY wX. FlippedSeal a wY -> a wX wY
unsafeUnsealFlipped FlippedSeal (FL (PatchInfoAnd rt p)) r
patches'
  IO ((), Tree IO) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ((), Tree IO) -> IO ()) -> IO ((), Tree IO) -> IO ()
forall a b. (a -> b) -> a -> b
$ TreeIO () -> Tree IO -> String -> IO ((), Tree IO)
forall a. TreeIO a -> Tree IO -> String -> IO (a, Tree IO)
hashedTreeIO ([PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) Any r
-> TreeIO ()
forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
[PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
tags forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark Int
n FL (PatchInfoAnd rt p) Any r
forall wX. FL (PatchInfoAnd rt p) wX r
patches'') Tree IO
tree' (String -> IO ((), Tree IO)) -> String -> IO ((), Tree IO)
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> "pristine.hashed"
  IORef Marks -> IO Marks
forall a. IORef a -> IO a
readIORef IORef Marks
marksref
 IO Marks -> IO () -> IO Marks
forall a b. IO a -> IO b -> IO a
`finally` do
  String -> IO ()
putStrLn "progress (cleaning up)"
  Maybe String
current <- Repository rt p r u r -> IO (Maybe String)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Maybe String)
readHashedPristineRoot Repository rt p r u r
repo
  Cache -> HashedDir -> [String] -> IO ()
cleanHashdir (Repository rt p r u r -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p r u r
repo) HashedDir
HashedPristineDir ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String
current]
  String -> IO ()
putStrLn "progress done"

dumpPatches ::  (RepoPatch p, ApplyState p ~ Tree)
            =>  [PatchInfo]
            -> (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())
            -> Int -> FL (PatchInfoAnd rt p) x y -> TreeIO ()
dumpPatches :: [PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches _ _ _ NilFL = IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn "progress (patches converted)"
dumpPatches tags :: [PatchInfo]
tags mark :: forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark n :: Int
n (p :: PatchInfoAnd rt p x wY
p:>:ps :: FL (PatchInfoAnd rt p) wY y
ps) = do
  PatchInfoAnd rt p x wY -> TreeIO ()
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m ()
apply PatchInfoAnd rt p x wY
p
  if [PatchInfo] -> PatchInfoAnd rt p x wY -> Bool
forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x wY
p Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
     then PatchInfoAnd rt p x wY -> Int -> TreeIO ()
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpTag PatchInfoAnd rt p x wY
p Int
n
     else do (forall (p0 :: * -> * -> *) x0 y0.
 PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> PatchInfoAnd rt p x wY -> Int -> TreeIO ()
forall (rt :: RepoType) (p :: * -> * -> *) x y.
(forall (p0 :: * -> * -> *) x0 y0.
 PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpPatch forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark PatchInfoAnd rt p x wY
p Int
n
             [AnchoredPath] -> TreeIO ()
dumpFiles ([AnchoredPath] -> TreeIO ()) -> [AnchoredPath] -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ (String -> AnchoredPath) -> [String] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map String -> AnchoredPath
floatPath ([String] -> [AnchoredPath]) -> [String] -> [AnchoredPath]
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p x wY -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
listTouchedFiles PatchInfoAnd rt p x wY
p
  [PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) wY y
-> TreeIO ()
forall (p :: * -> * -> *) (rt :: RepoType) x y.
(RepoPatch p, ApplyState p ~ Tree) =>
[PatchInfo]
-> (forall (p0 :: * -> * -> *) x0 y0.
    PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> Int
-> FL (PatchInfoAnd rt p) x y
-> TreeIO ()
dumpPatches [PatchInfo]
tags forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark ([PatchInfo] -> Int -> PatchInfoAnd rt p x wY -> Int
forall (p :: * -> * -> *) (rt :: RepoType) x y.
Effect p =>
[PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next [PatchInfo]
tags Int
n PatchInfoAnd rt p x wY
p) FL (PatchInfoAnd rt p) wY y
ps

dumpTag :: (PatchInfoAnd rt p) x y  -> Int -> TreeIO () 
dumpTag :: PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpTag p :: PatchInfoAnd rt p x y
p n :: Int
n =
  [ByteString] -> TreeIO ()
dumpBits [ String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "progress TAG " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> String
cleanTagName PatchInfoAnd rt p x y
p
           , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> String
cleanTagName PatchInfoAnd rt p x y
p -- FIXME is this valid?
           , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "from :" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
           , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ["tagger", PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> String
patchAuthor PatchInfoAnd rt p x y
p, PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> String
patchDate PatchInfoAnd rt p x y
p]
           -- -3 == (-4 for "TAG " and +1 for newline)
           , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "data "
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length (PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- 3)
           , Int64 -> ByteString -> ByteString
BL.drop 4 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p ]
   where
     -- FIXME forbidden characters and subsequences in tags:
     -- https://www.kernel.org/pub/software/scm/git/docs/git-check-ref-format.html
     cleanTagName :: PatchInfoAnd rt p wA wB -> String
cleanTagName = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
cleanup (String -> String)
-> (PatchInfoAnd rt p wA wB -> String)
-> PatchInfoAnd rt p wA wB
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop 4 (String -> String)
-> (PatchInfoAnd rt p wA wB -> String)
-> PatchInfoAnd rt p wA wB
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> String
piName (PatchInfo -> String)
-> (PatchInfoAnd rt p wA wB -> PatchInfo)
-> PatchInfoAnd rt p wA wB
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p wA wB -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info
         where cleanup :: Char -> Char
cleanup x :: Char
x | Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
bad = '_'
                         | Bool
otherwise = Char
x
               bad :: String
               bad :: String
bad = " ~^:"

dumpFiles :: [AnchoredPath] -> TreeIO ()
dumpFiles :: [AnchoredPath] -> TreeIO ()
dumpFiles files :: [AnchoredPath]
files = [AnchoredPath] -> (AnchoredPath -> TreeIO ()) -> TreeIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AnchoredPath]
files ((AnchoredPath -> TreeIO ()) -> TreeIO ())
-> (AnchoredPath -> TreeIO ()) -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ \file :: AnchoredPath
file -> do
  let quotedPath :: String
quotedPath = String -> String
quotePath (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> AnchoredPath -> String
anchorPath "" AnchoredPath
file
  Bool
isfile <- AnchoredPath -> RWST AnchoredPath () (TreeState IO) IO Bool
forall (m :: * -> *). TreeRO m => AnchoredPath -> m Bool
fileExists AnchoredPath
file
  Bool
isdir <- AnchoredPath -> RWST AnchoredPath () (TreeState IO) IO Bool
forall (m :: * -> *). TreeRO m => AnchoredPath -> m Bool
directoryExists AnchoredPath
file
  Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isfile (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ do ByteString
bits <- AnchoredPath -> RWST AnchoredPath () (TreeState IO) IO ByteString
forall (m :: * -> *). TreeRO m => AnchoredPath -> m ByteString
readFile AnchoredPath
file
                   [ByteString] -> TreeIO ()
dumpBits [ String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "M 100644 inline " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
quotedPath
                            , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length ByteString
bits)
                            , ByteString
bits ]
  Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isdir (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ 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.
                  IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "D " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> AnchoredPath -> String
anchorPath "" AnchoredPath
file
                  Tree IO
tt <- (TreeState IO -> Tree IO)
-> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState IO -> Tree IO
forall (m :: * -> *). TreeState m -> Tree m
tree -- ick
                  let subs :: [AnchoredPath]
subs = [ AnchoredPath
file AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
n | (n :: Name
n, _) <-
                                  Tree IO -> [(Name, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate (Tree IO -> [(Name, TreeItem IO)])
-> Tree IO -> [(Name, TreeItem IO)]
forall a b. (a -> b) -> a -> b
$ Maybe (Tree IO) -> Tree IO
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Tree IO) -> Tree IO) -> Maybe (Tree IO) -> Tree IO
forall a b. (a -> b) -> a -> b
$ Tree IO -> AnchoredPath -> Maybe (Tree IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree Tree IO
tt AnchoredPath
file ]
                  [AnchoredPath] -> TreeIO ()
dumpFiles [AnchoredPath]
subs
  Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isfile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isdir) (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "D " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> AnchoredPath -> String
anchorPath "" AnchoredPath
file
  where
    -- |quotePath escapes and quotes paths containing newlines, double-quotes
    -- or backslashes.
    quotePath :: FilePath -> String
    quotePath :: String -> String
quotePath path :: String
path = case (Char -> (String, Bool) -> (String, Bool))
-> (String, Bool) -> String -> (String, Bool)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> (String, Bool) -> (String, Bool)
escapeChars ("", Bool
False) String
path of
        (_, False) -> String
path
        (path' :: String
path', True) -> String -> String
quote String
path'

    quote :: String -> String
quote str :: String
str = "\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\""

    escapeChars :: Char -> (String, Bool) -> (String, Bool)
escapeChars c :: Char
c (processed :: String
processed, haveEscaped :: Bool
haveEscaped) = case Char -> (String, Bool)
escapeChar Char
c of
        (escaped :: String
escaped, didEscape :: Bool
didEscape) ->
            (String
escaped String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
processed, Bool
didEscape Bool -> Bool -> Bool
|| Bool
haveEscaped)

    escapeChar :: Char -> (String, Bool)
escapeChar c :: Char
c = case Char
c of
        '\n' -> ("\\n", Bool
True)
        '\r' -> ("\\r", Bool
True)
        '"'  -> ("\\\"", Bool
True)
        '\\' -> ("\\\\", Bool
True)
        _    -> ([Char
c], Bool
False)


dumpPatch ::  (forall p0 x0 y0 . (PatchInfoAnd rt p0) x0 y0 -> Int -> TreeIO ())
          -> (PatchInfoAnd rt p) x y -> Int
          -> TreeIO ()
dumpPatch :: (forall (p0 :: * -> * -> *) x0 y0.
 PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ())
-> PatchInfoAnd rt p x y -> Int -> TreeIO ()
dumpPatch mark :: forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark p :: PatchInfoAnd rt p x y
p n :: Int
n =
  do [ByteString] -> TreeIO ()
dumpBits [ String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "progress " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInfo -> String
piName (PatchInfoAnd rt p x y -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
              , "commit refs/heads/master" ]
     PatchInfoAnd rt p x y -> Int -> TreeIO ()
forall (p0 :: * -> * -> *) x0 y0.
PatchInfoAnd rt p0 x0 y0 -> Int -> TreeIO ()
mark PatchInfoAnd rt p x y
p Int
n
     [ByteString] -> TreeIO ()
dumpBits [ String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "committer " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> String
patchAuthor PatchInfoAnd rt p x y
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInfoAnd rt p x y -> String
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> String
patchDate PatchInfoAnd rt p x y
p
              , String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show (ByteString -> Int64
BL.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p)
              , PatchInfoAnd rt p x y -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) x y.
PatchInfoAnd rt p x y -> ByteString
patchMessage PatchInfoAnd rt p x y
p ]
     Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1) (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> TreeIO ()
dumpBits [ String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "from :" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) ]

dumpBits :: [BL.ByteString] -> TreeIO ()
dumpBits :: [ByteString] -> TreeIO ()
dumpBits = IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ())
-> ([ByteString] -> IO ()) -> [ByteString] -> TreeIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
BLC.putStrLn (ByteString -> IO ())
-> ([ByteString] -> ByteString) -> [ByteString] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> ByteString
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 rt p) x y -> String
patchAuthor :: PatchInfoAnd rt p x y -> String
patchAuthor p :: PatchInfoAnd rt p x y
p
 | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
author = String -> String
unknownEmail "unknown"
 | Bool
otherwise = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='<') String
author of
               -- No name, but have email (nothing spanned)
               ("", email :: String
email) -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='@') (String -> String
forall a. [a] -> [a]
tail String
email) of
                   -- Not a real email address (no @).
                   (n :: String
n, "") -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='>') String
n of
                       (name :: String
name, _) -> String -> String
unknownEmail String
name
                   -- A "real" email address.
                   (user :: String
user, rest :: String
rest) -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '>') (String -> String
forall a. [a] -> [a]
tail String
rest) of
                       (dom :: String
dom, _) -> String -> String -> String
mkAuthor String
user (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
emailPad (String
user String -> String -> String
forall a. [a] -> [a] -> [a]
++ "@" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dom)
               -- No email (everything spanned)
               (_, "") -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='@') String
author of
                   (n :: String
n, "") -> String -> String
unknownEmail String
n
                   (name :: String
name, _) -> String -> String -> String
mkAuthor String
name (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
emailPad String
author
               -- Name and email
               (n :: String
n, rest :: String
rest) -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='>') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail String
rest of
                   (email :: String
email, _) -> String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
emailPad String
email
 where
   author :: String
author = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ PatchInfo -> String
piAuthor (PatchInfoAnd rt p x y -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
   unknownEmail :: String -> String
unknownEmail = (String -> String -> String) -> String -> String -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> String
mkAuthor "<unknown>"
   emailPad :: String -> String
emailPad email :: String
email = "<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
email String -> String -> String
forall a. [a] -> [a] -> [a]
++ ">"
   mkAuthor :: String -> String -> String
mkAuthor name :: String
name email :: String
email = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
email

patchDate :: (PatchInfoAnd rt p) x y -> String
patchDate :: PatchInfoAnd rt p x y -> String
patchDate = String -> UTCTime -> String
formatDateTime "%s +0000" (UTCTime -> String)
-> (PatchInfoAnd rt p x y -> UTCTime)
-> PatchInfoAnd rt p x y
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClockTime -> UTCTime
fromClockTime (ClockTime -> UTCTime)
-> (PatchInfoAnd rt p x y -> ClockTime)
-> PatchInfoAnd rt p x y
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CalendarTime -> ClockTime
toClockTime (CalendarTime -> ClockTime)
-> (PatchInfoAnd rt p x y -> CalendarTime)
-> PatchInfoAnd rt p x y
-> ClockTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  PatchInfo -> CalendarTime
piDate (PatchInfo -> CalendarTime)
-> (PatchInfoAnd rt p x y -> PatchInfo)
-> PatchInfoAnd rt p x y
-> CalendarTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p x y -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info

patchMessage :: (PatchInfoAnd rt p) x y -> BLU.ByteString
patchMessage :: PatchInfoAnd rt p x y -> ByteString
patchMessage p :: PatchInfoAnd rt p x y
p = [ByteString] -> ByteString
BL.concat [ String -> ByteString
BLU.fromString (PatchInfo -> String
piName (PatchInfo -> String) -> PatchInfo -> String
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p x y -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p)
                           , case [String] -> String
unlines ([String] -> String)
-> (PatchInfo -> [String]) -> PatchInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> [String]
piLog (PatchInfo -> String) -> PatchInfo -> String
forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p x y -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p x y
p of
                                 "" -> ByteString
BL.empty
                                 plog :: String
plog -> String -> ByteString
BLU.fromString ("\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
plog)
                           ]

type Marked = Maybe Int
type Branch = B.ByteString
type AuthorInfo = B.ByteString
type Message = B.ByteString
type Content = B.ByteString
type Tag = B.ByteString

data RefId = MarkId Int | HashId B.ByteString | Inline
           deriving Int -> RefId -> String -> String
[RefId] -> String -> String
RefId -> String
(Int -> RefId -> String -> String)
-> (RefId -> String) -> ([RefId] -> String -> String) -> Show RefId
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [RefId] -> String -> String
$cshowList :: [RefId] -> String -> String
show :: RefId -> String
$cshow :: RefId -> String
showsPrec :: Int -> RefId -> String -> String
$cshowsPrec :: Int -> RefId -> String -> String
Show

-- Newish (> 1.7.6.1) Git either quotes filenames or has two
-- non-special-char-containing paths. Older git doesn't do any quoting, so
-- we'll have to manually try and find the correct paths, when we use the
-- paths.
data CopyRenameNames = Quoted B.ByteString B.ByteString
                     | Unquoted B.ByteString deriving Int -> CopyRenameNames -> String -> String
[CopyRenameNames] -> String -> String
CopyRenameNames -> String
(Int -> CopyRenameNames -> String -> String)
-> (CopyRenameNames -> String)
-> ([CopyRenameNames] -> String -> String)
-> Show CopyRenameNames
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CopyRenameNames] -> String -> String
$cshowList :: [CopyRenameNames] -> String -> String
show :: CopyRenameNames -> String
$cshow :: CopyRenameNames -> String
showsPrec :: Int -> CopyRenameNames -> String -> String
$cshowsPrec :: Int -> CopyRenameNames -> String -> String
Show

data Object = Blob (Maybe Int) Content
            | Reset Branch (Maybe RefId)
            | Commit Branch Marked AuthorInfo Message
            | Tag Tag Int AuthorInfo Message
            | Modify (Either Int Content) B.ByteString -- (mark or content), filename
            | Gitlink B.ByteString
            | Copy CopyRenameNames
            | Rename CopyRenameNames
            | Delete B.ByteString -- filename
            | From Int
            | Merge Int
            | Progress B.ByteString
            | End
            deriving Int -> Object -> String -> String
[Object] -> String -> String
Object -> String
(Int -> Object -> String -> String)
-> (Object -> String)
-> ([Object] -> String -> String)
-> Show Object
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Object] -> String -> String
$cshowList :: [Object] -> String -> String
show :: Object -> String
$cshow :: Object -> String
showsPrec :: Int -> Object -> String -> String
$cshowsPrec :: Int -> Object -> String -> String
Show

type Ancestors = (Marked, [Int])
data State p where
  Toplevel :: Marked -> Branch -> State p
  InCommit :: Marked -> Ancestors -> Branch -> Tree IO -> RL (PrimOf p) cX cY -> PatchInfo -> State p
  Done :: State p

instance Show (State p) where
  show :: State p -> String
show Toplevel {} = "Toplevel"
  show InCommit {} = "InCommit"
  show Done =  "Done"

fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
fastImport _ opts :: [DarcsFlag]
opts [outrepo :: String
outrepo] =
  UMask -> IO () -> IO ()
forall a. UMask -> IO a -> IO a
withUMaskFlag (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO () -> IO ()
withNewDirectory String
outrepo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    EmptyRepository repo :: Repository ('RepoType 'NoRebase) p Origin Origin Origin
repo <- PatchFormat
-> WithWorkingDir
-> WithPatchIndex
-> UseCache
-> IO EmptyRepository
createRepository
      (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a PatchFormat
patchFormat (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a PatchFormat)
-> [DarcsFlag] -> PatchFormat
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimDarcsOption WithWorkingDir
withWorkingDir PrimDarcsOption WithWorkingDir -> [DarcsFlag] -> WithWorkingDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimDarcsOption WithPatchIndex
patchIndexNo PrimDarcsOption WithPatchIndex -> [DarcsFlag] -> WithPatchIndex
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    -- TODO implement --dry-run, which would be read-only?
    ()
marks <- Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> Marks -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) r u.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p r u r -> Marks -> IO ()
fastImport' Repository ('RepoType 'NoRebase) p Origin Origin Origin
repo Marks
emptyMarks
    Repository ('RepoType 'NoRebase) p Origin Origin Origin
-> String -> WithWorkingDir -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String -> WithWorkingDir -> IO ()
createPristineDirectoryTree Repository ('RepoType 'NoRebase) p Origin Origin Origin
repo "." (PrimDarcsOption WithWorkingDir
withWorkingDir PrimDarcsOption WithWorkingDir -> [DarcsFlag] -> WithWorkingDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
marks
fastImport _ _ _ = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "I need exactly one output repository."

fastImport' :: forall rt p r u . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
               Repository rt p r u r -> Marks -> IO ()
fastImport' :: Repository rt p r u r -> Marks -> IO ()
fastImport' repo :: Repository rt p r u r
repo marks :: Marks
marks = do
    Tree IO
pristine <- Repository rt p r u r -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p r u r
repo
    IORef Marks
marksref <- Marks -> IO (IORef Marks)
forall a. a -> IO (IORef a)
newIORef Marks
marks
    let initial :: State p
initial = Marked -> ByteString -> State p
forall (p :: * -> * -> *). Marked -> ByteString -> State p
Toplevel Marked
forall a. Maybe a
Nothing (ByteString -> State p) -> ByteString -> State p
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack "refs/branches/master"

        go :: State p -> B.ByteString -> TreeIO ()
        go :: State p -> ByteString -> TreeIO ()
go state :: State p
state rest :: ByteString
rest = do (rest' :: ByteString
rest', item :: Object
item) <- ByteString -> TreeIO (ByteString, Object)
parseObject ByteString
rest
                           State p
state' <- State p -> Object -> TreeIO (State p)
process State p
state Object
item
                           case State p
state' of
                             Done -> () -> TreeIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                             _ -> State p -> ByteString -> TreeIO ()
go State p
state' ByteString
rest'

        -- sort marks into buckets, since there can be a *lot* of them
        markpath :: Int -> AnchoredPath
        markpath :: Int -> AnchoredPath
markpath n :: Int
n = String -> AnchoredPath
floatPath (String
darcsdir String -> String -> String
</> "marks")
                        AnchoredPath -> Name -> AnchoredPath
`appendPath` (String -> Name
makeName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 1000))
                        AnchoredPath -> Name -> AnchoredPath
`appendPath` (String -> Name
makeName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 1000))

        makeinfo :: ByteString -> ByteString -> Bool -> m PatchInfo
makeinfo author :: ByteString
author message :: ByteString
message tag :: Bool
tag = do
          let (name :: String
name, log :: [String]
log) = case ByteString -> String
BC.unpack ByteString
message of
                                      "" -> ("Unnamed patch", [])
                                      msg :: String
msg -> ([String] -> String
forall a. [a] -> a
head ([String] -> String)
-> ([String] -> [String]) -> [String] -> (String, [String])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [String] -> [String]
forall a. [a] -> [a]
tail) ([String] -> (String, [String]))
-> (String -> [String]) -> String -> (String, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> (String, [String])) -> String -> (String, [String])
forall a b. (a -> b) -> a -> b
$ String
msg
              (author'' :: String
author'', date'' :: String
date'') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='>') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BC.unpack ByteString
author
              date' :: String
date' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ("0123456789" :: String)) String
date''
              author' :: String
author' = String
author'' String -> String -> String
forall a. [a] -> [a] -> [a]
++ ">"
              date :: String
date = String -> UTCTime -> String
formatDateTime "%Y%m%d%H%M%S" (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe UTCTime
startOfTime (String -> String -> Maybe UTCTime
parseDateTime "%s %z" String
date')
          IO PatchInfo -> m PatchInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PatchInfo -> m PatchInfo) -> IO PatchInfo -> m PatchInfo
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> [String] -> IO PatchInfo
patchinfo String
date (if Bool
tag then "TAG " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name else String
name) String
author' [String]
log

        addtag :: ByteString -> ByteString -> m ()
addtag author :: ByteString
author msg :: ByteString
msg =
          do PatchInfo
info_ <- ByteString -> ByteString -> Bool -> m PatchInfo
forall (m :: * -> *).
MonadIO m =>
ByteString -> ByteString -> Bool -> m PatchInfo
makeinfo ByteString
author ByteString
msg Bool
True
             Bool
gotany <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> "tentative_hashed_pristine"
             [PatchInfo]
deps <- if Bool
gotany then IO [PatchInfo] -> m [PatchInfo]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [PatchInfo] -> m [PatchInfo])
-> IO [PatchInfo] -> m [PatchInfo]
forall a b. (a -> b) -> a -> b
$
                                      PatchSet rt p Origin r -> [PatchInfo]
forall (rt :: RepoType) (p :: * -> * -> *) wS wX.
PatchSet rt p wS wX -> [PatchInfo]
getUncovered (PatchSet rt p Origin r -> [PatchInfo])
-> IO (PatchSet rt p Origin r) -> IO [PatchInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
                                        Repository rt p r u r -> String -> IO (PatchSet rt p Origin r)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> String -> IO (PatchSet rt p Origin wT)
readTentativeRepo Repository rt p r u r
repo (Repository rt p r u r -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p r u r
repo)
                               else [PatchInfo] -> m [PatchInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
             let ident :: FL (RepoPatchV2 Prim) cX cX
ident = forall cX. FL (RepoPatchV2 Prim) cX cX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL :: FL RepoPatchV2 cX cX
                 patch :: WrappedNamed rt (RepoPatchV2 Prim) wY wY
patch = Named (RepoPatchV2 Prim) wY wY
-> WrappedNamed rt (RepoPatchV2 Prim) wY wY
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
Named p wX wY -> WrappedNamed rt p wX wY
NormalP (Named (RepoPatchV2 Prim) wY wY
-> [PatchInfo] -> Named (RepoPatchV2 Prim) wY wY
forall (p :: * -> * -> *) wX wY.
Named p wX wY -> [PatchInfo] -> Named p wX wY
adddeps (PatchInfo
-> FL (RepoPatchV2 Prim) wY wY -> Named (RepoPatchV2 Prim) wY wY
forall (p :: * -> * -> *) wX wY.
PatchInfo -> FL p wX wY -> Named p wX wY
infopatch PatchInfo
info_ FL (RepoPatchV2 Prim) wY wY
forall cX. FL (RepoPatchV2 Prim) cX cX
ident) [PatchInfo]
deps)
             m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m String -> m ()) -> m String -> m ()
forall a b. (a -> b) -> a -> b
$ IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ Cache
-> Compression
-> PatchInfoAnd Any (RepoPatchV2 Prim) Any Any
-> IO String
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
Cache -> Compression -> PatchInfoAnd rt p wX wY -> IO String
addToTentativeInventory (Repository rt p r u r -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p r u r
repo)
                                                     Compression
GzipCompression (WrappedNamed Any (RepoPatchV2 Prim) Any Any
-> PatchInfoAnd Any (RepoPatchV2 Prim) Any Any
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY
n2pia WrappedNamed Any (RepoPatchV2 Prim) Any Any
forall (rt :: RepoType) wY.
WrappedNamed rt (RepoPatchV2 Prim) wY wY
patch)

        -- processing items
        updateHashes :: RWST AnchoredPath () (TreeState IO) IO (Tree IO)
updateHashes = do
          let nodarcs :: AnchoredPath -> p -> Bool
nodarcs = \(AnchoredPath (x :: Name
x:_)) _ -> Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> Name
makeName String
darcsdir
              hashblobs :: TreeItem m -> m (TreeItem m)
hashblobs (File blob :: Blob m
blob@(T.Blob con :: m ByteString
con NoHash)) =
                do Hash
hash <- ByteString -> Hash
sha256 (ByteString -> Hash) -> m ByteString -> m Hash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Blob m -> m ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob m
blob
                   TreeItem m -> m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeItem m -> m (TreeItem m)) -> TreeItem m -> m (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Blob m -> TreeItem m
forall (m :: * -> *). Blob m -> TreeItem m
File (m ByteString -> Hash -> Blob m
forall (m :: * -> *). m ByteString -> Hash -> Blob m
T.Blob m ByteString
con Hash
hash)
              hashblobs x :: TreeItem m
x = TreeItem m -> m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
x
          Tree IO
tree' <- IO (Tree IO) -> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree IO) -> RWST AnchoredPath () (TreeState IO) IO (Tree IO))
-> (Tree IO -> IO (Tree IO))
-> Tree IO
-> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TreeItem IO -> IO (TreeItem IO))
-> (AnchoredPath -> TreeItem IO -> Bool) -> Tree IO -> IO (Tree IO)
forall (m :: * -> *).
Monad m =>
(TreeItem m -> m (TreeItem m))
-> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m)
T.partiallyUpdateTree TreeItem IO -> IO (TreeItem IO)
forall (m :: * -> *). Monad m => TreeItem m -> m (TreeItem m)
hashblobs AnchoredPath -> TreeItem IO -> Bool
forall p. AnchoredPath -> p -> Bool
nodarcs (Tree IO -> RWST AnchoredPath () (TreeState IO) IO (Tree IO))
-> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
-> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (TreeState IO -> Tree IO)
-> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState IO -> Tree IO
forall (m :: * -> *). TreeState m -> Tree m
tree
          (TreeState IO -> TreeState IO) -> TreeIO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState IO -> TreeState IO) -> TreeIO ())
-> (TreeState IO -> TreeState IO) -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ \s :: TreeState IO
s -> TreeState IO
s { tree :: Tree IO
tree = Tree IO
tree' }
          Tree IO -> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO -> RWST AnchoredPath () (TreeState IO) IO (Tree IO))
-> Tree IO -> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> TreeItem IO -> Bool) -> Tree IO -> Tree IO
forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
T.filter AnchoredPath -> TreeItem IO -> Bool
forall p. AnchoredPath -> p -> Bool
nodarcs Tree IO
tree'

        -- Since git doesn't track directores it implicitly deletes
        -- them when they become empty. We should therefore remove any
        -- directories that become empty (except the repo-root
        -- directory!)
        deleteEmptyParents :: AnchoredPath -> f ()
deleteEmptyParents fp :: AnchoredPath
fp = do
          let directParent :: AnchoredPath
directParent = AnchoredPath -> AnchoredPath
parent AnchoredPath
fp
          Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AnchoredPath
directParent AnchoredPath -> AnchoredPath -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredPath
anchoredRoot) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ do
              Maybe (Tree m)
parentTree <- (Tree m -> AnchoredPath -> Maybe (Tree m))
-> AnchoredPath -> Tree m -> Maybe (Tree m)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Tree m -> AnchoredPath -> Maybe (Tree m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree AnchoredPath
directParent (Tree m -> Maybe (Tree m)) -> f (Tree m) -> f (Maybe (Tree m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Tree m) -> f (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree
              case ([(Name, TreeItem m)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(Name, TreeItem m)] -> Bool)
-> (Tree m -> [(Name, TreeItem m)]) -> Tree m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate) (Tree m -> Bool) -> Maybe (Tree m) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Tree m)
parentTree of
                      Just True -> do AnchoredPath -> f ()
forall (m :: * -> *). TreeRW m => AnchoredPath -> m ()
TM.unlink AnchoredPath
directParent
                                      AnchoredPath -> f ()
deleteEmptyParents AnchoredPath
directParent
                      -- Either missing (not possible) or non-empty.
                      _ -> () -> f ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        -- generate a Hunk primitive patch from diffing
        diffCurrent :: State p -> TreeIO (State p)
        diffCurrent :: State p -> TreeIO (State p)
diffCurrent (InCommit mark :: Marked
mark ancestors :: Ancestors
ancestors branch :: ByteString
branch start :: Tree IO
start ps :: RL (PrimOf p) cX cY
ps info_ :: PatchInfo
info_) = do
          Tree IO
current <- RWST AnchoredPath () (TreeState IO) IO (Tree IO)
updateHashes
          Sealed diff :: FL (PrimOf p) cY wX
diff <- FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) cY)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft (FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) cY))
-> RWST
     AnchoredPath () (TreeState IO) IO (FreeLeft (FL (PrimOf p)))
-> RWST
     AnchoredPath () (TreeState IO) IO (Sealed (FL (PrimOf p) cY))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
             IO (FreeLeft (FL (PrimOf p)))
-> RWST
     AnchoredPath () (TreeState IO) IO (FreeLeft (FL (PrimOf p)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (DiffAlgorithm
-> (String -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL (PrimOf p)))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
       (prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> (String -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
PatienceDiff (FileType -> String -> FileType
forall a b. a -> b -> a
const FileType
TextFile) Tree IO
start Tree IO
current)
          let newps :: RL (PrimOf p) cX wX
newps = RL (PrimOf p) cX cY
ps RL (PrimOf p) cX cY -> RL (PrimOf p) cY wX -> RL (PrimOf p) cX wX
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> RL a wY wZ -> RL a wX wZ
+<+ FL (PrimOf p) cY wX -> RL (PrimOf p) cY wX
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PrimOf p) cY wX
diff
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX wX
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Marked
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Marked
mark Ancestors
ancestors ByteString
branch Tree IO
current RL (PrimOf p) cX wX
newps PatchInfo
info_
        diffCurrent _ = String -> TreeIO (State p)
forall a. HasCallStack => String -> a
error "This is never valid outside of a commit."

        process :: State p -> Object -> TreeIO (State p)
        process :: State p -> Object -> TreeIO (State p)
process s :: State p
s (Progress p :: ByteString
p) = do
          IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn ("progress " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
decodeLocale ByteString
p)
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return State p
s

        process (Toplevel _ _) End = do
          Tree IO
tree' <- (IO (Tree IO) -> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree IO) -> RWST AnchoredPath () (TreeState IO) IO (Tree IO))
-> (Tree IO -> IO (Tree IO))
-> Tree IO
-> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsAddMissingHashes) (Tree IO -> RWST AnchoredPath () (TreeState IO) IO (Tree IO))
-> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
-> RWST AnchoredPath () (TreeState IO) IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RWST AnchoredPath () (TreeState IO) IO (Tree IO)
updateHashes
          (TreeState IO -> TreeState IO) -> TreeIO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState IO -> TreeState IO) -> TreeIO ())
-> (TreeState IO -> TreeState IO) -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ \s :: TreeState IO
s -> TreeState IO
s { tree :: Tree IO
tree = Tree IO
tree' } -- lets dump the right tree, without _darcs
          let root :: ByteString
root = Hash -> ByteString
encodeBase16 (Hash -> ByteString) -> Hash -> ByteString
forall a b. (a -> b) -> a -> b
$ Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree IO
tree'
          IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
putStrLn "\\o/ It seems we survived. Enjoy your new repo."
            String -> ByteString -> IO ()
B.writeFile (String
darcsdir String -> String -> String
</> "tentative_pristine") (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
              [ByteString] -> ByteString
BC.concat [String -> ByteString
BC.pack "pristine:", ByteString
root]
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return State p
forall (p :: * -> * -> *). State p
Done

        process (Toplevel n :: Marked
n b :: ByteString
b) (Tag tag :: ByteString
tag what :: Int
what author :: ByteString
author msg :: ByteString
msg) = do
          if Int -> Marked
forall a. a -> Maybe a
Just Int
what Marked -> Marked -> Bool
forall a. Eq a => a -> a -> Bool
== Marked
n
             then ByteString -> ByteString -> TreeIO ()
forall (m :: * -> *). MonadIO m => ByteString -> ByteString -> m ()
addtag ByteString
author ByteString
msg
             else IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                    "WARNING: Ignoring out-of-order tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
decodeLocale ByteString
tag
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (Marked -> ByteString -> State p
forall (p :: * -> * -> *). Marked -> ByteString -> State p
Toplevel Marked
n ByteString
b)

        process (Toplevel n :: Marked
n _) (Reset branch :: ByteString
branch from :: Maybe RefId
from) =
          do case Maybe RefId
from of
               (Just (MarkId k :: Int
k)) | Int -> Marked
forall a. a -> Maybe a
Just Int
k Marked -> Marked -> Bool
forall a. Eq a => a -> a -> Bool
== Marked
n ->
                 ByteString -> ByteString -> TreeIO ()
forall (m :: * -> *). MonadIO m => ByteString -> ByteString -> m ()
addtag (String -> ByteString
BC.pack "Anonymous Tagger <> 0 +0000") ByteString
branch
               _ -> IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "WARNING: Ignoring out-of-order tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                        ByteString -> String
BC.unpack ByteString
branch
             State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked -> ByteString -> State p
forall (p :: * -> * -> *). Marked -> ByteString -> State p
Toplevel Marked
n ByteString
branch

        process (Toplevel n :: Marked
n b :: ByteString
b) (Blob (Just m :: Int
m) bits :: ByteString
bits) = do
          AnchoredPath -> ByteString -> TreeIO ()
forall (m :: * -> *).
TreeRW m =>
AnchoredPath -> ByteString -> m ()
TM.writeFile (Int -> AnchoredPath
markpath Int
m) ([ByteString] -> ByteString
BLC.fromChunks [ByteString
bits])
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked -> ByteString -> State p
forall (p :: * -> * -> *). Marked -> ByteString -> State p
Toplevel Marked
n ByteString
b

        process x :: State p
x (Gitlink link :: ByteString
link) = do
          IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "WARNING: Ignoring gitlink " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack ByteString
link
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return State p
x

        process (Toplevel previous :: Marked
previous pbranch :: ByteString
pbranch) (Commit branch :: ByteString
branch mark :: Marked
mark author :: ByteString
author message :: ByteString
message) = do
          Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
pbranch ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
branch) (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ do
            IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn ("Tagging branch: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack ByteString
pbranch)
            ByteString -> ByteString -> TreeIO ()
forall (m :: * -> *). MonadIO m => ByteString -> ByteString -> m ()
addtag ByteString
author ByteString
pbranch
          PatchInfo
info_ <- ByteString
-> ByteString
-> Bool
-> RWST AnchoredPath () (TreeState IO) IO PatchInfo
forall (m :: * -> *).
MonadIO m =>
ByteString -> ByteString -> Bool -> m PatchInfo
makeinfo ByteString
author ByteString
message Bool
False
          Tree IO
startstate <- RWST AnchoredPath () (TreeState IO) IO (Tree IO)
updateHashes
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) Any Any
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Marked
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Marked
mark (Marked
previous, []) ByteString
branch Tree IO
startstate RL (PrimOf p) Any Any
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL PatchInfo
info_

        process s :: State p
s@InCommit {} (Modify (Left m :: Int
m) path :: ByteString
path) = do
          AnchoredPath -> AnchoredPath -> TreeIO ()
forall (m :: * -> *).
TreeRW m =>
AnchoredPath -> AnchoredPath -> m ()
TM.copy (Int -> AnchoredPath
markpath Int
m) (String -> AnchoredPath
floatPath (String -> AnchoredPath) -> String -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BC.unpack ByteString
path)
          State p -> TreeIO (State p)
diffCurrent State p
s

        process s :: State p
s@InCommit {} (Modify (Right bits :: ByteString
bits) path :: ByteString
path) = do
          AnchoredPath -> ByteString -> TreeIO ()
forall (m :: * -> *).
TreeRW m =>
AnchoredPath -> ByteString -> m ()
TM.writeFile (String -> AnchoredPath
floatPath (String -> AnchoredPath) -> String -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BC.unpack ByteString
path) ([ByteString] -> ByteString
BLC.fromChunks [ByteString
bits])
          State p -> TreeIO (State p)
diffCurrent State p
s

        process s :: State p
s@InCommit {} (Delete path :: ByteString
path) = do
          let floatedPath :: AnchoredPath
floatedPath = String -> AnchoredPath
floatPath (String -> AnchoredPath) -> String -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BC.unpack ByteString
path
          AnchoredPath -> TreeIO ()
forall (m :: * -> *). TreeRW m => AnchoredPath -> m ()
TM.unlink AnchoredPath
floatedPath
          AnchoredPath -> TreeIO ()
forall (f :: * -> *) (m :: * -> *).
(MonadState (TreeState m) f, TreeRW f) =>
AnchoredPath -> f ()
deleteEmptyParents AnchoredPath
floatedPath
          State p -> TreeIO (State p)
diffCurrent State p
s

        process (InCommit mark :: Marked
mark (prev :: Marked
prev, current :: [Int]
current) branch :: ByteString
branch start :: Tree IO
start ps :: RL (PrimOf p) cX cY
ps info_ :: PatchInfo
info_) (From from :: Int
from) =
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Marked
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Marked
mark (Marked
prev, Int
fromInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
current) ByteString
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_

        process (InCommit mark :: Marked
mark (prev :: Marked
prev, current :: [Int]
current) branch :: ByteString
branch start :: Tree IO
start ps :: RL (PrimOf p) cX cY
ps info_ :: PatchInfo
info_) (Merge from :: Int
from) =
          State p -> TreeIO (State p)
forall (m :: * -> *) a. Monad m => a -> m a
return (State p -> TreeIO (State p)) -> State p -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ Marked
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Marked
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Marked
mark (Marked
prev, Int
fromInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
current) ByteString
branch Tree IO
start RL (PrimOf p) cX cY
ps PatchInfo
info_

        process s :: State p
s@InCommit {} (Copy names :: CopyRenameNames
names) = do
            (from :: ByteString
from, to :: ByteString
to) <- CopyRenameNames -> TreeIO (ByteString, ByteString)
extractNames CopyRenameNames
names
            AnchoredPath -> AnchoredPath -> TreeIO ()
forall (m :: * -> *).
TreeRW m =>
AnchoredPath -> AnchoredPath -> m ()
TM.copy (String -> AnchoredPath
floatPath (String -> AnchoredPath) -> String -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BC.unpack ByteString
from) (String -> AnchoredPath
floatPath (String -> AnchoredPath) -> String -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BC.unpack ByteString
to)
            -- We can't tell Darcs that a file has been copied, so it'll
            -- show as an addfile.
            State p -> TreeIO (State p)
diffCurrent State p
s

        process s :: State p
s@(InCommit mark :: Marked
mark ancestors :: Ancestors
ancestors branch :: ByteString
branch start :: Tree IO
start _ info_ :: PatchInfo
info_) (Rename names :: CopyRenameNames
names) = do
          (from :: ByteString
from, to :: ByteString
to) <- CopyRenameNames -> TreeIO (ByteString, ByteString)
extractNames CopyRenameNames
names
          let uFrom :: String
uFrom = ByteString -> String
BC.unpack ByteString
from
              uTo :: String
uTo = ByteString -> String
BC.unpack ByteString
to
              parentDir :: AnchoredPath
parentDir = AnchoredPath -> AnchoredPath
parent (AnchoredPath -> AnchoredPath) -> AnchoredPath -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ String -> AnchoredPath
floatPath String
uTo
          Bool
targetDirExists <- IO Bool -> RWST AnchoredPath () (TreeState IO) IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RWST AnchoredPath () (TreeState IO) IO Bool)
-> IO Bool -> RWST AnchoredPath () (TreeState IO) IO Bool
forall a b. (a -> b) -> a -> b
$ Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
start String
uTo
          Bool
targetFileExists <- IO Bool -> RWST AnchoredPath () (TreeState IO) IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RWST AnchoredPath () (TreeState IO) IO Bool)
-> IO Bool -> RWST AnchoredPath () (TreeState IO) IO Bool
forall a b. (a -> b) -> a -> b
$ Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasFile Tree IO
start String
uTo
          Bool
parentDirExists <-
              IO Bool -> RWST AnchoredPath () (TreeState IO) IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RWST AnchoredPath () (TreeState IO) IO Bool)
-> IO Bool -> RWST AnchoredPath () (TreeState IO) IO Bool
forall a b. (a -> b) -> a -> b
$ Tree IO -> String -> IO Bool
forall (m :: * -> *). Monad m => Tree m -> String -> m Bool
treeHasDir Tree IO
start (String -> AnchoredPath -> String
anchorPath "" AnchoredPath
parentDir)
          -- If the target exists, remove it; if it doesn't, add all
          -- its parent directories.
          if Bool
targetDirExists Bool -> Bool -> Bool
|| Bool
targetFileExists
              then AnchoredPath -> TreeIO ()
forall (m :: * -> *). TreeRW m => AnchoredPath -> m ()
TM.unlink (AnchoredPath -> TreeIO ()) -> AnchoredPath -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> AnchoredPath
floatPath String
uTo
              else Bool -> TreeIO () -> TreeIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
parentDirExists (TreeIO () -> TreeIO ()) -> TreeIO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> TreeIO ()
forall (m :: * -> *). TreeRW m => AnchoredPath -> m ()
TM.createDirectory AnchoredPath
parentDir
          (InCommit _ _ _ _ newPs :: RL (PrimOf p) cX cY
newPs _) <- State p -> TreeIO (State p)
diffCurrent State p
s
          AnchoredPath -> AnchoredPath -> TreeIO ()
forall (m :: * -> *).
TreeRW m =>
AnchoredPath -> AnchoredPath -> m ()
TM.rename (String -> AnchoredPath
floatPath String
uFrom) (String -> AnchoredPath
floatPath String
uTo)
          let ps' :: RL (PrimOf p) cX wZ
ps' = RL (PrimOf p) cX cY
newPs RL (PrimOf p) cX cY -> PrimOf p cY wZ -> RL (PrimOf p) cX wZ
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: String -> String -> PrimOf p cY wZ
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
String -> String -> prim wX wY
move String
uFrom String
uTo
          Tree IO
current <- RWST AnchoredPath () (TreeState IO) IO (Tree IO)
updateHashes
          -- ensure empty dirs get deleted
          AnchoredPath -> TreeIO ()
forall (f :: * -> *) (m :: * -> *).
(MonadState (TreeState m) f, TreeRW f) =>
AnchoredPath -> f ()
deleteEmptyParents (String -> AnchoredPath
floatPath String
uFrom)
          -- run diffCurrent to add the dir deletions prims
          State p -> TreeIO (State p)
diffCurrent (Marked
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX Any
-> PatchInfo
-> State p
forall (p :: * -> * -> *) cX cY.
Marked
-> Ancestors
-> ByteString
-> Tree IO
-> RL (PrimOf p) cX cY
-> PatchInfo
-> State p
InCommit Marked
mark Ancestors
ancestors ByteString
branch Tree IO
current RL (PrimOf p) cX Any
forall wZ. RL (PrimOf p) cX wZ
ps' PatchInfo
info_)

        -- When we leave the commit, create a patch for the cumulated
        -- prims.
        process (InCommit mark :: Marked
mark ancestors :: Ancestors
ancestors branch :: ByteString
branch _ ps :: RL (PrimOf p) cX cY
ps info_ :: PatchInfo
info_) x :: Object
x = do
          case Ancestors
ancestors of
            (_, []) -> () -> TreeIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- OK, previous commit is the ancestor
            (Just n :: Int
n, list :: [Int]
list)
              | Int
n Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
list -> () -> TreeIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- OK, we base off one of the ancestors
              | Bool
otherwise -> IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                               "WARNING: Linearising non-linear ancestry:" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                               " currently at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", ancestors " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
list
            (Nothing, list :: [Int]
list) ->
              IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "WARNING: Linearising non-linear ancestry " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
list

          {- current <- updateHashes -} -- why not?
          (FL p cX cY
prims :: FL p cX cY)  <- FL p cX cY -> RWST AnchoredPath () (TreeState IO) IO (FL p cX cY)
forall (m :: * -> *) a. Monad m => a -> m a
return (FL p cX cY -> RWST AnchoredPath () (TreeState IO) IO (FL p cX cY))
-> FL p cX cY
-> RWST AnchoredPath () (TreeState IO) IO (FL p cX cY)
forall a b. (a -> b) -> a -> b
$ FL (PrimOf (FL p)) cX cY -> FL p cX cY
forall (p :: * -> * -> *) wX wY.
FromPrims p =>
FL (PrimOf p) wX wY -> p wX wY
fromPrims (FL (PrimOf (FL p)) cX cY -> FL p cX cY)
-> FL (PrimOf (FL p)) cX cY -> FL p cX cY
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) cX cY -> FL (PrimOf (FL p)) cX cY
forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
FL prim wX wY -> FL prim wX wY
sortCoalesceFL (FL (PrimOf p) cX cY -> FL (PrimOf (FL p)) cX cY)
-> FL (PrimOf p) cX cY -> FL (PrimOf (FL p)) cX cY
forall a b. (a -> b) -> a -> b
$ RL (PrimOf p) cX cY -> FL (PrimOf p) cX cY
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> FL a wX wZ
reverseRL RL (PrimOf p) cX cY
ps
          let patch :: WrappedNamed rt p cX cY
patch = Named p cX cY -> WrappedNamed rt p cX cY
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
Named p wX wY -> WrappedNamed rt p wX wY
NormalP (PatchInfo -> FL p cX cY -> Named p cX cY
forall (p :: * -> * -> *) wX wY.
PatchInfo -> FL p wX wY -> Named p wX wY
infopatch PatchInfo
info_ ((FL p cX cX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL :: FL p cX cX) FL p cX cX -> FL p cX cY -> FL p cX cY
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL p cX cY
prims))
          RWST AnchoredPath () (TreeState IO) IO String -> TreeIO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RWST AnchoredPath () (TreeState IO) IO String -> TreeIO ())
-> RWST AnchoredPath () (TreeState IO) IO String -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ IO String -> RWST AnchoredPath () (TreeState IO) IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> RWST AnchoredPath () (TreeState IO) IO String)
-> IO String -> RWST AnchoredPath () (TreeState IO) IO String
forall a b. (a -> b) -> a -> b
$ Cache -> Compression -> PatchInfoAnd Any p cX cY -> IO String
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
Cache -> Compression -> PatchInfoAnd rt p wX wY -> IO String
addToTentativeInventory (Repository rt p r u r -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p r u r
repo)
                                                  Compression
GzipCompression (WrappedNamed Any p cX cY -> PatchInfoAnd Any p cX cY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY
n2pia WrappedNamed Any p cX cY
forall (rt :: RepoType). WrappedNamed rt p cX cY
patch)
          case Marked
mark of
            Nothing -> () -> TreeIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just n :: Int
n -> case Marks -> Int -> Maybe ByteString
getMark Marks
marks Int
n of
              Nothing -> IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ IORef Marks -> (Marks -> Marks) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Marks
marksref ((Marks -> Marks) -> IO ()) -> (Marks -> Marks) -> IO ()
forall a b. (a -> b) -> a -> b
$ \m :: Marks
m -> Marks -> Int -> ByteString -> Marks
addMark Marks
m Int
n (PatchInfoAnd Any p cX cY -> ByteString
forall (rt :: RepoType) (p :: * -> * -> *) cX cY.
PatchInfoAnd rt p cX cY -> ByteString
patchHash (PatchInfoAnd Any p cX cY -> ByteString)
-> PatchInfoAnd Any p cX cY -> ByteString
forall a b. (a -> b) -> a -> b
$ WrappedNamed Any p cX cY -> PatchInfoAnd Any p cX cY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY
n2pia WrappedNamed Any p cX cY
forall (rt :: RepoType). WrappedNamed rt p cX cY
patch)
              Just n' :: ByteString
n' -> String -> TreeIO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TreeIO ()) -> String -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ "FATAL: Mark already exists: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack ByteString
n'
          State p -> Object -> TreeIO (State p)
process (Marked -> ByteString -> State p
forall (p :: * -> * -> *). Marked -> ByteString -> State p
Toplevel Marked
mark ByteString
branch) Object
x

        process state :: State p
state obj :: Object
obj = do
          IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ Object -> IO ()
forall a. Show a => a -> IO ()
print Object
obj
          String -> TreeIO (State p)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TreeIO (State p)) -> String -> TreeIO (State p)
forall a b. (a -> b) -> a -> b
$ "Unexpected object in state " String -> String -> String
forall a. [a] -> [a] -> [a]
++ State p -> String
forall a. Show a => a -> String
show State p
state

        extractNames :: CopyRenameNames
                     -> TreeIO (BC.ByteString, BC.ByteString)
        extractNames :: CopyRenameNames -> TreeIO (ByteString, ByteString)
extractNames names :: CopyRenameNames
names = case CopyRenameNames
names of
            Quoted f :: ByteString
f t :: ByteString
t -> (ByteString, ByteString) -> TreeIO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
f, ByteString
t)
            Unquoted uqNames :: ByteString
uqNames -> do
                let spaceIndices :: [Int]
spaceIndices = Char -> ByteString -> [Int]
BC.elemIndices ' ' ByteString
uqNames
                    splitStr :: Int -> (ByteString, ByteString)
splitStr = (ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> ByteString -> ByteString
BC.drop 1) ((ByteString, ByteString) -> (ByteString, ByteString))
-> (Int -> (ByteString, ByteString))
-> Int
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> ByteString -> (ByteString, ByteString))
-> ByteString -> Int -> (ByteString, ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> ByteString -> (ByteString, ByteString)
BC.splitAt ByteString
uqNames
                    -- Reverse the components, so we find the longest
                    -- prefix existing name.
                    spaceComponents :: [(ByteString, ByteString)]
spaceComponents = [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a]
reverse ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ (Int -> (ByteString, ByteString))
-> [Int] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (ByteString, ByteString)
splitStr [Int]
spaceIndices
                    componentCount :: Int
componentCount = [(ByteString, ByteString)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ByteString, ByteString)]
spaceComponents
                if Int
componentCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
                    then (ByteString, ByteString) -> TreeIO (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, ByteString) -> TreeIO (ByteString, ByteString))
-> (ByteString, ByteString) -> TreeIO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> (ByteString, ByteString)
forall a. [a] -> a
head [(ByteString, ByteString)]
spaceComponents
                    else do
                        let dieMessage :: String
dieMessage = [String] -> String
unwords
                                [ "Couldn't determine move/rename"
                                , "source/destination filenames, with the"
                                , "data produced by this (old) version of"
                                , "git, since it uses unquoted, but"
                                , "special-character-containing paths."
                                ]
                            floatUnpack :: ByteString -> AnchoredPath
floatUnpack = String -> AnchoredPath
floatPath (String -> AnchoredPath)
-> (ByteString -> String) -> ByteString -> AnchoredPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BC.unpack
                            lPathExists :: (ByteString, b) -> m Bool
lPathExists (l :: ByteString
l,_) =
                                AnchoredPath -> m Bool
forall (m :: * -> *). TreeRO m => AnchoredPath -> m Bool
TM.fileExists (AnchoredPath -> m Bool) -> AnchoredPath -> m Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> AnchoredPath
floatUnpack ByteString
l
                            finder :: [(ByteString, b)] -> m (ByteString, b)
finder [] = String -> m (ByteString, b)
forall a. HasCallStack => String -> a
error String
dieMessage
                            finder (x :: (ByteString, b)
x : rest :: [(ByteString, b)]
rest) = do
                                Bool
xExists <- (ByteString, b) -> m Bool
forall (m :: * -> *) b. TreeRO m => (ByteString, b) -> m Bool
lPathExists (ByteString, b)
x
                                if Bool
xExists then (ByteString, b) -> m (ByteString, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString, b)
x else [(ByteString, b)] -> m (ByteString, b)
finder [(ByteString, b)]
rest
                        [(ByteString, ByteString)] -> TreeIO (ByteString, ByteString)
forall (m :: * -> *) b.
TreeRO m =>
[(ByteString, b)] -> m (ByteString, b)
finder [(ByteString, ByteString)]
spaceComponents

    IO ((), Tree IO) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ((), Tree IO) -> IO ()) -> IO ((), Tree IO) -> IO ()
forall a b. (a -> b) -> a -> b
$ TreeIO () -> Tree IO -> String -> IO ((), Tree IO)
forall a. TreeIO a -> Tree IO -> String -> IO (a, Tree IO)
hashedTreeIO (State p -> ByteString -> TreeIO ()
go State p
forall (p :: * -> * -> *). State p
initial ByteString
B.empty) Tree IO
pristine (String -> IO ((), Tree IO)) -> String -> IO ((), Tree IO)
forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> "pristine.hashed"
    Repository rt p r u r -> UpdateWorking -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
finalizeRepositoryChanges Repository rt p r u r
repo UpdateWorking
YesUpdateWorking Compression
GzipCompression
    Repository rt p r u r -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanRepository Repository rt p r u r
repo

parseObject :: BC.ByteString -> TreeIO ( BC.ByteString, Object )
parseObject :: ByteString -> TreeIO (ByteString, Object)
parseObject = (ByteString -> Result (Maybe Object))
-> ByteString -> TreeIO (ByteString, Object)
next' ByteString -> Result (Maybe Object)
mbObject
  where mbObject :: ByteString -> Result (Maybe Object)
mbObject = Parser (Maybe Object) -> ByteString -> Result (Maybe Object)
forall a. Parser a -> ByteString -> Result a
A.parse Parser (Maybe Object)
p_maybeObject

        p_maybeObject :: Parser (Maybe Object)
p_maybeObject = Object -> Maybe Object
forall a. a -> Maybe a
Just (Object -> Maybe Object)
-> Parser ByteString Object -> Parser (Maybe Object)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Object
p_object
                        Parser (Maybe Object)
-> Parser (Maybe Object) -> Parser (Maybe Object)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput Parser ByteString ()
-> Parser (Maybe Object) -> Parser (Maybe Object)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Object -> Parser (Maybe Object)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Object
forall a. Maybe a
Nothing)

        lex :: Parser ByteString b -> Parser ByteString b
lex p :: Parser ByteString b
p = Parser ByteString b
p Parser ByteString b
-> (b -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: b
x -> Parser ByteString ()
A.skipSpace Parser ByteString () -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Parser ByteString b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
        lexString :: String -> Parser ByteString ()
lexString s :: String
s = ByteString -> Parser ByteString
A.string (String -> ByteString
BC.pack String
s) Parser ByteString -> Parser ByteString () -> Parser ByteString ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString ()
A.skipSpace
        line :: Parser ByteString
line = Parser ByteString -> Parser ByteString
forall b. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString -> Parser ByteString)
-> Parser ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString
A.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='\n')

        optional :: f a -> f (Maybe a)
optional p :: f a
p = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> f a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` f a
p f (Maybe a) -> f (Maybe a) -> f (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a -> f (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

        p_object :: Parser ByteString Object
p_object = Parser ByteString Object
p_blob
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_reset
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_commit
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_tag
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_modify
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_rename
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_copy
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_from
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_merge
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Object
p_delete
                   Parser ByteString Object
-> Parser ByteString Object -> Parser ByteString Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> Parser ByteString ()
lexString "progress" Parser ByteString ()
-> Parser ByteString Object -> Parser ByteString Object
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Object
Progress (ByteString -> Object)
-> Parser ByteString -> Parser ByteString Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString
line)

        p_author :: String -> Parser ByteString
p_author name :: String
name = String -> Parser ByteString ()
lexString String
name Parser ByteString () -> Parser ByteString -> Parser ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString
line

        p_reset :: Parser ByteString Object
p_reset = do String -> Parser ByteString ()
lexString "reset"
                     ByteString
branch <- Parser ByteString
line
                     Maybe RefId
refid <- Parser ByteString RefId -> Parser ByteString (Maybe RefId)
forall (f :: * -> *) a.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional (Parser ByteString RefId -> Parser ByteString (Maybe RefId))
-> Parser ByteString RefId -> Parser ByteString (Maybe RefId)
forall a b. (a -> b) -> a -> b
$ String -> Parser ByteString ()
lexString "from" Parser ByteString ()
-> Parser ByteString RefId -> Parser ByteString RefId
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString RefId
p_refid
                     Object -> Parser ByteString Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe RefId -> Object
Reset ByteString
branch Maybe RefId
refid

        p_commit :: Parser ByteString Object
p_commit = do String -> Parser ByteString ()
lexString "commit"
                      ByteString
branch <- Parser ByteString
line
                      Marked
mark <- Parser ByteString Int -> Parser ByteString Marked
forall (f :: * -> *) a.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional Parser ByteString Int
p_mark
                      Maybe ByteString
_ <- Parser ByteString -> Parser ByteString (Maybe ByteString)
forall (f :: * -> *) a.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional (Parser ByteString -> Parser ByteString (Maybe ByteString))
-> Parser ByteString -> Parser ByteString (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ String -> Parser ByteString
p_author "author"
                      ByteString
committer <- String -> Parser ByteString
p_author "committer"
                      ByteString
message <- Parser ByteString
p_data
                      Object -> Parser ByteString Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ ByteString -> Marked -> ByteString -> ByteString -> Object
Commit ByteString
branch Marked
mark ByteString
committer ByteString
message

        p_tag :: Parser ByteString Object
p_tag = do ()
_ <- String -> Parser ByteString ()
lexString "tag"
                   ByteString
tag <- Parser ByteString
line
                   String -> Parser ByteString ()
lexString "from"
                   Int
mark <- Parser ByteString Int
p_marked
                   ByteString
author <- String -> Parser ByteString
p_author "tagger"
                   ByteString
message <- Parser ByteString
p_data
                   Object -> Parser ByteString Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> ByteString -> ByteString -> Object
Tag ByteString
tag Int
mark ByteString
author ByteString
message

        p_blob :: Parser ByteString Object
p_blob = do String -> Parser ByteString ()
lexString "blob"
                    Marked
mark <- Parser ByteString Int -> Parser ByteString Marked
forall (f :: * -> *) a.
(Alternative f, Monad f) =>
f a -> f (Maybe a)
optional Parser ByteString Int
p_mark
                    Marked -> ByteString -> Object
Blob Marked
mark (ByteString -> Object)
-> Parser ByteString -> Parser ByteString Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString
p_data
                  Parser ByteString Object -> String -> Parser ByteString Object
forall i a. Parser i a -> String -> Parser i a
<?> "p_blob"

        p_mark :: Parser ByteString Int
p_mark = do String -> Parser ByteString ()
lexString "mark"
                    Parser ByteString Int
p_marked
                  Parser ByteString Int -> String -> Parser ByteString Int
forall i a. Parser i a -> String -> Parser i a
<?> "p_mark"

        p_refid :: Parser ByteString RefId
p_refid = Int -> RefId
MarkId (Int -> RefId) -> Parser ByteString Int -> Parser ByteString RefId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Int
p_marked
                  Parser ByteString RefId
-> Parser ByteString RefId -> Parser ByteString RefId
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> Parser ByteString ()
lexString "inline" Parser ByteString ()
-> Parser ByteString RefId -> Parser ByteString RefId
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RefId -> Parser ByteString RefId
forall (m :: * -> *) a. Monad m => a -> m a
return RefId
Inline)
                  Parser ByteString RefId
-> Parser ByteString RefId -> Parser ByteString RefId
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> RefId
HashId (ByteString -> RefId)
-> Parser ByteString -> Parser ByteString RefId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString
p_hash

        p_data :: Parser ByteString
p_data = do String -> Parser ByteString ()
lexString "data"
                    Int
len <- Parser ByteString Int
forall a. Integral a => Parser a
A.decimal
                    Char
_ <- Char -> Parser Char
A.char '\n'
                    Parser ByteString -> Parser ByteString
forall b. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString -> Parser ByteString)
-> Parser ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Parser ByteString
A.take Int
len
                  Parser ByteString -> String -> Parser ByteString
forall i a. Parser i a -> String -> Parser i a
<?> "p_data"

        p_marked :: Parser ByteString Int
p_marked = Parser ByteString Int -> Parser ByteString Int
forall b. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString Int -> Parser ByteString Int)
-> Parser ByteString Int -> Parser ByteString Int
forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
A.char ':' Parser Char -> Parser ByteString Int -> Parser ByteString Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString Int
forall a. Integral a => Parser a
A.decimal
        p_hash :: Parser ByteString
p_hash = Parser ByteString -> Parser ByteString
forall b. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString -> Parser ByteString)
-> Parser ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString
A.takeWhile1 (String -> Char -> Bool
A.inClass "0123456789abcdefABCDEF")
        p_from :: Parser ByteString Object
p_from = String -> Parser ByteString ()
lexString "from" Parser ByteString ()
-> Parser ByteString Object -> Parser ByteString Object
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Object
From (Int -> Object)
-> Parser ByteString Int -> Parser ByteString Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Int
p_marked
        p_merge :: Parser ByteString Object
p_merge = String -> Parser ByteString ()
lexString "merge" Parser ByteString ()
-> Parser ByteString Object -> Parser ByteString Object
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Object
Merge (Int -> Object)
-> Parser ByteString Int -> Parser ByteString Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString Int
p_marked
        p_delete :: Parser ByteString Object
p_delete = String -> Parser ByteString ()
lexString "D" Parser ByteString ()
-> Parser ByteString Object -> Parser ByteString Object
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Object
Delete (ByteString -> Object)
-> Parser ByteString -> Parser ByteString Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString
p_maybeQuotedName
        p_rename :: Parser ByteString Object
p_rename = do String -> Parser ByteString ()
lexString "R"
                      CopyRenameNames
names <- Parser ByteString CopyRenameNames
p_maybeQuotedCopyRenameNames
                      Object -> Parser ByteString Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ CopyRenameNames -> Object
Rename CopyRenameNames
names
        p_copy :: Parser ByteString Object
p_copy = do String -> Parser ByteString ()
lexString "C"
                    CopyRenameNames
names <- Parser ByteString CopyRenameNames
p_maybeQuotedCopyRenameNames
                    Object -> Parser ByteString Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ CopyRenameNames -> Object
Copy CopyRenameNames
names
        p_modify :: Parser ByteString Object
p_modify = do String -> Parser ByteString ()
lexString "M"
                      ByteString
mode <- Parser ByteString -> Parser ByteString
forall b. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString -> Parser ByteString)
-> Parser ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString
A.takeWhile (String -> Char -> Bool
A.inClass "01234567890")
                      RefId
mark <- Parser ByteString RefId
p_refid
                      ByteString
path <- Parser ByteString
p_maybeQuotedName
                      case RefId
mark of
                        HashId hash :: ByteString
hash | ByteString
mode ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack "160000" -> Object -> Parser ByteString Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ ByteString -> Object
Gitlink ByteString
hash
                                    | Bool
otherwise -> String -> Parser ByteString Object
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ":(("
                        MarkId n :: Int
n -> Object -> Parser ByteString Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ Either Int ByteString -> ByteString -> Object
Modify (Int -> Either Int ByteString
forall a b. a -> Either a b
Left Int
n) ByteString
path
                        Inline -> do ByteString
bits <- Parser ByteString
p_data
                                     Object -> Parser ByteString Object
forall (m :: * -> *) a. Monad m => a -> m a
return (Object -> Parser ByteString Object)
-> Object -> Parser ByteString Object
forall a b. (a -> b) -> a -> b
$ Either Int ByteString -> ByteString -> Object
Modify (ByteString -> Either Int ByteString
forall a b. b -> Either a b
Right ByteString
bits) ByteString
path
        p_maybeQuotedCopyRenameNames :: Parser ByteString CopyRenameNames
p_maybeQuotedCopyRenameNames =
            Parser ByteString CopyRenameNames
p_lexTwoQuotedNames Parser ByteString CopyRenameNames
-> Parser ByteString CopyRenameNames
-> Parser ByteString CopyRenameNames
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> CopyRenameNames
Unquoted (ByteString -> CopyRenameNames)
-> Parser ByteString -> Parser ByteString CopyRenameNames
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser ByteString
line
        p_lexTwoQuotedNames :: Parser ByteString CopyRenameNames
p_lexTwoQuotedNames = do
            ByteString
n1 <- Parser ByteString -> Parser ByteString
forall b. Parser ByteString b -> Parser ByteString b
lex Parser ByteString
p_quotedName
            ByteString
n2 <- Parser ByteString -> Parser ByteString
forall b. Parser ByteString b -> Parser ByteString b
lex Parser ByteString
p_quotedName
            CopyRenameNames -> Parser ByteString CopyRenameNames
forall (m :: * -> *) a. Monad m => a -> m a
return (CopyRenameNames -> Parser ByteString CopyRenameNames)
-> CopyRenameNames -> Parser ByteString CopyRenameNames
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> CopyRenameNames
Quoted ByteString
n1 ByteString
n2
        p_maybeQuotedName :: Parser ByteString
p_maybeQuotedName = Parser ByteString -> Parser ByteString
forall b. Parser ByteString b -> Parser ByteString b
lex (Parser ByteString
p_quotedName Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString
line)
        p_quotedName :: Parser ByteString
p_quotedName = do
          Char
_ <- Char -> Parser Char
A.char '"'
          -- Take until a non-escaped " character.
          ByteString
name <- Maybe Char
-> (Maybe Char -> Char -> Maybe (Maybe Char)) -> Parser ByteString
forall s. s -> (s -> Char -> Maybe s) -> Parser ByteString
A.scan Maybe Char
forall a. Maybe a
Nothing
            (\previous :: Maybe Char
previous char :: Char
char -> if Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '"' Bool -> Bool -> Bool
&& Maybe Char
previous Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> Maybe Char
forall a. a -> Maybe a
Just '\\'
               then Maybe (Maybe Char)
forall a. Maybe a
Nothing else Maybe Char -> Maybe (Maybe Char)
forall a. a -> Maybe a
Just (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
char))
          Char
_ <- Char -> Parser Char
A.char '"'
          ByteString -> Parser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Parser ByteString)
-> ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
unescape ByteString
name


        next' :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)
        next' :: (ByteString -> Result (Maybe Object))
-> ByteString -> TreeIO (ByteString, Object)
next' parser :: ByteString -> Result (Maybe Object)
parser rest :: ByteString
rest =
          do ByteString
chunk <- if ByteString -> Bool
B.null ByteString
rest then IO ByteString -> RWST AnchoredPath () (TreeState IO) IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString
 -> RWST AnchoredPath () (TreeState IO) IO ByteString)
-> IO ByteString
-> RWST AnchoredPath () (TreeState IO) IO ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Int -> IO ByteString
B.hGet Handle
stdin (64 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1024)
                                     else ByteString -> RWST AnchoredPath () (TreeState IO) IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
rest
             (ByteString -> Result (Maybe Object))
-> ByteString -> TreeIO (ByteString, Object)
next_chunk ByteString -> Result (Maybe Object)
parser ByteString
chunk

        next_chunk :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)
        next_chunk :: (ByteString -> Result (Maybe Object))
-> ByteString -> TreeIO (ByteString, Object)
next_chunk parser :: ByteString -> Result (Maybe Object)
parser chunk :: ByteString
chunk =
          case ByteString -> Result (Maybe Object)
parser ByteString
chunk of
             A.Done rest :: ByteString
rest result :: Maybe Object
result -> (ByteString, Object) -> TreeIO (ByteString, Object)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
rest, Object -> (Object -> Object) -> Maybe Object -> Object
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Object
End Object -> Object
forall a. a -> a
id Maybe Object
result) -- not sure about the maybe
             A.Partial cont :: ByteString -> Result (Maybe Object)
cont -> (ByteString -> Result (Maybe Object))
-> ByteString -> TreeIO (ByteString, Object)
next' ByteString -> Result (Maybe Object)
cont ByteString
B.empty
             A.Fail _ ctx :: [String]
ctx err :: String
err -> do
               IO () -> TreeIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TreeIO ()) -> IO () -> TreeIO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "=== chunk ===\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack ByteString
chunk String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n=== end chunk ===="
               String -> TreeIO (ByteString, Object)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TreeIO (ByteString, Object))
-> String -> TreeIO (ByteString, Object)
forall a b. (a -> b) -> a -> b
$ "Error parsing stream. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\nContext: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
ctx


patchHash :: PatchInfoAnd rt p cX cY -> BC.ByteString
patchHash :: PatchInfoAnd rt p cX cY -> ByteString
patchHash p :: PatchInfoAnd rt p cX cY
p = String -> ByteString
BC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SHA1 -> String
forall a. Show a => a -> String
show (SHA1 -> String) -> SHA1 -> String
forall a b. (a -> b) -> a -> b
$ PatchInfo -> SHA1
makePatchname (PatchInfoAnd rt p cX cY -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p cX cY
p)

inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag :: [PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag tags :: [PatchInfo]
tags p :: PatchInfoAnd rt p wX wZ
p = PatchInfo -> Bool
isTag (PatchInfoAnd rt p wX wZ -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wX wZ
p) Bool -> Bool -> Bool
&& PatchInfoAnd rt p wX wZ -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wX wZ
p PatchInfo -> [PatchInfo] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PatchInfo]
tags Bool -> Bool -> Bool
&& FL (PrimOf p) wX wZ -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL (PatchInfoAnd rt p wX wZ -> FL (PrimOf (PatchInfoAnd rt p)) wX wZ
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect PatchInfoAnd rt p wX wZ
p)

next :: (Effect p) => [PatchInfo] -> Int ->  PatchInfoAnd rt p x y -> Int
next :: [PatchInfo] -> Int -> PatchInfoAnd rt p x y -> Int
next tags :: [PatchInfo]
tags n :: Int
n p :: PatchInfoAnd rt p x y
p = if [PatchInfo] -> PatchInfoAnd rt p x y -> Bool
forall (p :: * -> * -> *) (rt :: RepoType) wX wZ.
Effect p =>
[PatchInfo] -> PatchInfoAnd rt p wX wZ -> Bool
inOrderTag [PatchInfo]
tags PatchInfoAnd rt p x y
p then Int
n else Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

inOrderTags :: PatchSet rt p wS wX -> [PatchInfo]
inOrderTags :: PatchSet rt p wS wX -> [PatchInfo]
inOrderTags (PatchSet ts :: RL (Tagged rt p) wS wX
ts _) = RL (Tagged rt p) wS wX -> [PatchInfo]
forall (rt :: RepoType) (t1 :: * -> * -> *) wT wY.
RL (Tagged rt t1) wT wY -> [PatchInfo]
go RL (Tagged rt p) wS wX
ts
  where go :: RL(Tagged rt t1) wT wY -> [PatchInfo]
        go :: RL (Tagged rt t1) wT wY -> [PatchInfo]
go (ts' :: RL (Tagged rt t1) wT wY
ts' :<: Tagged t :: PatchInfoAnd rt t1 wY wY
t _ _) = PatchInfoAnd rt t1 wY wY -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info PatchInfoAnd rt t1 wY wY
t PatchInfo -> [PatchInfo] -> [PatchInfo]
forall a. a -> [a] -> [a]
: RL (Tagged rt t1) wT wY -> [PatchInfo]
forall (rt :: RepoType) (t1 :: * -> * -> *) wT wY.
RL (Tagged rt t1) wT wY -> [PatchInfo]
go RL (Tagged rt t1) wT wY
ts'
        go NilRL = []

type Marks = M.IntMap BC.ByteString

emptyMarks :: Marks
emptyMarks :: Marks
emptyMarks = Marks
forall a. IntMap a
M.empty

lastMark :: Marks -> Int
lastMark :: Marks -> Int
lastMark m :: Marks
m = if Marks -> Bool
forall a. IntMap a -> Bool
M.null Marks
m then 0 else (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst ((Int, ByteString) -> Int) -> (Int, ByteString) -> Int
forall a b. (a -> b) -> a -> b
$ Marks -> (Int, ByteString)
forall a. IntMap a -> (Int, a)
M.findMax Marks
m

getMark :: Marks -> Int -> Maybe BC.ByteString
getMark :: Marks -> Int -> Maybe ByteString
getMark marks :: Marks
marks key :: Int
key = Int -> Marks -> Maybe ByteString
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
key Marks
marks

addMark :: Marks -> Int -> BC.ByteString -> Marks
addMark :: Marks -> Int -> ByteString -> Marks
addMark marks :: Marks
marks key :: Int
key value :: ByteString
value = Int -> ByteString -> Marks -> Marks
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
key ByteString
value Marks
marks

readMarks :: FilePath -> IO Marks
readMarks :: String -> IO Marks
readMarks p :: String
p = do [ByteString]
lines' <- Char -> ByteString -> [ByteString]
BC.split '\n' (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO ByteString
BC.readFile String
p
                 Marks -> IO Marks
forall (m :: * -> *) a. Monad m => a -> m a
return (Marks -> IO Marks) -> Marks -> IO Marks
forall a b. (a -> b) -> a -> b
$ (Marks -> ByteString -> Marks) -> Marks -> [ByteString] -> Marks
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Marks -> ByteString -> Marks
merge Marks
forall a. IntMap a
M.empty [ByteString]
lines'
               IO Marks -> IO Marks -> IO Marks
forall a. IO a -> IO a -> IO a
`catchall` Marks -> IO Marks
forall (m :: * -> *) a. Monad m => a -> m a
return Marks
emptyMarks
  where merge :: Marks -> ByteString -> Marks
merge set :: Marks
set line :: ByteString
line = case Char -> ByteString -> [ByteString]
BC.split ':' ByteString
line of
          [i :: ByteString
i, hash :: ByteString
hash] -> Int -> ByteString -> Marks -> Marks
forall a. Int -> a -> IntMap a -> IntMap a
M.insert (String -> Int
forall a. Read a => String -> a
read (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BC.unpack ByteString
i) ((Char -> Bool) -> ByteString -> ByteString
BC.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') ByteString
hash) Marks
set
          _ -> Marks
set -- ignore, although it is maybe not such a great idea...

writeMarks :: FilePath -> Marks -> IO ()
writeMarks :: String -> Marks -> IO ()
writeMarks fp :: String
fp m :: Marks
m = do String -> IO ()
removeFile String
fp IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- unlink
                     String -> ByteString -> IO ()
BC.writeFile String
fp ByteString
marks
  where marks :: ByteString
marks = [ByteString] -> ByteString
BC.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ((Int, ByteString) -> ByteString)
-> [(Int, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Int, ByteString) -> ByteString
forall a. Show a => (a, ByteString) -> ByteString
format ([(Int, ByteString)] -> [ByteString])
-> [(Int, ByteString)] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Marks -> [(Int, ByteString)]
forall a. IntMap a -> [(Int, a)]
M.assocs Marks
m
        format :: (a, ByteString) -> ByteString
format (k :: a
k, s :: ByteString
s) = [ByteString] -> ByteString
BC.concat [String -> ByteString
BC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
k, String -> ByteString
BC.pack ": ", ByteString
s, String -> ByteString
BC.pack "\n"]

-- |unescape turns \r \n \" \\ into their unescaped form, leaving any
-- other \-preceeded characters as they are.
unescape :: BC.ByteString -> BC.ByteString
unescape :: ByteString -> ByteString
unescape cs :: ByteString
cs = case ByteString -> Maybe (Char, ByteString)
BC.uncons ByteString
cs of
  Nothing -> ByteString
BC.empty
  Just (c' :: Char
c', cs' :: ByteString
cs') -> if Char
c' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\\'
    then case ByteString -> Maybe (Char, ByteString)
BC.uncons ByteString
cs' of
      Nothing -> ByteString
BC.empty
      Just (c'' :: Char
c'', cs'' :: ByteString
cs'') -> let unescapedC :: Char
unescapedC = case Char
c'' of
                                'r'  -> '\r'
                                'n'  -> '\n'
                                '"'  -> '"'
                                '\\' -> '\\'
                                x :: Char
x    -> Char
x in
        Char -> ByteString -> ByteString
BC.cons Char
unescapedC (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
unescape ByteString
cs''
    else Char -> ByteString -> ByteString
BC.cons Char
c' (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
unescape ByteString
cs'