Merge pull request #7831 from ptkato/cabal-init-fileformat-tests

Cabal init fileformat tests

cabal-install/cabal-install.cabal

@@ -284,6 +284,7 @@ Test-Suite unit-tests
       UnitTests.Distribution.Client.Init.NonInteractive
       UnitTests.Distribution.Client.Init.Simple
       UnitTests.Distribution.Client.Init.Utils
+      UnitTests.Distribution.Client.Init.FileCreators
       UnitTests.Distribution.Client.Store
       UnitTests.Distribution.Client.Tar
       UnitTests.Distribution.Client.TreeDiffInstances
@@ -320,6 +321,7 @@ Test-Suite unit-tests
           time,
           zlib,
           tasty >= 1.2.3 && <1.5,
+          tasty-expected-failure,
           tasty-golden >=2.3.1.1 && <2.4,
           tasty-quickcheck,
           tasty-hunit >= 0.10,

cabal-install/src/Distribution/Client/Init/FileCreators.hs

@@ -28,7 +28,6 @@ import Distribution.Client.Compat.Prelude hiding (head, empty, writeFile)
 
 import qualified Data.Set as Set (member)
 
-import Distribution.Client.Utils (getCurrentYear, removeExistingFile)
 import Distribution.Client.Init.Defaults
 import Distribution.Client.Init.Licenses
   ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc )
@@ -45,17 +44,16 @@ import System.FilePath ((</>), (<.>))
 -- -------------------------------------------------------------------- --
 --  File generation
 
-writeProject :: ProjectSettings -> IO ()
+writeProject :: Interactive m => ProjectSettings -> m ()
 writeProject (ProjectSettings opts pkgDesc libTarget exeTarget testTarget)
     | null pkgName = do
-      message opts "\nError: no package name given, so no .cabal file can be generated\n"
+      message opts T.Error "no package name given, so no .cabal file can be generated\n"
     | otherwise = do
 
       -- clear prompt history a bit"
-      message opts
-        $ "\nUsing cabal specification: "
+      message opts T.Log
+        $ "Using cabal specification: "
         ++ showCabalSpecVersion (_optCabalSpec opts)
-        ++ "\n"
 
       writeLicense opts pkgDesc
       writeChangeLog opts pkgDesc
@@ -70,17 +68,18 @@ writeProject (ProjectSettings opts pkgDesc libTarget exeTarget testTarget)
       writeCabalFile opts $ pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza]
 
       when (null $ _pkgSynopsis pkgDesc) $
-        message opts "\nWarning: no synopsis given. You should edit the .cabal file and add one."
+        message opts T.Warning "no synopsis given. You should edit the .cabal file and add one."
 
-      message opts "You may want to edit the .cabal file and add a Description field."
+      message opts T.Info "You may want to edit the .cabal file and add a Description field."
   where
     pkgName = unPackageName $ _optPkgName opts
 
 
 prepareLibTarget
-    :: WriteOpts
+    :: Interactive m 
+    => WriteOpts
     -> Maybe LibTarget
-    -> IO (PrettyField FieldAnnotation)
+    -> m (PrettyField FieldAnnotation)
 prepareLibTarget _ Nothing = return PrettyEmpty
 prepareLibTarget opts (Just libTarget) = do
     void $ writeDirectoriesSafe opts srcDirs
@@ -98,9 +97,10 @@ prepareLibTarget opts (Just libTarget) = do
       _ -> _hsFilePath myLibFile
 
 prepareExeTarget
-    :: WriteOpts
+    :: Interactive m
+    => WriteOpts
     -> Maybe ExeTarget
-    -> IO (PrettyField FieldAnnotation)
+    -> m (PrettyField FieldAnnotation)
 prepareExeTarget _ Nothing = return PrettyEmpty
 prepareExeTarget opts (Just exeTarget) = do
     void $ writeDirectoriesSafe opts appDirs
@@ -121,9 +121,10 @@ prepareExeTarget opts (Just exeTarget) = do
       else myExeHs
 
 prepareTestTarget
-    :: WriteOpts
+    :: Interactive m 
+    => WriteOpts
     -> Maybe TestTarget
-    -> IO (PrettyField FieldAnnotation)
+    -> m (PrettyField FieldAnnotation)
 prepareTestTarget _ Nothing = return PrettyEmpty
 prepareTestTarget opts (Just testTarget) = do
     void $ writeDirectoriesSafe opts testDirs'
@@ -137,10 +138,11 @@ prepareTestTarget opts (Just testTarget) = do
       _ -> testMainIs
 
 writeCabalFile
-    :: WriteOpts
+    :: Interactive m 
+    => WriteOpts
     -> [PrettyField FieldAnnotation]
       -- ^ .cabal fields
-    -> IO ()
+    -> m ()
 writeCabalFile opts fields =
     writeFileSafe opts cabalFileName cabalContents
   where
@@ -161,14 +163,14 @@ writeCabalFile opts fields =
 -- If the license type is unknown no license file will be prepared and
 -- a warning will be raised.
 --
-writeLicense :: WriteOpts -> PkgDescription -> IO ()
+writeLicense :: Interactive m => WriteOpts -> PkgDescription -> m ()
 writeLicense writeOpts pkgDesc = do
   year <- show <$> getCurrentYear
   case licenseFile year (_pkgAuthor pkgDesc) of
     Just licenseText -> do
-      message writeOpts "\nCreating LICENSE..."
+      message writeOpts T.Log "Creating LICENSE..."
       writeFileSafe writeOpts "LICENSE" licenseText
-    Nothing -> message writeOpts "Warning: unknown license type, you must put a copy in LICENSE yourself."
+    Nothing -> message writeOpts T.Warning "unknown license type, you must put a copy in LICENSE yourself."
   where
     getLid (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) =
       Just lid
@@ -195,7 +197,7 @@ writeLicense writeOpts pkgDesc = do
 
 -- | Writes the changelog to the current directory.
 --
-writeChangeLog :: WriteOpts -> PkgDescription -> IO ()
+writeChangeLog :: Interactive m => WriteOpts -> PkgDescription -> m ()
 writeChangeLog opts pkgDesc
   | Just docs <- _pkgExtraDocFiles pkgDesc
   , defaultChangelog `Set.member` docs = go
@@ -211,20 +213,20 @@ writeChangeLog opts pkgDesc
     ]
 
   go = do
-    message opts ("Creating " ++ defaultChangelog ++"...")
+    message opts T.Log ("Creating " ++ defaultChangelog ++"...")
     writeFileSafe opts defaultChangelog changeLog
 
 -- -------------------------------------------------------------------- --
 -- Utilities
 
 -- | Possibly generate a message to stdout, taking into account the
 --   --quiet flag.
-message :: Interactive m => WriteOpts -> String -> m ()
+message :: Interactive m => WriteOpts -> T.Severity -> String -> m ()
 message opts = T.message (_optVerbosity opts)
 
 -- | Write a file \"safely\" if it doesn't exist, backing up any existing version when
 --   the overwrite flag is set.
-writeFileSafe :: WriteOpts -> FilePath -> String -> IO ()
+writeFileSafe :: Interactive m => WriteOpts -> FilePath -> String -> m ()
 writeFileSafe opts fileName content = do
     exists <- doesFileExist fileName
 
@@ -235,7 +237,7 @@ writeFileSafe opts fileName content = do
 
     go exists
 
-    message opts $ action ++ " file " ++ fileName ++ "..."
+    message opts T.Log $ action ++ " file " ++ fileName ++ "..."
     writeFile fileName content
   where
     doOverwrite = _optOverwrite opts
@@ -245,9 +247,8 @@ writeFileSafe opts fileName content = do
         removeExistingFile fileName
       | exists, not doOverwrite = do
         newName <- findNewPath fileName
-        message opts $ concat
-          [ "Warning: "
-          , fileName
+        message opts T.Log $ concat
+          [ fileName
           , " already exists. Backing up old version in "
           , newName
           ]
@@ -256,7 +257,7 @@ writeFileSafe opts fileName content = do
         removeExistingFile fileName
       | otherwise = return ()
 
-writeDirectoriesSafe :: WriteOpts -> [String] -> IO ()
+writeDirectoriesSafe :: Interactive m => WriteOpts -> [String] -> m ()
 writeDirectoriesSafe opts dirs = for_ dirs $ \dir -> do
     exists <- doesDirectoryExist dir
 
@@ -267,7 +268,7 @@ writeDirectoriesSafe opts dirs = for_ dirs $ \dir -> do
 
     go dir exists
 
-    message opts $ action ++ " directory ./" ++ dir ++ "..."
+    message opts T.Log $ action ++ " directory ./" ++ dir ++ "..."
     createDirectory dir
   where
     doOverwrite = _optOverwrite opts
@@ -277,9 +278,8 @@ writeDirectoriesSafe opts dirs = for_ dirs $ \dir -> do
         removeDirectory dir
       | exists, not doOverwrite = do
         newDir <- findNewPath dir
-        message opts $ concat
-          [ "Warning: "
-          , dir
+        message opts T.Log $ concat
+          [ dir
           , " already exists. Backing up old version in "
           , newDir
           ]

cabal-install/src/Distribution/Client/Init/Types.hs

@@ -37,6 +37,7 @@ module Distribution.Client.Init.Types
 , BreakException(..)
 , PurePrompt(..)
 , evalPrompt
+, Severity(..)
   -- * Aliases
 , IsLiterate
 , IsSimple
@@ -311,6 +312,7 @@ class Monad m => Interactive m where
     canonicalizePathNoThrow :: FilePath -> m FilePath
     readProcessWithExitCode :: FilePath -> [String] -> String -> m (ExitCode, String, String)
     getEnvironment :: m [(String, String)]
+    getCurrentYear :: m Integer
     listFilesInside :: (FilePath -> m Bool) -> FilePath -> m [FilePath]
     listFilesRecursive :: FilePath -> m [FilePath]
 
@@ -320,10 +322,11 @@ class Monad m => Interactive m where
     createDirectory :: FilePath -> m ()
     removeDirectory :: FilePath -> m ()
     writeFile :: FilePath -> String -> m ()
+    removeExistingFile :: FilePath -> m ()
     copyFile :: FilePath -> FilePath -> m ()
     renameDirectory :: FilePath -> FilePath -> m ()
-    message :: Verbosity -> String -> m ()
     hFlush :: System.IO.Handle -> m ()
+    message :: Verbosity -> Severity -> String -> m ()
 
     -- misc functions
     break :: m Bool
@@ -341,6 +344,7 @@ instance Interactive IO where
     canonicalizePathNoThrow = P.canonicalizePathNoThrow
     readProcessWithExitCode = P.readProcessWithExitCode
     getEnvironment = P.getEnvironment
+    getCurrentYear = P.getCurrentYear
     listFilesInside = P.listFilesInside
     listFilesRecursive = P.listFilesRecursive
 
@@ -349,10 +353,12 @@ instance Interactive IO where
     createDirectory = P.createDirectory
     removeDirectory = P.removeDirectoryRecursive
     writeFile = P.writeFile
+    removeExistingFile = P.removeExistingFile
     copyFile = P.copyFile
     renameDirectory = P.renameDirectory
-    message q = unless (q == silent) . putStrLn
     hFlush = System.IO.hFlush
+    message q severity = unless (q == silent)
+      . putStrLn . (("\n" ++ show severity ++ ": ") ++)
 
     break = return False
     throwPrompt = throwM
@@ -372,20 +378,25 @@ instance Interactive PurePrompt where
       input <- pop
       return (ExitSuccess, input, "")
     getEnvironment = fmap (map read) popList
+    getCurrentYear = fmap read pop
     listFilesInside pred' !_ = do
       input <- map splitDirectories <$> popList
       map joinPath <$> filterM (fmap and . traverse pred') input
     listFilesRecursive !_ = popList
 
     putStr !_ = return ()
     putStrLn !_ = return ()
-    createDirectory !_ = return ()
-    removeDirectory !_ = return ()
-    writeFile !_ !_ = return ()
-    copyFile !_ !_ = return ()
-    renameDirectory !_ !_ = return ()
-    message !_ !_ = return ()
+    createDirectory !d = checkInvalidPath d ()
+    removeDirectory !d = checkInvalidPath d ()
+    writeFile !f !_ = checkInvalidPath f ()
+    removeExistingFile !f = checkInvalidPath f ()
+    copyFile !f !_ = checkInvalidPath f ()
+    renameDirectory !d !_ = checkInvalidPath d ()
     hFlush _ = return ()
+    message !_ !severity !msg = case severity of
+      Error -> PurePrompt $ \_ -> Left $ BreakException
+        (show severity ++ ": " ++ msg)
+      _     -> return ()
 
     break = return True
     throwPrompt (BreakException e) = PurePrompt $ \s -> Left $ BreakException
@@ -410,6 +421,14 @@ popList = pop >>= \a -> case P.safeRead a of
     Nothing -> throwPrompt $ BreakException ("popList: " ++ show a)
     Just as -> return as
 
+checkInvalidPath :: String -> a -> PurePrompt a
+checkInvalidPath path act = 
+    -- The check below is done this way so it's easier to append
+    -- more invalid paths in the future, if necessary
+    if path `elem` ["."] then
+      throwPrompt $ BreakException $ "Invalid path: " ++ path
+    else
+      return act
 
 -- | A pure exception thrown exclusively by the pure prompter
 -- to cancel infinite loops in the prompting process.
@@ -421,6 +440,10 @@ newtype BreakException = BreakException String deriving (Eq, Show)
 
 instance Exception BreakException
 
+-- | Used to inform the intent of prompted messages.
+--
+data Severity = Log | Info | Warning | Error deriving (Eq, Show)
+
 -- | Convenience alias for the literate haskell flag
 --
 type IsLiterate = Bool

cabal-install/src/Distribution/Client/Init/Utils.hs

@@ -223,7 +223,7 @@ retrieveDependencies v flags mods' pkgIx = do
       modDeps = map (\(mn, ds) -> (mn, ds, M.lookup ds modMap)) mods
       -- modDeps = map (id &&& flip M.lookup modMap) mods
 
-  message v "\nGuessing dependencies..."
+  message v Log "Guessing dependencies..."
   nub . catMaybes <$> traverse (chooseDep v flags) modDeps
 
 -- Given a module and a list of installed packages providing it,
@@ -254,7 +254,7 @@ chooseDep v flags (importer, m, mipi) = case mipi of
 
         -- Otherwise, choose the latest version and issue a warning.
         pids -> do
-          message v ("\nWarning: multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.")
+          message v Warning ("multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.")
           return $ P.Dependency
               (P.pkgName . NE.head $ pids)
               (pvpize desugar . maximum . fmap P.pkgVersion $ pids)
@@ -263,12 +263,12 @@ chooseDep v flags (importer, m, mipi) = case mipi of
       -- if multiple packages are found, we refuse to choose between
       -- different packages and make the user do it
       grps     -> do
-        message v ("\nWarning: multiple packages found providing " ++ prettyShow m ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps))
-        message v "You will need to pick one and manually add it to the build-depends field."
+        message v Warning ("multiple packages found providing " ++ prettyShow m ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps))
+        message v Warning "You will need to pick one and manually add it to the build-depends field."
         return Nothing
 
   _ -> do
-    message v ("\nWarning: no package found providing " ++ prettyShow m ++ " in " ++ prettyShow importer ++ ".")
+    message v Warning ("no package found providing " ++ prettyShow m ++ " in " ++ prettyShow importer ++ ".")
     return Nothing
 
   where
@@ -293,7 +293,7 @@ mkPackageNameDep pkg = mkDependency pkg anyVersion (NES.singleton LMainLibName)
 fixupDocFiles :: Interactive m => Verbosity -> PkgDescription -> m PkgDescription
 fixupDocFiles v pkgDesc
   | _pkgCabalVersion pkgDesc < CabalSpecV1_18 = do
-    message v $ concat
+    message v Warning $ concat
       [ "Cabal spec versions < 1.18 do not support extra-doc-files. "
       , "Doc files will be treated as extra-src-files."
       ]

cabal-install/tests/UnitTests/Distribution/Client/Init.hs

@@ -8,6 +8,7 @@ import qualified UnitTests.Distribution.Client.Init.Interactive    as Interactiv
 import qualified UnitTests.Distribution.Client.Init.NonInteractive as NonInteractive
 import qualified UnitTests.Distribution.Client.Init.Golden         as Golden
 import qualified UnitTests.Distribution.Client.Init.Simple         as Simple
+import qualified UnitTests.Distribution.Client.Init.FileCreators   as FileCreators
 
 import UnitTests.Distribution.Client.Init.Utils
 
@@ -40,6 +41,7 @@ tests = do
          , NonInteractive.tests v initFlags' comp pkgIx srcDb
          , Golden.tests v initFlags' pkgIx srcDb
          , Simple.tests v initFlags' pkgIx srcDb
+         , FileCreators.tests v initFlags' comp pkgIx srcDb
          ]
   where
     v :: Verbosity