Commit 85fecab0 authored by Ian D. Bollinger's avatar Ian D. Bollinger

Fix #1569.

* Change `guessPackageName` to translate arbitrary strings into valid
package names.
* Change type of `packageName` flag from String to PackageName and
reject names that do not pass PackageName's corresponding parse
function.
parent 774d76d8
......@@ -154,7 +154,7 @@ getPackageName flags = do
?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)
pkgName' <- return (flagToMaybe $ packageName flags)
?>> maybePrompt flags (promptStr "Package name" guess)
?>> maybePrompt flags (prompt "Package name" guess)
?>> return guess
return $ flags { packageName = maybeToFlag pkgName' }
......@@ -597,7 +597,7 @@ writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do
message flags "Error: no package name provided."
return False
writeCabalFile flags@(InitFlags{packageName = Flag p}) = do
let cabalFileName = p ++ ".cabal"
let cabalFileName = display p ++ ".cabal"
message flags $ "Generating " ++ cabalFileName ++ "..."
writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)
return True
......@@ -647,7 +647,7 @@ generateCabalFile fileName c =
$$ text ""
else empty)
$$
vcat [ fieldS "name" (packageName c)
vcat [ field "name" (packageName c)
(Just "The name of the package.")
True
......@@ -712,7 +712,9 @@ generateCabalFile fileName c =
, case packageType c of
Flag Executable ->
text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ nest 2 (vcat
text "\nexecutable" <+>
text (maybe "" display . flagToMaybe $ packageName c) $$
nest 2 (vcat
[ fieldS "main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True
, generateBuildInfo Executable c
......
......@@ -24,6 +24,7 @@ import Distribution.ModuleName
( ModuleName, toFilePath )
import Distribution.Client.PackageIndex
( allPackagesByName )
import qualified Distribution.Package as P
import qualified Distribution.PackageDescription as PD
( category, packageDescription )
import Distribution.Simple.Utils
......@@ -34,8 +35,9 @@ import Language.Haskell.Extension ( Extension )
import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) )
import Control.Applicative ( pure, (<$>), (<*>) )
import Control.Arrow ( first )
import Control.Monad ( liftM )
import Data.Char ( isUpper, isLower, isSpace )
import Data.Char ( isAlphaNum, isNumber, isUpper, isLower, isSpace )
import Data.Either ( partitionEithers )
import Data.List ( isPrefixOf )
import Data.Maybe ( mapMaybe, catMaybes, maybeToList )
......@@ -50,9 +52,26 @@ import System.FilePath ( takeExtension, takeBaseName, dropExtension,
import Distribution.Client.Compat.Process ( readProcessWithExitCode )
import System.Exit ( ExitCode(..) )
-- |Guess the package name based on the given root directory
guessPackageName :: FilePath -> IO String
guessPackageName = liftM (last . splitDirectories) . tryCanonicalizePath
-- | Guess the package name based on the given root directory.
guessPackageName :: FilePath -> IO P.PackageName
guessPackageName = liftM (P.PackageName . repair . last . splitDirectories)
. tryCanonicalizePath
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 $ break (not . isAlphaNum) x'
in c ++ repairRest r
where
repairComponent c | all isNumber c = invalid c
| otherwise = valid c
repairRest = repair' id ('-' :)
-- |Data type of source files found in the working directory
data SourceFileEntry = SourceFileEntry
......
......@@ -41,7 +41,7 @@ data InitFlags =
, noComments :: Flag Bool
, minimal :: Flag Bool
, packageName :: Flag String
, packageName :: Flag P.PackageName
, version :: Flag Version
, cabalVersion :: Flag VersionRange
, license :: Flag License
......
......@@ -1323,7 +1323,9 @@ initCommand = CommandUI {
, option ['p'] ["package-name"]
"Name of the Cabal package to create."
IT.packageName (\v flags -> flags { IT.packageName = v })
(reqArgFlag "PACKAGE")
(reqArg "PACKAGE" (readP_to_E ("Cannot parse package name: "++)
(toFlag `fmap` parse))
(flagToList . fmap display))
, option [] ["version"]
"Initial version of the package."
......
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