Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
5310aa7e
Commit
5310aa7e
authored
Apr 12, 2014
by
Mikhail Glushenkov
Browse files
Address review comments.
parent
c8250aa8
Changes
4
Hide whitespace changes
Inline
Side-by-side
cabal-install/Distribution/Client/Init.hs
View file @
5310aa7e
...
...
@@ -34,13 +34,9 @@ import Data.Time
import
Data.Char
(
toUpper
)
import
Data.List
(
intercalate
,
nub
,
groupBy
,
(
\\
)
,
sortBy
,
isInfixOf
,
isSuffixOf
)
(
intercalate
,
nub
,
groupBy
,
(
\\
)
)
import
Data.Maybe
(
fromMaybe
,
isJust
,
catMaybes
,
listToMaybe
)
import
Data.Ord
(
comparing
)
import
Data.Monoid
(
mappend
)
import
Data.Function
(
on
)
import
qualified
Data.Map
as
M
...
...
@@ -73,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
...
...
@@ -271,44 +268,27 @@ getLibOrExec flags = do
Nothing
display
False
)
?>>
return
(
Just
Library
)
mainFile
<-
if
isLib
/=
Just
Executable
then
return
Nothing
else
return
(
mainIs
flags
)
?>>
guessAndPromptMainFile
flags
getMainFile
flags
return
$
flags
{
packageType
=
maybeToFlag
isLib
,
mainIs
=
mainFile
,
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' will
-- be candidates, and shorter filenames will be preferred.
guessAndPromptMainFile
::
InitFlags
->
IO
(
Maybe
FilePath
)
guessAndPromptMainFile
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
)
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
)
where
isMain
f
=
isInfixOf
"Main"
f
&&
(
isSuffixOf
".hs"
f
||
isSuffixOf
".lhs"
f
)
-- | 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
...
...
@@ -756,7 +736,7 @@ generateCabalFile fileName c =
text
"
\n
executable"
<+>
text
(
maybe
""
display
.
flagToMaybe
$
packageName
c
)
$$
nest
2
(
vcat
[
fieldS
"main-is"
(
maybeToFlag
$
mainIs
c
)
(
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
])
...
...
cabal-install/Distribution/Client/Init/Heuristics.hs
View file @
5310aa7e
...
...
@@ -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
)
...
...
cabal-install/Distribution/Client/Init/Types.hs
View file @
5310aa7e
...
...
@@ -54,7 +54,7 @@ data InitFlags =
,
extraSrc
::
Maybe
[
String
]
,
packageType
::
Flag
PackageType
,
mainIs
::
Maybe
FilePath
,
mainIs
::
Flag
FilePath
,
language
::
Flag
Language
,
exposedModules
::
Maybe
[
ModuleName
]
...
...
@@ -127,7 +127,7 @@ instance Monoid InitFlags where
,
category
=
combine
category
,
extraSrc
=
combine
extraSrc
,
packageType
=
combine
packageType
,
mainIs
=
getLast
$
combine
(
Last
.
mainIs
)
,
mainIs
=
combine
mainIs
,
language
=
combine
language
,
exposedModules
=
combine
exposedModules
,
otherModules
=
combine
otherModules
...
...
cabal-install/Distribution/Client/Setup.hs
View file @
5310aa7e
...
...
@@ -1404,7 +1404,7 @@ initCommand = CommandUI {
"Specify the main module."
IT
.
mainIs
(
\
v
flags
->
flags
{
IT
.
mainIs
=
v
})
(
reqArg
'
"FILE"
Just
maybeToList
)
(
reqArg
Flag
"FILE"
)
,
option
[]
[
"language"
]
"Specify the default language."
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment