{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Client.Init.FileCreators
-- Copyright   :  (c) Brent Yorgey 2009
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Functions to create files during 'cabal init'.
module Distribution.Client.Init.FileCreators
  ( -- * Commands
    writeProject
  , writeLicense
  , writeChangeLog
  , prepareLibTarget
  , prepareExeTarget
  , prepareTestTarget
  ) where

import Distribution.Client.Compat.Prelude hiding (empty, head, readFile, writeFile)
import Prelude hiding (readFile, writeFile)

import qualified Data.Set as Set (member)

import Distribution.CabalSpecVersion (showCabalSpecVersion)
import Distribution.Client.Init.Defaults
import Distribution.Client.Init.Format
import Distribution.Client.Init.Licenses
  ( agplv3
  , apache20
  , bsd2
  , bsd3
  , gplv2
  , gplv3
  , isc
  , lgpl21
  , lgpl3
  , mit
  , mpl20
  )
import Distribution.Client.Init.Types hiding (message, putStr, putStrLn)
import qualified Distribution.Client.Init.Types as T
import Distribution.Fields.Pretty (PrettyField (..), showFields')
import qualified Distribution.SPDX as SPDX
import Distribution.Types.PackageName

import Distribution.FieldGrammar.Newtypes
import Distribution.License (licenseToSPDX)
import System.FilePath ((<.>), (</>))

-- -------------------------------------------------------------------- --
--  File generation

writeProject :: Interactive m => ProjectSettings -> m ()
writeProject :: forall (m :: * -> *). Interactive m => ProjectSettings -> m ()
writeProject (ProjectSettings WriteOpts
opts PkgDescription
pkgDesc Maybe LibTarget
libTarget Maybe ExeTarget
exeTarget Maybe TestTarget
testTarget)
  | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pkgName = do
      WriteOpts -> Severity -> String -> m ()
forall (m :: * -> *).
Interactive m =>
WriteOpts -> Severity -> String -> m ()
message WriteOpts
opts Severity
T.Error String
"no package name given, so no .cabal file can be generated\n"
  | Bool
otherwise = do
      -- clear prompt history a bit"
      WriteOpts -> Severity -> String -> m ()
forall (m :: * -> *).
Interactive m =>
WriteOpts -> Severity -> String -> m ()
message WriteOpts
opts Severity
T.Info (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
        String
"Using cabal specification: "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ CabalSpecVersion -> String
showCabalSpecVersion (WriteOpts -> CabalSpecVersion
_optCabalSpec WriteOpts
opts)

      WriteOpts -> PkgDescription -> m ()
forall (m :: * -> *).
Interactive m =>
WriteOpts -> PkgDescription -> m ()
writeLicense WriteOpts
opts PkgDescription
pkgDesc
      WriteOpts -> PkgDescription -> m ()
forall (m :: * -> *).
Interactive m =>
WriteOpts -> PkgDescription -> m ()
writeChangeLog WriteOpts
opts PkgDescription
pkgDesc

      let pkgFields :: [PrettyField FieldAnnotation]
pkgFields = WriteOpts -> PkgDescription -> [PrettyField FieldAnnotation]
mkPkgDescription WriteOpts
opts PkgDescription
pkgDesc
          commonStanza :: PrettyField FieldAnnotation
commonStanza = WriteOpts -> PrettyField FieldAnnotation
mkCommonStanza WriteOpts
opts

      libStanza <- WriteOpts -> Maybe LibTarget -> m (PrettyField FieldAnnotation)
forall (m :: * -> *).
Interactive m =>
WriteOpts -> Maybe LibTarget -> m (PrettyField FieldAnnotation)
prepareLibTarget WriteOpts
opts Maybe LibTarget
libTarget
      exeStanza <- prepareExeTarget opts exeTarget
      testStanza <- prepareTestTarget opts testTarget

      (reusedCabal, cabalContents) <-
        writeCabalFile opts $
          pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza]

      when (null $ _pkgSynopsis pkgDesc) $
        message opts T.Warning "No synopsis given. You should edit the .cabal file and add one."

      message opts T.Info "You may want to edit the .cabal file and add a Description field."

      when reusedCabal $ do
        existingCabal <- readFile $ unPackageName (_optPkgName opts) ++ ".cabal"
        when (existingCabal /= cabalContents) $
          message opts T.Warning "A .cabal file was found and not updated, if updating is desired please use the '--overwrite' option."

      -- clear out last line for presentation.
      T.putStrLn ""
  where
    pkgName :: String
pkgName = PackageName -> String
unPackageName (PackageName -> String) -> PackageName -> String
forall a b. (a -> b) -> a -> b
$ WriteOpts -> PackageName
_optPkgName WriteOpts
opts

prepareLibTarget
  :: Interactive m
  => WriteOpts
  -> Maybe LibTarget
  -> m (PrettyField FieldAnnotation)
prepareLibTarget :: forall (m :: * -> *).
Interactive m =>
WriteOpts -> Maybe LibTarget -> m (PrettyField FieldAnnotation)
prepareLibTarget WriteOpts
_ Maybe LibTarget
Nothing = PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PrettyField FieldAnnotation
forall ann. PrettyField ann
PrettyEmpty
prepareLibTarget WriteOpts
opts (Just LibTarget
libTarget) = do
  m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ WriteOpts -> [String] -> m Bool
forall (m :: * -> *).
Interactive m =>
WriteOpts -> [String] -> m Bool
writeDirectoriesSafe WriteOpts
opts ([String] -> m Bool) -> [String] -> m Bool
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
".") [String]
srcDirs
  -- avoid writing when conflicting exposed paths may
  -- exist.
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NonEmpty ModuleName
expMods NonEmpty ModuleName -> NonEmpty ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== (ModuleName
myLibModule ModuleName -> [ModuleName] -> NonEmpty ModuleName
forall a. a -> [a] -> NonEmpty a
:| [])) (m () -> m ()) -> (m Bool -> m ()) -> m Bool -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$
    WriteOpts -> String -> String -> m Bool
forall (m :: * -> *).
Interactive m =>
WriteOpts -> String -> String -> m Bool
writeFileSafe WriteOpts
opts String
libPath String
myLibHs

  PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation))
-> PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation)
forall a b. (a -> b) -> a -> b
$ WriteOpts -> LibTarget -> PrettyField FieldAnnotation
mkLibStanza WriteOpts
opts LibTarget
libTarget
  where
    expMods :: NonEmpty ModuleName
expMods = LibTarget -> NonEmpty ModuleName
_libExposedModules LibTarget
libTarget
    srcDirs :: [String]
srcDirs = LibTarget -> [String]
_libSourceDirs LibTarget
libTarget
    libPath :: String
libPath = case [String]
srcDirs of
      String
path : [String]
_ -> String
path String -> String -> String
</> HsFilePath -> String
_hsFilePath HsFilePath
myLibFile
      [String]
_ -> HsFilePath -> String
_hsFilePath HsFilePath
myLibFile

prepareExeTarget
  :: Interactive m
  => WriteOpts
  -> Maybe ExeTarget
  -> m (PrettyField FieldAnnotation)
prepareExeTarget :: forall (m :: * -> *).
Interactive m =>
WriteOpts -> Maybe ExeTarget -> m (PrettyField FieldAnnotation)
prepareExeTarget WriteOpts
_ Maybe ExeTarget
Nothing = PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PrettyField FieldAnnotation
forall ann. PrettyField ann
PrettyEmpty
prepareExeTarget WriteOpts
opts (Just ExeTarget
exeTarget) = do
  m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ WriteOpts -> [String] -> m Bool
forall (m :: * -> *).
Interactive m =>
WriteOpts -> [String] -> m Bool
writeDirectoriesSafe WriteOpts
opts [String]
appDirs
  m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ WriteOpts -> String -> String -> m Bool
forall (m :: * -> *).
Interactive m =>
WriteOpts -> String -> String -> m Bool
writeFileSafe WriteOpts
opts String
mainPath String
mainHs
  PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation))
-> PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation)
forall a b. (a -> b) -> a -> b
$ WriteOpts -> ExeTarget -> PrettyField FieldAnnotation
mkExeStanza WriteOpts
opts ExeTarget
exeTarget
  where
    exeMainIs :: HsFilePath
exeMainIs = ExeTarget -> HsFilePath
_exeMainIs ExeTarget
exeTarget
    pkgType :: PackageType
pkgType = WriteOpts -> PackageType
_optPkgType WriteOpts
opts
    appDirs :: [String]
appDirs = ExeTarget -> [String]
_exeApplicationDirs ExeTarget
exeTarget
    mainFile :: String
mainFile = HsFilePath -> String
_hsFilePath HsFilePath
exeMainIs
    mainPath :: String
mainPath = case [String]
appDirs of
      String
appPath : [String]
_ -> String
appPath String -> String -> String
</> String
mainFile
      [String]
_ -> String
mainFile

    mainHs :: String
mainHs =
      [String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsFilePath -> [String] -> [String]
mkLiterate HsFilePath
exeMainIs ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        if PackageType
pkgType PackageType -> PackageType -> Bool
forall a. Eq a => a -> a -> Bool
== PackageType
LibraryAndExecutable
          then [String]
myLibExeHs
          else [String]
myExeHs

prepareTestTarget
  :: Interactive m
  => WriteOpts
  -> Maybe TestTarget
  -> m (PrettyField FieldAnnotation)
prepareTestTarget :: forall (m :: * -> *).
Interactive m =>
WriteOpts -> Maybe TestTarget -> m (PrettyField FieldAnnotation)
prepareTestTarget WriteOpts
_ Maybe TestTarget
Nothing = PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PrettyField FieldAnnotation
forall ann. PrettyField ann
PrettyEmpty
prepareTestTarget WriteOpts
opts (Just TestTarget
testTarget) = do
  m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ WriteOpts -> [String] -> m Bool
forall (m :: * -> *).
Interactive m =>
WriteOpts -> [String] -> m Bool
writeDirectoriesSafe WriteOpts
opts [String]
testDirs'
  m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ WriteOpts -> String -> String -> m Bool
forall (m :: * -> *).
Interactive m =>
WriteOpts -> String -> String -> m Bool
writeFileSafe WriteOpts
opts String
testPath String
myTestHs
  PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation))
-> PrettyField FieldAnnotation -> m (PrettyField FieldAnnotation)
forall a b. (a -> b) -> a -> b
$ WriteOpts -> TestTarget -> PrettyField FieldAnnotation
mkTestStanza WriteOpts
opts TestTarget
testTarget
  where
    testDirs' :: [String]
testDirs' = TestTarget -> [String]
_testDirs TestTarget
testTarget
    testMainIs :: String
testMainIs = HsFilePath -> String
_hsFilePath (HsFilePath -> String) -> HsFilePath -> String
forall a b. (a -> b) -> a -> b
$ TestTarget -> HsFilePath
_testMainIs TestTarget
testTarget
    testPath :: String
testPath = case [String]
testDirs' of
      String
p : [String]
_ -> String
p String -> String -> String
</> String
testMainIs
      [String]
_ -> String
testMainIs

writeCabalFile
  :: Interactive m
  => WriteOpts
  -> [PrettyField FieldAnnotation]
  -- ^ .cabal fields
  -> m (Bool, String)
writeCabalFile :: forall (m :: * -> *).
Interactive m =>
WriteOpts -> [PrettyField FieldAnnotation] -> m (Bool, String)
writeCabalFile WriteOpts
opts [PrettyField FieldAnnotation]
fields = do
  let cabalContents :: String
cabalContents =
        (FieldAnnotation -> CommentPosition)
-> (FieldAnnotation -> [String] -> [String])
-> Int
-> [PrettyField FieldAnnotation]
-> String
forall ann.
(ann -> CommentPosition)
-> (ann -> [String] -> [String])
-> Int
-> [PrettyField ann]
-> String
showFields'
          FieldAnnotation -> CommentPosition
annCommentLines
          FieldAnnotation -> [String] -> [String]
postProcessFieldLines
          Int
4
          [PrettyField FieldAnnotation]
fields

  reusedCabal <- WriteOpts -> String -> String -> m Bool
forall (m :: * -> *).
Interactive m =>
WriteOpts -> String -> String -> m Bool
writeFileSafe WriteOpts
opts String
cabalFileName String
cabalContents
  return (reusedCabal, cabalContents)
  where
    cabalFileName :: String
cabalFileName = String
pkgName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".cabal"
    pkgName :: String
pkgName = PackageName -> String
unPackageName (PackageName -> String) -> PackageName -> String
forall a b. (a -> b) -> a -> b
$ WriteOpts -> PackageName
_optPkgName WriteOpts
opts

-- | Write the LICENSE file.
--
-- For licenses that contain the author's name(s), the values are taken
-- from the 'authors' field of 'InitFlags', and if not specified will
-- be the string "???".
--
-- If the license type is unknown no license file will be prepared and
-- a warning will be raised.
writeLicense :: Interactive m => WriteOpts -> PkgDescription -> m ()
writeLicense :: forall (m :: * -> *).
Interactive m =>
WriteOpts -> PkgDescription -> m ()
writeLicense WriteOpts
writeOpts PkgDescription
pkgDesc = do
  year <- Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> m Integer -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Integer
forall (m :: * -> *). Interactive m => m Integer
getCurrentYear
  case licenseFile year (_pkgAuthor pkgDesc) of
    Just String
licenseText ->
      m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ WriteOpts -> String -> String -> m Bool
forall (m :: * -> *).
Interactive m =>
WriteOpts -> String -> String -> m Bool
writeFileSafe WriteOpts
writeOpts String
"LICENSE" String
licenseText
    Maybe String
Nothing -> WriteOpts -> Severity -> String -> m ()
forall (m :: * -> *).
Interactive m =>
WriteOpts -> Severity -> String -> m ()
message WriteOpts
writeOpts Severity
T.Warning String
"unknown license type, you must put a copy in LICENSE yourself."
  where
    getLid :: Either License License -> Maybe LicenseId
getLid (Left (SPDX.License (SPDX.ELicense (SPDX.ELicenseId LicenseId
lid) Maybe LicenseExceptionId
Nothing))) = LicenseId -> Maybe LicenseId
forall a. a -> Maybe a
Just LicenseId
lid
    getLid (Right License
l) = Either License License -> Maybe LicenseId
getLid (Either License License -> Maybe LicenseId)
-> (License -> Either License License)
-> License
-> Maybe LicenseId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. License -> Either License License
forall a b. a -> Either a b
Left (License -> Maybe LicenseId) -> License -> Maybe LicenseId
forall a b. (a -> b) -> a -> b
$ License -> License
licenseToSPDX License
l
    getLid Either License License
_ = Maybe LicenseId
forall a. Maybe a
Nothing

    licenseFile :: String -> String -> Maybe String
licenseFile String
year String
auth = case Either License License -> Maybe LicenseId
getLid (Either License License -> Maybe LicenseId)
-> (SpecLicense -> Either License License)
-> SpecLicense
-> Maybe LicenseId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecLicense -> Either License License
getSpecLicense (SpecLicense -> Maybe LicenseId) -> SpecLicense -> Maybe LicenseId
forall a b. (a -> b) -> a -> b
$ PkgDescription -> SpecLicense
_pkgLicense PkgDescription
pkgDesc of
      Just LicenseId
SPDX.BSD_2_Clause -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
bsd2 String
auth String
year
      Just LicenseId
SPDX.BSD_3_Clause -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
bsd3 String
auth String
year
      Just LicenseId
SPDX.Apache_2_0 -> String -> Maybe String
forall a. a -> Maybe a
Just String
apache20
      Just LicenseId
SPDX.MIT -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
mit String
auth String
year
      Just LicenseId
SPDX.MPL_2_0 -> String -> Maybe String
forall a. a -> Maybe a
Just String
mpl20
      Just LicenseId
SPDX.ISC -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
isc String
auth String
year
      Just LicenseId
SPDX.GPL_2_0_only -> String -> Maybe String
forall a. a -> Maybe a
Just String
gplv2
      Just LicenseId
SPDX.GPL_3_0_only -> String -> Maybe String
forall a. a -> Maybe a
Just String
gplv3
      Just LicenseId
SPDX.LGPL_2_1_only -> String -> Maybe String
forall a. a -> Maybe a
Just String
lgpl21
      Just LicenseId
SPDX.LGPL_3_0_only -> String -> Maybe String
forall a. a -> Maybe a
Just String
lgpl3
      Just LicenseId
SPDX.AGPL_3_0_only -> String -> Maybe String
forall a. a -> Maybe a
Just String
agplv3
      Just LicenseId
SPDX.GPL_2_0_or_later -> String -> Maybe String
forall a. a -> Maybe a
Just String
gplv2
      Just LicenseId
SPDX.GPL_3_0_or_later -> String -> Maybe String
forall a. a -> Maybe a
Just String
gplv3
      Just LicenseId
SPDX.LGPL_2_1_or_later -> String -> Maybe String
forall a. a -> Maybe a
Just String
lgpl21
      Just LicenseId
SPDX.LGPL_3_0_or_later -> String -> Maybe String
forall a. a -> Maybe a
Just String
lgpl3
      Just LicenseId
SPDX.AGPL_3_0_or_later -> String -> Maybe String
forall a. a -> Maybe a
Just String
agplv3
      Maybe LicenseId
_ -> Maybe String
forall a. Maybe a
Nothing

-- | Writes the changelog to the current directory.
writeChangeLog :: Interactive m => WriteOpts -> PkgDescription -> m ()
writeChangeLog :: forall (m :: * -> *).
Interactive m =>
WriteOpts -> PkgDescription -> m ()
writeChangeLog WriteOpts
opts PkgDescription
pkgDesc
  | Just Set String
docs <- PkgDescription -> Maybe (Set String)
_pkgExtraDocFiles PkgDescription
pkgDesc
  , String
defaultChangelog String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
docs =
      m ()
go
  | String
defaultChangelog String -> Set String -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` PkgDescription -> Set String
_pkgExtraSrcFiles PkgDescription
pkgDesc = m ()
go
  | Bool
otherwise = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    changeLog :: String
changeLog =
      [String] -> String
unlines
        [ String
"# Revision history for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PkgDescription -> PackageName
_pkgName PkgDescription
pkgDesc)
        , String
""
        , String
"## " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow (PkgDescription -> Version
_pkgVersion PkgDescription
pkgDesc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -- YYYY-mm-dd"
        , String
""
        , String
"* First version. Released on an unsuspecting world."
        ]

    go :: m ()
go =
      m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ WriteOpts -> String -> String -> m Bool
forall (m :: * -> *).
Interactive m =>
WriteOpts -> String -> String -> m Bool
writeFileSafe WriteOpts
opts String
defaultChangelog String
changeLog

-- -------------------------------------------------------------------- --
-- Utilities

data WriteAction = Overwrite | Fresh | Existing deriving (WriteAction -> WriteAction -> Bool
(WriteAction -> WriteAction -> Bool)
-> (WriteAction -> WriteAction -> Bool) -> Eq WriteAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WriteAction -> WriteAction -> Bool
== :: WriteAction -> WriteAction -> Bool
$c/= :: WriteAction -> WriteAction -> Bool
/= :: WriteAction -> WriteAction -> Bool
Eq)

instance Show WriteAction where
  show :: WriteAction -> String
show WriteAction
Overwrite = String
"Overwriting"
  show WriteAction
Fresh = String
"Creating fresh"
  show WriteAction
Existing = String
"Using existing"

-- | Possibly generate a message to stdout, taking into account the
--   --quiet flag.
message :: Interactive m => WriteOpts -> T.Severity -> String -> m ()
message :: forall (m :: * -> *).
Interactive m =>
WriteOpts -> Severity -> String -> m ()
message WriteOpts
opts = Verbosity -> Severity -> String -> m ()
forall (m :: * -> *).
Interactive m =>
Verbosity -> Severity -> String -> m ()
T.message (WriteOpts -> Verbosity
_optVerbosity WriteOpts
opts)

-- | Write a file \"safely\" if it doesn't exist, backing up any existing version when
--   the overwrite flag is set.
writeFileSafe :: Interactive m => WriteOpts -> FilePath -> String -> m Bool
writeFileSafe :: forall (m :: * -> *).
Interactive m =>
WriteOpts -> String -> String -> m Bool
writeFileSafe WriteOpts
opts String
fileName String
content = do
  exists <- String -> m Bool
forall (m :: * -> *). Interactive m => String -> m Bool
doesFileExist String
fileName

  let action
        | Bool
exists Bool -> Bool -> Bool
&& Bool
doOverwrite = WriteAction
Overwrite
        | Bool -> Bool
not Bool
exists = WriteAction
Fresh
        | Bool
otherwise = WriteAction
Existing

  go exists

  message opts T.Info $ show action ++ " file " ++ fileName ++ "..."
  return $ action == Existing
  where
    doOverwrite :: Bool
doOverwrite = WriteOpts -> Bool
_optOverwrite WriteOpts
opts

    go :: Bool -> m ()
go Bool
exists
      | Bool -> Bool
not Bool
exists = do
          String -> String -> m ()
forall (m :: * -> *). Interactive m => String -> String -> m ()
writeFile String
fileName String
content
      | Bool
exists Bool -> Bool -> Bool
&& Bool
doOverwrite = do
          newName <- String -> m String
forall (m :: * -> *). Interactive m => String -> m String
findNewPath String
fileName
          message opts T.Info $
            concat
              [ fileName
              , " already exists. Backing up old version in "
              , newName
              ]

          copyFile fileName newName -- backups the old file
          removeExistingFile fileName -- removes the original old file
          writeFile fileName content -- writes the new file
      | Bool
otherwise = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

writeDirectoriesSafe :: Interactive m => WriteOpts -> [String] -> m Bool
writeDirectoriesSafe :: forall (m :: * -> *).
Interactive m =>
WriteOpts -> [String] -> m Bool
writeDirectoriesSafe WriteOpts
opts [String]
dirs = ([Bool] -> Bool) -> m [Bool] -> m Bool
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (m [Bool] -> m Bool) -> m [Bool] -> m Bool
forall a b. (a -> b) -> a -> b
$ [String] -> (String -> m Bool) -> m [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [String]
dirs ((String -> m Bool) -> m [Bool]) -> (String -> m Bool) -> m [Bool]
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
  exists <- String -> m Bool
forall (m :: * -> *). Interactive m => String -> m Bool
doesDirectoryExist String
dir

  let action
        | Bool
exists Bool -> Bool -> Bool
&& Bool
doOverwrite = WriteAction
Overwrite
        | Bool -> Bool
not Bool
exists = WriteAction
Fresh
        | Bool
otherwise = WriteAction
Existing

  go dir exists

  message opts T.Info $ show action ++ " directory ./" ++ dir ++ "..."
  return $ action == Existing
  where
    doOverwrite :: Bool
doOverwrite = WriteOpts -> Bool
_optOverwrite WriteOpts
opts

    go :: String -> Bool -> m ()
go String
dir Bool
exists
      | Bool -> Bool
not Bool
exists = do
          String -> m ()
forall (m :: * -> *). Interactive m => String -> m ()
createDirectory String
dir
      | Bool
exists Bool -> Bool -> Bool
&& Bool
doOverwrite = do
          newDir <- String -> m String
forall (m :: * -> *). Interactive m => String -> m String
findNewPath String
dir
          message opts T.Info $
            concat
              [ dir
              , " already exists. Backing up old version in "
              , newDir
              ]

          renameDirectory dir newDir -- backups the old directory
          createDirectory dir -- creates the new directory
      | Bool
otherwise = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

findNewPath :: Interactive m => FilePath -> m FilePath
findNewPath :: forall (m :: * -> *). Interactive m => String -> m String
findNewPath String
dir = Int -> m String
forall {m :: * -> *} {t}.
(Interactive m, Enum t, Show t) =>
t -> m String
go (Int
0 :: Int)
  where
    go :: t -> m String
go t
n = do
      let newDir :: String
newDir = String
dir String -> String -> String
<.> (String
"save" String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
n)
      e <- String -> m Bool
forall (m :: * -> *). Interactive m => String -> m Bool
doesDirectoryExist String
newDir
      if e then go (succ n) else return newDir