Commit cca1cbc4 authored by byorgey's avatar byorgey
Browse files

Merge pull request #1770 from 23Skidoo/main-is

Add support for 'main-is' to 'cabal init'
parents fbadad3b 5310aa7e
......@@ -36,7 +36,7 @@ import Data.Char
import Data.List
( intercalate, nub, groupBy, (\\) )
import Data.Maybe
( fromMaybe, isJust, catMaybes )
( fromMaybe, isJust, catMaybes, listToMaybe )
import Data.Function
( on )
import qualified Data.Map as M
......@@ -69,7 +69,8 @@ import Distribution.Client.Init.Types
import Distribution.Client.Init.Licenses
( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20 )
import Distribution.Client.Init.Heuristics
( guessPackageName, guessAuthorNameMail, SourceFileEntry(..),
( guessPackageName, guessAuthorNameMail, guessMainFileCandidates,
SourceFileEntry(..),
scanForModules, neededBuildPrograms )
import Distribution.License
......@@ -266,8 +267,28 @@ getLibOrExec flags = do
[Library, Executable]
Nothing display False)
?>> return (Just Library)
mainFile <- if isLib /= Just Executable then return Nothing else
getMainFile flags
return $ flags { packageType = maybeToFlag isLib }
return $ flags { packageType = maybeToFlag isLib
, mainIs = maybeToFlag mainFile
}
-- | Try to guess the main file of the executable, and prompt the user to choose
-- one of them. Top-level modules including the word 'Main' in the file name
-- will be candidates, and shorter filenames will be preferred.
getMainFile :: InitFlags -> IO (Maybe FilePath)
getMainFile flags =
return (flagToMaybe $ mainIs flags)
?>> do
candidates <- guessMainFileCandidates flags
let showCandidate = either (++" (does not yet exist)") id
defaultFile = listToMaybe candidates
maybePrompt flags (either id (either id id) `fmap`
promptList "What is the main module of the executable"
candidates
defaultFile showCandidate True)
?>> return (fmap (either id id) defaultFile)
-- | Ask for the base language of the package.
getLanguage :: InitFlags -> IO InitFlags
......@@ -715,7 +736,7 @@ generateCabalFile fileName c =
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
[ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True
, generateBuildInfo Executable c
])
......
......@@ -15,11 +15,12 @@ module Distribution.Client.Init.Heuristics (
guessPackageName,
scanForModules, SourceFileEntry(..),
neededBuildPrograms,
guessMainFileCandidates,
guessAuthorNameMail,
knownCategories,
) where
import Distribution.Text (simpleParse)
import Distribution.Simple.Setup (Flag(..))
import Distribution.Simple.Setup (Flag(..), flagToMaybe)
import Distribution.ModuleName
( ModuleName, toFilePath )
import Distribution.Client.PackageIndex
......@@ -39,19 +40,49 @@ import Control.Arrow ( first )
import Control.Monad ( liftM )
import Data.Char ( isAlphaNum, isNumber, isUpper, isLower, isSpace )
import Data.Either ( partitionEithers )
import Data.List ( isPrefixOf )
import Data.Maybe ( mapMaybe, catMaybes, maybeToList )
import Data.Monoid ( mempty, mconcat )
import Data.List ( isInfixOf, isPrefixOf, isSuffixOf, sortBy )
import Data.Maybe ( mapMaybe, catMaybes, maybeToList, listToMaybe )
import Data.Monoid ( mempty, mappend, mconcat, )
import Data.Ord ( comparing )
import qualified Data.Set as Set ( fromList, toList )
import System.Directory ( getDirectoryContents,
import System.Directory ( getCurrentDirectory, getDirectoryContents,
doesDirectoryExist, doesFileExist, getHomeDirectory, )
import Distribution.Compat.Environment ( getEnvironment )
import System.FilePath ( takeExtension, takeBaseName, dropExtension,
(</>), (<.>), splitDirectories, makeRelative )
import Distribution.Client.Init.Types ( InitFlags(..) )
import Distribution.Client.Compat.Process ( readProcessWithExitCode )
import System.Exit ( ExitCode(..) )
-- | Return a list of candidate main files for this executable: top-level
-- modules including the word 'Main' in the file name. The list is sorted in
-- order of preference, shorter file names are preferred. 'Right's are existing
-- candidates and 'Left's are those that do not yet exist.
guessMainFileCandidates :: InitFlags -> IO [Either FilePath FilePath]
guessMainFileCandidates flags = do
dir <-
maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)
files <- getDirectoryContents dir
let existingCandidates = filter isMain files
-- We always want to give the user at least one default choice. If either
-- Main.hs or Main.lhs has already been created, then we don't want to
-- suggest the other; however, if neither has been created, then we
-- suggest both.
newCandidates =
if any (`elem` existingCandidates) ["Main.hs", "Main.lhs"]
then []
else ["Main.hs", "Main.lhs"]
candidates =
sortBy (\x y -> comparing (length . either id id) x y
`mappend` compare x y)
(map Left newCandidates ++ map Right existingCandidates)
return candidates
where
isMain f = (isInfixOf "Main" f || isInfixOf "main" f)
&& (isSuffixOf ".hs" f || isSuffixOf ".lhs" f)
-- | Guess the package name based on the given root directory.
guessPackageName :: FilePath -> IO P.PackageName
guessPackageName = liftM (P.PackageName . repair . last . splitDirectories)
......
......@@ -54,6 +54,7 @@ data InitFlags =
, extraSrc :: Maybe [String]
, packageType :: Flag PackageType
, mainIs :: Flag FilePath
, language :: Flag Language
, exposedModules :: Maybe [ModuleName]
......@@ -98,6 +99,7 @@ instance Monoid InitFlags where
, category = mempty
, extraSrc = mempty
, packageType = mempty
, mainIs = mempty
, language = mempty
, exposedModules = mempty
, otherModules = mempty
......@@ -125,6 +127,7 @@ instance Monoid InitFlags where
, category = combine category
, extraSrc = combine extraSrc
, packageType = combine packageType
, mainIs = combine mainIs
, language = combine language
, exposedModules = combine exposedModules
, otherModules = combine otherModules
......
......@@ -1401,6 +1401,12 @@ initCommand = CommandUI {
(\v flags -> flags { IT.packageType = v })
(noArg (Flag IT.Executable))
, option [] ["main-is"]
"Specify the main module."
IT.mainIs
(\v flags -> flags { IT.mainIs = v })
(reqArgFlag "FILE")
, option [] ["language"]
"Specify the default language."
IT.language
......
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