Merge pull request #8586 from haskell/mergify/bp/3.8/pr-8561

cabal init -i should sanitize suggested package name (fix #8404) (backport #8561)

cabal-install/src/Distribution/Client/Init/Interactive/Command.hs

@@ -297,7 +297,7 @@ cabalVersionPrompt flags = getCabalVersion flags $ do
 packageNamePrompt :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName
 packageNamePrompt srcDb flags = getPackageName flags $ do
     defName <- case packageDir flags of
-        Flag b -> return $ filePathToPkgName b
+        Flag b -> filePathToPkgName b
         NoFlag -> currentDirPkgName
 
     go $ DefaultPrompt defName

cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs

@@ -27,7 +27,6 @@ module Distribution.Client.Init.NonInteractive.Heuristics
   ) where
 
 import Distribution.Client.Compat.Prelude hiding (readFile, (<|>), many)
-import Distribution.Utils.Generic (safeLast)
 
 import Distribution.Simple.Setup (fromFlagOrDefault)
 
@@ -40,7 +39,7 @@ import System.FilePath
 import Distribution.CabalSpecVersion
 import Language.Haskell.Extension
 import Distribution.Version
-import Distribution.Types.PackageName (PackageName, mkPackageName)
+import Distribution.Types.PackageName (PackageName)
 import Distribution.Simple.Compiler
 import qualified Data.Set as Set
 import Distribution.FieldGrammar.Newtypes
@@ -82,24 +81,7 @@ guessLanguage _ = return defaultLanguage
 
 -- | Guess the package name based on the given root directory.
 guessPackageName :: Interactive m => FilePath -> m PackageName
-guessPackageName = fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories)
-                 . canonicalizePathNoThrow
-  where
-    -- Treat each span of non-alphanumeric characters as a hyphen. Each
-    -- hyphenated component of a package name must contain at least one
-    -- alphabetic character. An arbitrary character ('x') will be prepended if
-    -- this is not the case for the first component, and subsequent components
-    -- will simply be run together. For example, "1+2_foo-3" will become
-    -- "x12-foo3".
-    repair = repair' ('x' :) id
-    repair' invalid valid x = case dropWhile (not . isAlphaNum) x of
-        "" -> repairComponent ""
-        x' -> let (c, r) = first repairComponent $ span isAlphaNum x'
-              in c ++ repairRest r
-      where
-        repairComponent c | all isDigit c = invalid c
-                          | otherwise     = valid c
-    repairRest = repair' id ('-' :)
+guessPackageName = filePathToPkgName
 
 -- | Try to guess the license from an already existing @LICENSE@ file in
 --   the package directory, comparing the file contents with the ones

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

@@ -23,9 +23,9 @@ module Distribution.Client.Init.Utils
 ) where
 
 
-import qualified Prelude
+import qualified Prelude ()
 import Distribution.Client.Compat.Prelude hiding (putStrLn, empty, readFile, Parsec, many)
-import Distribution.Utils.Generic (isInfixOf)
+import Distribution.Utils.Generic (isInfixOf, safeLast)
 
 import Control.Monad (forM)
 
@@ -38,7 +38,6 @@ import Distribution.CabalSpecVersion (CabalSpecVersion(..))
 import Distribution.ModuleName (ModuleName)
 import Distribution.InstalledPackageInfo (InstalledPackageInfo, exposed)
 import qualified Distribution.Package as P
-import qualified Distribution.Types.PackageName as PN
 import Distribution.Simple.PackageIndex (InstalledPackageIndex, moduleNameIndex)
 import Distribution.Simple.Setup (Flag(..))
 import Distribution.Utils.String (trim)
@@ -277,11 +276,28 @@ chooseDep v flags (importer, m, mipi) = case mipi of
       Flag x -> x                   < CabalSpecV2_0
       NoFlag -> defaultCabalVersion < CabalSpecV2_0
 
-filePathToPkgName :: FilePath -> P.PackageName
-filePathToPkgName = PN.mkPackageName . Prelude.last . splitDirectories
+filePathToPkgName :: Interactive m => FilePath -> m P.PackageName
+filePathToPkgName = fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories)
+                 . canonicalizePathNoThrow
+  where
+    -- Treat each span of non-alphanumeric characters as a hyphen. Each
+    -- hyphenated component of a package name must contain at least one
+    -- alphabetic character. An arbitrary character ('x') will be prepended if
+    -- this is not the case for the first component, and subsequent components
+    -- will simply be run together. For example, "1+2_foo-3" will become
+    -- "x12-foo3".
+    repair = repair' ('x' :) id
+    repair' invalid valid x = case dropWhile (not . isAlphaNum) x of
+        "" -> repairComponent ""
+        x' -> let (c, r) = first repairComponent $ span isAlphaNum x'
+              in c ++ repairRest r
+      where
+        repairComponent c | all isDigit c = invalid c
+                          | otherwise     = valid c
+    repairRest = repair' id ('-' :)
 
 currentDirPkgName :: Interactive m => m P.PackageName
-currentDirPkgName = filePathToPkgName <$> getCurrentDirectory
+currentDirPkgName = filePathToPkgName =<< getCurrentDirectory
 
 mkPackageNameDep :: PackageName -> Dependency
 mkPackageNameDep pkg = mkDependency pkg anyVersion (NES.singleton LMainLibName)

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

@@ -68,7 +68,7 @@ tests v initFlags pkgIx srcDb = testGroup "golden"
     pkgDir = evalPrompt (getPackageDir initFlags)
       $ fromList ["."]
     pkgName = evalPrompt (packageNamePrompt srcDb initFlags)
-      $ fromList ["test-package", "y"]
+      $ fromList ["test-package", "test-package", "y"]
 
 goldenPkgDescTests
     :: Verbosity
@@ -337,6 +337,7 @@ pkgArgs :: NonEmpty String
 pkgArgs = fromList
     [ "5"
     , "foo-package"
+    , "foo-package"
     , "y"
     , "0.1.0.0"
     , "2"

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

@@ -140,6 +140,7 @@ createProjectTest pkgIx srcDb = testGroup "createProject tests"
               -- package name
               , "test-package"
               , "test-package"
+              , "test-package"
               -- version
               , "3.1.2.3"
               -- license
@@ -246,6 +247,7 @@ createProjectTest pkgIx srcDb = testGroup "createProject tests"
               -- package name
               , "test-package"
               , "test-package"
+              , "test-package"
               -- version
               , "3.1.2.3"
               -- license
@@ -337,6 +339,7 @@ createProjectTest pkgIx srcDb = testGroup "createProject tests"
               -- package name
               , "test-package"
               , "test-package"
+              , "test-package"
               -- version
               , "3.1.2.3"
               -- license
@@ -415,6 +418,7 @@ createProjectTest pkgIx srcDb = testGroup "createProject tests"
               -- package name
               , "test-package"
               , "test-package"
+              , "test-package"
               -- version
               , "3.1.2.3"
               -- license
@@ -507,6 +511,7 @@ createProjectTest pkgIx srcDb = testGroup "createProject tests"
               -- package name
               , "test-package"
               , "test-package"
+              , "test-package"
               -- version
               , "3.1.2.3"
               -- license
@@ -584,6 +589,7 @@ createProjectTest pkgIx srcDb = testGroup "createProject tests"
               -- package name
               , "test-package"
               , "test-package"
+              , "test-package"
               -- version
               , "3.1.2.3"
               -- license
@@ -667,6 +673,7 @@ createProjectTest pkgIx srcDb = testGroup "createProject tests"
               -- package name
               , "test-package"
               , "test-package"
+              , "test-package"
               -- version
               , "3.1.2.3"
               -- license
@@ -739,6 +746,7 @@ fileCreatorTests pkgIx srcDb _pkgName = testGroup "generators"
         let inputs = fromList
               [ "1"               -- pick the first cabal version in the list
               , "my-test-package" -- package name
+              , "my-test-package" -- current dir for the purpose of guessing the package name
               , "y"               -- "yes to prompt internal to package name"
               , "0.2.0.1"         -- package version
               , "2"               -- pick the second license in the list
@@ -796,22 +804,26 @@ interactiveTests srcDb = testGroup "Check top level getter functions"
           (packageNamePrompt srcDb) (mkPackageName "test-package")
           [ "test-package"
           , "test-package"
+          , "test-package"
           ]
       , testSimplePrompt "New package name 2"
           (packageNamePrompt srcDb) (mkPackageName "test-package")
           [ "test-package"
+          , "test-package"
           , ""
           ]
       , testSimplePrompt "Existing package name 1"
           (packageNamePrompt srcDb) (mkPackageName "test-package")
           [ "test-package"
+          , "test-package"
           , "cabal-install"
           , "y"
           , "test-package"
           ]
       , testSimplePrompt "Existing package name 2"
           (packageNamePrompt srcDb) (mkPackageName "cabal-install")
           [ "test-package"
+          , "test-package"
           , "cabal-install"
           , "n"
           ]

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

@@ -50,7 +50,12 @@ simpleCreateProjectTests v pkgIx srcDb pkgName =
     [ testCase "Simple lib createProject - no tests" $ do
       let inputs = fromList
             [ "1"           -- package type: Library
-            , "simple-test" -- package dir (ignored, piped to current dir due to prompt monad)
+            , "simple.test" -- package dir: used for determining package name;
+                            -- note that . will be replaced with - in a sanitization step,
+                            -- and we get the expected "simple-test" -- regression test for #8404
+            , "simple.test" -- package dir again: the prompt monad needs extra parameter for every
+                            -- IO call, and this one will be used for canonicalizePath,
+                            -- which is called as a part of sanitization
             , "n"           -- no tests
             ]
 
@@ -65,7 +70,7 @@ simpleCreateProjectTests v pkgIx srcDb pkgName =
         Right (settings', _) -> settings @=? settings'
 
     , testCase "Simple lib createProject - with tests" $ do
-      let inputs = fromList ["1", "simple-test", "y", "1"]
+      let inputs = fromList ["1", "simple-test", "simple-test", "y", "1"]
           flags = emptyFlags { packageType = Flag Library }
           settings = ProjectSettings
             (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion)
@@ -77,7 +82,7 @@ simpleCreateProjectTests v pkgIx srcDb pkgName =
         Right (settings', _) -> settings @=? settings'
 
     , testCase "Simple exe createProject" $ do
-      let inputs = fromList ["2", "simple-test"]
+      let inputs = fromList ["2", "simple-test", "simple-test"]
           flags = emptyFlags { packageType = Flag Executable }
           settings = ProjectSettings
             (WriteOpts False False False v "/home/test/2" Executable pkgName defaultCabalVersion)
@@ -89,7 +94,7 @@ simpleCreateProjectTests v pkgIx srcDb pkgName =
         Right (settings', _) -> settings @=? settings'
 
     , testCase "Simple lib+exe createProject - no tests" $ do
-      let inputs = fromList ["2", "simple-test", "n"]
+      let inputs = fromList ["2", "simple-test", "simple-test", "n"]
           flags = emptyFlags { packageType = Flag LibraryAndExecutable }
           settings = ProjectSettings
             (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)
@@ -100,7 +105,7 @@ simpleCreateProjectTests v pkgIx srcDb pkgName =
         Left e -> assertFailure $ "Failed to create simple lib+exe project: " ++ show e
         Right (settings', _) -> settings @=? settings'
     , testCase "Simple lib+exe createProject - with tests" $ do
-      let inputs = fromList ["2", "simple-test", "y", "1"]
+      let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"]
           flags = emptyFlags { packageType = Flag LibraryAndExecutable }
           settings = ProjectSettings
             (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)
@@ -113,7 +118,7 @@ simpleCreateProjectTests v pkgIx srcDb pkgName =
         Right (settings', _) -> settings @=? settings'
 
     , testCase "Simple standalone tests" $ do
-      let inputs = fromList ["2", "simple-test", "y", "1"]
+      let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"]
           flags = emptyFlags { packageType = Flag TestSuite }
           settings = ProjectSettings
             (WriteOpts False False False v "/home/test/2" TestSuite pkgName defaultCabalVersion)

changelog.d/pr-8561

@@ -0,0 +1,9 @@
+synopsis: cabal init -i should sanitize package name guessed from the directory name
+packages: cabal-install
+prs: #8561
+issues: #8404
+description: {
+    If the current directory name has any non-alphanumeric symbol in its name, the symbol will be replaced with a dash. Also, will make sure that the resulting package name starts with a letter.
+
+    This worked for cabal init -n already, and this PR only moves code around so that cabal init -i also benefits from this logic.
+}