%  Copyright (C) 2002-2005,2007 David Roundy
%
%  This program is free software; you can redistribute it and/or modify
%  it under the terms of the GNU General Public License as published by
%  the Free Software Foundation; either version 2, or (at your option)
%  any later version.
%
%  This program is distributed in the hope that it will be useful,
%  but WITHOUT ANY WARRANTY; without even the implied warranty of
%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
%  GNU General Public License for more details.
%
%  You should have received a copy of the GNU General Public License
%  along with this program; see the file COPYING.  If not, write to
%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
%  Boston, MA 02110-1301, USA.

\darcsCommand{convert}
\begin{code}
{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
{-# LANGUAGE CPP #-}
-- , MagicHash #-}

#include "gadts.h"

module Darcs.Commands.Convert ( convert ) where

import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,
                   createDirectory )
import Workaround ( getCurrentDirectory )
import Control.Monad ( when )
import GHC.Base ( unsafeCoerce# )
import Data.Maybe ( catMaybes )

import Darcs.Hopefully ( PatchInfoAnd, n2pia, info, hopefully )
import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo, putVerbose )
import Darcs.Arguments
   ( DarcsFlag
      ( AllowConflicts, NewRepo, SetScriptsExecutable, UseFormat2
      , NoUpdateWorking, NoLinks
      )
   , reponame
   , setScriptsExecutableOption
   , networkOptions
   )
import Darcs.Repository ( Repository, withRepoLock, ($-), withRepositoryDirectory, readRepo,
                          createRepository, invalidateIndex,
                          optimizeInventory,
                          tentativelyMergePatches, patchSetToPatches,
                          createPristineDirectoryTree,
                          revertRepositoryChanges, finalizeRepositoryChanges,
                          applyToWorking, setScriptsExecutable )
import Darcs.Global ( darcsdir )
import Darcs.Patch ( RealPatch, Patch, Named, showPatch, patch2patchinfo, fromPrims, infopatch,
                     modernizePatch,
                     adddeps, getdeps, effect, flattenFL, isMerger, patchcontents )
import Darcs.Witnesses.Ordered ( FL(..), RL(..), EqCheck(..), (=/\=), bunchFL, mapFL, mapFL_FL,
                                 concatFL, mapRL )
import Darcs.Patch.Info ( piRename, piTag, isTag, PatchInfo )
import Darcs.Patch.Commute ( publicUnravel )
import Darcs.Patch.Real ( mergeUnravelled )
import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2RL )
import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )
import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2))
import Darcs.Repository.Motd ( showMotd )
import Darcs.Utils ( clarifyErrors, askUser, catchall )
import Darcs.ProgressPatches ( progressFL )
import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(..) )
import Printer ( text, ($$) )
import Darcs.ColorPrinter ( traceDoc )
import Darcs.Lock ( writeBinFile )
import Darcs.External
import System.FilePath.Posix

#include "gadts.h"

convertDescription :: String
convertDescription = "Convert a repository from a legacy format."

convertHelp :: String
convertHelp =
 "The current repository format is called `darcs-2'.  It was introduced\n" ++
 "in Darcs 2.0 and became the default for new projects in Darcs 2.2.\n" ++
 "The `darcs convert' command allows existing projects to migrate to\n" ++
 "this format from the older `darcs-1' format.\n" ++
 "\n" ++
 "This command DOES NOT modify the source repository; a new destination\n" ++
 "repository is created.  It is safe to run this command more than once\n" ++
 "on a repository (e.g. for testing), before the final conversion.\n" ++
 "\n" ++
 convertHelp' ++
 "\n" ++
 "Due to this limitation, migrating a multi-branch project is a little\n" ++
 "awkward.  Sorry!  Here is the recommended process:\n" ++
 "\n" ++
 " 1. for each branch `foo', tag that branch with `foo-final';\n" ++
 " 2. merge all branches together (--allow-conflicts may help);\n" ++
 " 3. run `darcs optimize --reorder' on the result;\n" ++
 " 4. run `darcs convert' to create a merged darcs-2 repository;\n" ++
 " 5. re-create each branch by calling `darcs get --tag foo-final' on\n" ++
 "    the darcs-2 repository; and finally\n" ++
 " 6. use `darcs obliterate' to delete the foo-final tags.\n"

-- | This part of the help is split out because it is used twice: in
-- the help string, and in the prompt for confirmation.
convertHelp' :: String
convertHelp' =
 "WARNING: the repository produced by this command is not understood by\n" ++
 "Darcs 1.x, and patches cannot be exchanged between repositories in\n" ++
 "darcs-1 and darcs-2 formats.\n" ++
 "\n" ++
 "Furthermore, darcs 2 repositories created by different invocations of\n" ++
 "this command SHOULD NOT exchange patches, unless those repositories\n" ++
 "had no patches in common when they were converted.  (That is, within a\n" ++
 "set of repos that exchange patches, no patch should be converted more\n" ++
 "than once.)\n"

convert :: DarcsCommand
convert = DarcsCommand {commandProgramName = "darcs",
                    commandName = "convert",
                    commandHelp = convertHelp,
                    commandDescription = convertDescription,
                    commandExtraArgs = -1,
                    commandExtraArgHelp = ["<SOURCE>", "[<DESTINATION>]"],
                    commandCommand = convertCmd,
                    commandPrereq = \_ -> return $ Right (),
                    commandGetArgPossibilities = return [],
                    commandArgdefaults = nodefaults,
                    commandAdvancedOptions = networkOptions,
                    commandBasicOptions = [reponame,setScriptsExecutableOption]}

convertCmd :: [DarcsFlag] -> [String] -> IO ()
convertCmd opts [inrepodir, outname] = convertCmd (NewRepo outname:opts) [inrepodir]
convertCmd orig_opts [inrepodir] = do

  typed_repodir <- ioAbsoluteOrRemote inrepodir
  let repodir = toPath typed_repodir

  --test for converting darcs-2 repository
  Right format <- identifyRepoFormat repodir -- just fail in case of error
  when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format."

  putStrLn convertHelp'
  let vow = "I understand the consequences of my action"
  putStrLn "Please confirm that you have read and understood the above"
  vow' <- askUser ("by typing `" ++ vow ++ "': ")
  when (vow' /= vow) $ fail "User didn't understand the consequences."

  let opts = UseFormat2:orig_opts
  showMotd opts repodir
  mysimplename <- makeRepoName opts repodir
  createDirectory mysimplename
  setCurrentDirectory mysimplename
  createRepository opts
  writeBinFile (darcsdir++"/hashed_inventory") ""
  withRepoLock (NoUpdateWorking:opts) $- \repositoryfoo ->
    withRepositoryDirectory opts repodir $- \themrepobar -> do
      -- We really ought to have special versions of withRepoLock and
      -- withRepositoryDirectory that check at runtime that it's the right
      -- sort of repository and accept a function of (Repository Patch) or
      -- (Repository (FL RealPatch)), but that seems like a lot of work
      -- when these functions would be used exactly once, right here.  So I
      -- go with a horrible evil hack.

      -- The other alternative (which is what we used to do) is to use
      -- "universal" functions to do the conversion, but that's also
      -- unsatisfying.

      let repository = unsafeCoerce# repositoryfoo :: Repository (FL RealPatch) C(r u t)
          themrepo = unsafeCoerce# themrepobar :: Repository Patch C(r u t)
      theirstuff <- readRepo themrepo
      let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff
          inOrderTags = iot theirstuff
              where iot :: PatchSet p C(s x) -> [PatchInfo]
                    iot (PatchSet _ ts) = iot_ ts
                    iot_ :: RL(Tagged t1) C(t y) -> [PatchInfo]
                    iot_ (Tagged t _ _ :<: ts) = info t : iot_ ts
                    iot_ NilRL = []
          outOfOrderTags = catMaybes $ mapRL oot $ newset2RL theirstuff
              where oot t = if isTag (info t) && not (info t `elem` inOrderTags)
                            then Just (info t, getdeps $ hopefully t)
                            else Nothing
          fixDep p = case lookup p outOfOrderTags of
                     Just d -> p : concatMap fixDep d
                     Nothing -> [p]
          convertOne :: Patch C(x y) -> FL RealPatch C(x y)
          convertOne x | isMerger x = case mergeUnravelled $ publicUnravel $ modernizePatch x of
                                       Just (FlippedSeal y) ->
                                           case effect y =/\= effect x of
                                           IsEq -> y :>: NilFL
                                           NotEq ->
                                               traceDoc (text "lossy conversion:" $$
                                                         showPatch x)
                                               fromPrims (effect x)
                                       Nothing -> traceDoc (text
                                                            "lossy conversion of complicated conflict:" $$
                                                            showPatch x)
                                                  fromPrims (effect x)
                       | otherwise = case flattenFL x of
                                     NilFL -> NilFL
                                     (x':>:NilFL) -> fromPrims $ effect x'
                                     xs -> concatFL $ mapFL_FL convertOne xs
          convertNamed :: Named Patch C(x y) -> PatchInfoAnd (FL RealPatch) C(x y)
          convertNamed n = n2pia $
                           adddeps (infopatch (convertInfo $ patch2patchinfo n) $
                                              convertOne $ patchcontents n)
                                   (map convertInfo $ concatMap fixDep $ getdeps n)
          convertInfo n | n `elem` inOrderTags = n
                        | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n
          applySome xs = do Sealed pw <- tentativelyMergePatches repository "convert" (AllowConflicts:opts) NilFL xs
                            finalizeRepositoryChanges repository -- this is to clean out pristine.hashed
                            revertRepositoryChanges repository
                            revertable $ applyToWorking repository opts pw
                            invalidateIndex repository
      sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches
      invalidateIndex repository
      revertable $ createPristineDirectoryTree repository "."
      when (SetScriptsExecutable `elem` opts) $ setScriptsExecutable

      -- Copy over the prefs file
      let prefsRelPath = darcsdir </> "prefs" </> "prefs"
      copyFileOrUrl [NoLinks] (repodir </> prefsRelPath)
         prefsRelPath Uncachable `catchall` return ()

      optimizeInventory repository
      putInfo opts $ text "Finished converting."
      where revertable x = x `clarifyErrors` unlines
                  ["An error may have left your new working directory an inconsistent",
                   "but recoverable state. You should be able to make the new",
                   "repository consistent again by running darcs revert -a."]

convertCmd _ _ = fail "You must provide 'convert' with either one or two arguments."

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

modifyRepoName :: String -> IO String
modifyRepoName name =
    if head name == '/'
    then mrn name (-1)
    else do cwd <- getCurrentDirectory
            mrn (cwd ++ "/" ++ name) (-1)
 where
  mrn :: String -> Int -> IO String
  mrn n i = do
    exists <- doesDirectoryExist thename
    file_exists <- doesFileExist thename
    if not exists && not file_exists
       then do when (i /= -1) $
                    putStrLn $ "Directory '"++ n ++
                               "' already exists, creating repository as '"++
                               thename ++"'"
               return thename
       else mrn n $ i+1
    where thename = if i == -1 then n else n++"_"++show i

\end{code}