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

{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.Init ( initialize, initializeCmd ) where

import Darcs.Prelude

import Control.Monad ( when )

import Darcs.Repository ( createRepository, withUMaskFlag )
import Darcs.UI.Commands
    ( DarcsCommand(..)
    , amNotInRepository
    , nodefaults
    , putFinished
    , withStdOpts
    , putWarning
    )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags ( DarcsFlag, withNewRepo )
import Darcs.UI.Options ( defaultFlags, ocheck, odesc, (?), (^) )
import Darcs.UI.Options.All ()
import qualified Darcs.UI.Options.All as O
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Printer
    ( Doc
    , formatWords
    , quoted
    , renderString
    , text
    , vsep
    , ($$)
    , (<+>)
    )

initializeDescription :: String
initializeDescription :: String
initializeDescription = String
"Create an empty repository."

initializeHelp :: Doc
initializeHelp :: Doc
initializeHelp = [Doc] -> Doc
vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ([String] -> Doc) -> [[String]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> Doc
formatWords
  [ [ String
"The `darcs initialize` command creates an empty repository in the"
    , String
"current directory. This repository lives in a new `_darcs` directory,"
    , String
"which stores version control metadata and settings."
    ]
  , [ String
"Existing files and subdirectories are not touched. You can"
    , String
"record them with `darcs record --look-for-adds`."
    ]
  , [ String
"Initialize is commonly abbreviated to `init`."
    ]
  , [ String
"Darcs currently supports three kinds of patch semantics. These are called"
    , String
"`darcs-1`, `darcs-2`, and `darcs-3`. They are mutually incompatible, that"
    , String
"is, you cannot exchange patches between repos with different semantics."
    ]
  , [ String
"By default, patches of the new repository are in the darcs-2 semantics."
    , String
"However it is possible to create a repository in darcs-1 semantics with"
    , String
"the flag `--darcs-1`, althought this is not recommended except for sharing"
    , String
"patches with a project that uses patches in the darcs-1 semantics."
    ]
  ] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [Doc
darcs3Warning]

darcs3Warning :: Doc
darcs3Warning :: Doc
darcs3Warning = [String] -> Doc
formatWords
  [ String
"The `darcs-3` semantics is EXPERIMENTAL and new in version 2.16. It is"
  , String
"included only as a technology preview and we do NOT recommend to use it"
  , String
"for any serious work. The on-disk format is not yet finalized and we"
  , String
"cannot and will not promise that later releases will work with darcs-3"
  , String
"repos created with any darcs version before 3.0."
  ]

initialize :: DarcsCommand
initialize :: DarcsCommand
initialize = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"initialize"
    , commandHelp :: Doc
commandHelp = Doc
initializeHelp
    , commandDescription :: String
commandDescription = String
initializeDescription
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"[<DIRECTORY>]"]
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = \[DarcsFlag]
_ -> 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 ()
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
initializeCmd
    , 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 -> () -> UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr DarcsFlag Any (WithPatchIndex -> () -> UMask -> Any)
forall a.
OptSpec
  DarcsOptDescr DarcsFlag a (WithPatchIndex -> () -> UMask -> a)
initAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (PatchFormat -> WithWorkingDir -> Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (PatchFormat -> WithWorkingDir -> Maybe String -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (PatchFormat -> WithWorkingDir -> Maybe String -> a)
initBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (PatchFormat
   -> WithWorkingDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (PatchFormat
   -> WithWorkingDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (PatchFormat
   -> WithWorkingDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
initOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (PatchFormat
   -> WithWorkingDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (PatchFormat
   -> WithWorkingDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (PatchFormat
   -> WithWorkingDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
initOpts
    }
  where
    initBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (PatchFormat -> WithWorkingDir -> Maybe String -> a)
initBasicOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (WithWorkingDir -> Maybe String -> a)
  PatchFormat
PrimDarcsOption PatchFormat
O.patchFormat PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (WithWorkingDir -> Maybe String -> a)
  PatchFormat
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> a)
     (WithWorkingDir -> Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> a)
     (PatchFormat -> WithWorkingDir -> 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
  (Maybe String -> a)
  (WithWorkingDir -> Maybe String -> a)
PrimDarcsOption WithWorkingDir
O.withWorkingDir OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> a)
  (PatchFormat -> WithWorkingDir -> Maybe String -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (PatchFormat -> WithWorkingDir -> 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 -> a)
PrimDarcsOption (Maybe String)
O.newRepo
    initAdvancedOpts :: OptSpec
  DarcsOptDescr DarcsFlag a (WithPatchIndex -> () -> UMask -> a)
initAdvancedOpts = PrimOptSpec
  DarcsOptDescr DarcsFlag (() -> UMask -> a) WithPatchIndex
PrimDarcsOption WithPatchIndex
O.patchIndexNo PrimOptSpec
  DarcsOptDescr DarcsFlag (() -> UMask -> a) WithPatchIndex
-> OptSpec DarcsOptDescr DarcsFlag (UMask -> a) (() -> UMask -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (UMask -> a)
     (WithPatchIndex -> () -> UMask -> 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 (UMask -> a) (() -> UMask -> a)
PrimDarcsOption ()
O.hashed OptSpec
  DarcsOptDescr
  DarcsFlag
  (UMask -> a)
  (WithPatchIndex -> () -> UMask -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (UMask -> a)
-> OptSpec
     DarcsOptDescr DarcsFlag a (WithPatchIndex -> () -> UMask -> 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 (UMask -> a)
PrimDarcsOption UMask
O.umask
    initOpts :: DarcsOption
  a
  (PatchFormat
   -> WithWorkingDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
initOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (PatchFormat
   -> WithWorkingDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (PatchFormat -> WithWorkingDir -> Maybe String -> a)
initBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (PatchFormat
   -> WithWorkingDir
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (WithPatchIndex
      -> ()
      -> UMask
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
-> DarcsOption
     a
     (PatchFormat
      -> WithWorkingDir
      -> Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> WithPatchIndex
      -> ()
      -> UMask
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (WithPatchIndex
   -> ()
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr DarcsFlag a (WithPatchIndex -> () -> UMask -> a)
initAdvancedOpts

initializeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
initializeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
initializeCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String
outname]
  | Maybe String
Nothing <- PrimDarcsOption (Maybe String)
O.newRepo PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts = [DarcsFlag] -> IO ()
doInit (String -> [DarcsFlag] -> [DarcsFlag]
withNewRepo String
outname [DarcsFlag]
opts)
initializeCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [] = [DarcsFlag] -> IO ()
doInit [DarcsFlag]
opts
initializeCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [String]
_ =
  String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"You must provide 'initialize' with either zero or one argument."

doInit :: [DarcsFlag] -> IO ()
doInit :: [DarcsFlag] -> IO ()
doInit [DarcsFlag]
opts =
  UMask -> IO () -> IO ()
forall a. UMask -> IO a -> IO a
withUMaskFlag (PrimDarcsOption UMask
O.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
$ do
    Either String ()
location <- [DarcsFlag] -> IO (Either String ())
amNotInRepository [DarcsFlag]
opts
    case Either String ()
location of
      Left String
msg -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
        Doc
"Unable to" Doc -> Doc -> Doc
<+> String -> Doc
quoted (String
"darcs " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DarcsCommand -> String
commandName DarcsCommand
initialize)
                    Doc -> Doc -> Doc
<+> Doc
"here:" Doc -> Doc -> Doc
$$ String -> Doc
text String
msg
      Right () -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PrimDarcsOption PatchFormat
O.patchFormat PrimDarcsOption PatchFormat -> [DarcsFlag] -> PatchFormat
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts PatchFormat -> PatchFormat -> Bool
forall a. Eq a => a -> a -> Bool
== PatchFormat
O.PatchFormat3) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          [DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
            Doc
"============================= WARNING =============================" Doc -> Doc -> Doc
$$
            Doc
darcs3Warning Doc -> Doc -> Doc
$$
            Doc
"==================================================================="
        EmptyRepository
_ <- PatchFormat
-> WithWorkingDir
-> WithPatchIndex
-> UseCache
-> IO EmptyRepository
createRepository
          (PrimDarcsOption PatchFormat
O.patchFormat PrimDarcsOption PatchFormat -> [DarcsFlag] -> PatchFormat
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
          (PrimDarcsOption WithWorkingDir
O.withWorkingDir PrimDarcsOption WithWorkingDir -> [DarcsFlag] -> WithWorkingDir
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
          (PrimDarcsOption WithPatchIndex
O.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)
        [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"initializing repository"