Commit a5f69e24 authored by Brent Yorgey's avatar Brent Yorgey Committed by tibbe

cabal init: back up existing files before writing (fixes #673)

parent 6bc5b917
......@@ -24,9 +24,9 @@ module Distribution.Client.Init (
import System.IO
( hSetBuffering, stdout, BufferMode(..) )
import System.Directory
( getCurrentDirectory, doesDirectoryExist )
( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile )
import System.FilePath
( (</>) )
( (</>), (<.>) )
import Data.Time
( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )
......@@ -42,7 +42,7 @@ import Data.Traversable
import Control.Applicative
( (<$>) )
import Control.Monad
( when )
( when, unless )
#if MIN_VERSION_base(3,0,0)
import Control.Monad
( (>=>), join )
......@@ -501,7 +501,7 @@ writeLicense flags = do
_ -> Nothing
case licenseFile of
Just licenseText -> writeFile "LICENSE" licenseText
Just licenseText -> writeFileSafe flags "LICENSE" licenseText
Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."
getYear :: IO Integer
......@@ -515,7 +515,7 @@ getYear = do
writeSetupFile :: InitFlags -> IO ()
writeSetupFile flags = do
message flags "Generating Setup.hs..."
writeFile "Setup.hs" setupFile
writeFileSafe flags "Setup.hs" setupFile
where
setupFile = unlines
[ "import Distribution.Simple"
......@@ -531,9 +531,36 @@ writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do
writeCabalFile flags@(InitFlags{packageName = Flag p}) = do
let cabalFileName = p ++ ".cabal"
message flags $ "Generating " ++ cabalFileName ++ "..."
writeFile cabalFileName (generateCabalFile cabalFileName flags)
writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)
return True
-- | Write a file \"safely\", backing up any existing version (unless
-- the overwrite flag is set).
writeFileSafe :: InitFlags -> FilePath -> String -> IO ()
writeFileSafe flags fileName content = do
moveExistingFile flags fileName
writeFile fileName content
-- | Move an existing file, if there is one, and the overwrite flag is
-- not set.
moveExistingFile :: InitFlags -> FilePath -> IO ()
moveExistingFile flags fileName =
unless (overwrite flags == Flag True) $ do
e <- doesFileExist fileName
when e $ do
newName <- findNewName fileName
message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName
copyFile fileName newName
findNewName :: FilePath -> IO FilePath
findNewName oldName = findNewName' 0
where
findNewName' :: Integer -> IO FilePath
findNewName' n = do
let newName = oldName <.> ("save" ++ show n)
e <- doesFileExist newName
if e then findNewName' (n+1) else return newName
-- | Generate a .cabal file from an InitFlags structure. NOTE: this
-- is rather ad-hoc! What we would REALLY like is to have a
-- standard low-level AST type representing .cabal files, which
......
......@@ -62,6 +62,7 @@ data InitFlags =
, buildTools :: Maybe [String]
, initVerbosity :: Flag Verbosity
, overwrite :: Flag Bool
}
deriving (Show)
......@@ -95,6 +96,7 @@ instance Monoid InitFlags where
, sourceDirs = mempty
, buildTools = mempty
, initVerbosity = mempty
, overwrite = mempty
}
mappend a b = InitFlags
{ nonInteractive = combine nonInteractive
......@@ -118,6 +120,7 @@ instance Monoid InitFlags where
, sourceDirs = combine sourceDirs
, buildTools = combine buildTools
, initVerbosity = combine initVerbosity
, overwrite = combine overwrite
}
where combine field = field a `mappend` field b
......
......@@ -979,6 +979,11 @@ initCommand = CommandUI {
IT.minimal (\v flags -> flags { IT.minimal = v })
trueArg
, option [] ["overwrite"]
"Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning."
IT.overwrite (\v flags -> flags { IT.overwrite = v })
trueArg
, option [] ["package-dir"]
"Root directory of the package (default = current directory)."
IT.packageDir (\v flags -> flags { IT.packageDir = v })
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment