Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
74ffcfd1
Commit
74ffcfd1
authored
Nov 05, 2012
by
EyalLotem
Browse files
hlint police
parent
3744251c
Changes
19
Hide whitespace changes
Inline
Side-by-side
cabal-install/Distribution/Client/Check.hs
View file @
74ffcfd1
...
...
@@ -72,10 +72,10 @@ check verbosity = do
isDistError
_
=
True
errors
=
filter
isDistError
packageChecks
unless
(
null
errors
)
$
do
unless
(
null
errors
)
$
putStrLn
"Hackage would reject this package."
when
(
null
packageChecks
)
$
do
when
(
null
packageChecks
)
$
putStrLn
"No errors or warnings could be found in the package."
return
(
null
packageChecks
)
...
...
cabal-install/Distribution/Client/Config.hs
View file @
74ffcfd1
...
...
@@ -85,7 +85,7 @@ import Data.Maybe
import
Data.Monoid
(
Monoid
(
..
)
)
import
Control.Monad
(
when
,
foldM
,
liftM
)
(
unless
,
foldM
,
liftM
)
import
qualified
Distribution.Compat.ReadP
as
Parse
(
option
)
import
qualified
Text.PrettyPrint
as
Disp
...
...
@@ -281,15 +281,15 @@ loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do
writeConfigFile
configFile
commentConf
initialConf
return
initialConf
Just
(
ParseOk
ws
conf
)
->
do
when
(
not
$
null
ws
)
$
warn
verbosity
$
unless
(
null
ws
)
$
warn
verbosity
$
unlines
(
map
(
showPWarning
configFile
)
ws
)
return
conf
Just
(
ParseFailed
err
)
->
do
let
(
line
,
msg
)
=
locatedErrorMsg
err
warn
verbosity
$
"Error parsing config file "
++
configFile
++
maybe
""
(
\
n
->
":"
++
show
n
)
line
++
":
\n
"
++
msg
warn
verbosity
$
"Using default configuration."
++
maybe
""
(
\
n
->
':'
:
show
n
)
line
++
":
\n
"
++
msg
warn
verbosity
"Using default configuration."
initialSavedConfig
where
...
...
cabal-install/Distribution/Client/Configure.hs
View file @
74ffcfd1
...
...
@@ -167,10 +167,9 @@ planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex
.
addConstraints
-- '--enable-tests' and '--enable-benchmarks' constraints from
-- command line
[
PackageConstraintStanzas
(
packageName
pkg
)
$
concat
[
if
testsEnabled
then
[
TestStanzas
]
else
[]
,
if
benchmarksEnabled
then
[
BenchStanzas
]
else
[]
]
[
PackageConstraintStanzas
(
packageName
pkg
)
$
[
TestStanzas
|
testsEnabled
]
++
[
BenchStanzas
|
benchmarksEnabled
]
]
$
standardInstallPolicy
...
...
cabal-install/Distribution/Client/Dependency/Modular/Explore.hs
View file @
74ffcfd1
...
...
@@ -72,7 +72,7 @@ combine var ((k, ( d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $
-- | Naive backtracking exploration of the search tree. This will yield correct
-- assignments only once the tree itself is validated.
explore
::
Alternative
m
=>
Tree
a
->
(
Assignment
->
m
(
Assignment
,
RevDepMap
)
)
explore
::
Alternative
m
=>
Tree
a
->
Assignment
->
m
(
Assignment
,
RevDepMap
)
explore
=
cata
go
where
go
(
FailF
_
_
)
_
=
A
.
empty
...
...
@@ -80,24 +80,25 @@ explore = cata go
go
(
PChoiceF
qpn
_
ts
)
(
A
pa
fa
sa
)
=
asum
$
-- try children in order,
P
.
mapWithKey
-- when descending ...
(
\
k
r
->
r
(
A
(
M
.
insert
qpn
k
pa
)
fa
sa
))
$
-- record the pkg choice
(
\
k
r
->
r
(
A
(
M
.
insert
qpn
k
pa
)
fa
sa
))
-- record the pkg choice
ts
go
(
FChoiceF
qfn
_
_
_
ts
)
(
A
pa
fa
sa
)
=
asum
$
-- try children in order,
P
.
mapWithKey
-- when descending ...
(
\
k
r
->
r
(
A
pa
(
M
.
insert
qfn
k
fa
)
sa
))
$
-- record the flag choice
(
\
k
r
->
r
(
A
pa
(
M
.
insert
qfn
k
fa
)
sa
))
-- record the flag choice
ts
go
(
SChoiceF
qsn
_
_
ts
)
(
A
pa
fa
sa
)
=
asum
$
-- try children in order,
P
.
mapWithKey
-- when descending ...
(
\
k
r
->
r
(
A
pa
fa
(
M
.
insert
qsn
k
sa
)))
$
-- record the flag choice
(
\
k
r
->
r
(
A
pa
fa
(
M
.
insert
qsn
k
sa
)))
-- record the flag choice
ts
go
(
GoalChoiceF
ts
)
a
=
casePSQ
ts
A
.
empty
-- empty goal choice is an internal error
(
\
_k
v
_xs
->
v
a
)
-- commit to the first goal choice
-- | Version of 'explore' that returns a 'Log'.
exploreLog
::
Tree
(
Maybe
(
ConflictSet
QPN
))
->
(
Assignment
->
Log
Message
(
Assignment
,
RevDepMap
))
exploreLog
::
Tree
(
Maybe
(
ConflictSet
QPN
))
->
Assignment
->
Log
Message
(
Assignment
,
RevDepMap
)
exploreLog
=
cata
go
where
go
(
FailF
c
fr
)
_
=
failWith
(
Failure
c
fr
)
...
...
cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
View file @
74ffcfd1
...
...
@@ -114,10 +114,10 @@ convGPD os arch cid pi
PInfo
(
maybe
[]
(
convCondTree
os
arch
cid
pi
fds
(
const
True
)
)
libs
++
concatMap
(
convCondTree
os
arch
cid
pi
fds
(
const
True
)
.
snd
)
exes
++
(
prefix
(
Stanza
(
SN
pi
TestStanzas
))
(
L
.
map
(
convCondTree
os
arch
cid
pi
fds
(
const
True
)
.
snd
)
tests
)
)
++
(
prefix
(
Stanza
(
SN
pi
BenchStanzas
))
(
L
.
map
(
convCondTree
os
arch
cid
pi
fds
(
const
True
)
.
snd
)
benchs
))
)
prefix
(
Stanza
(
SN
pi
TestStanzas
))
(
L
.
map
(
convCondTree
os
arch
cid
pi
fds
(
const
True
)
.
snd
)
tests
)
++
prefix
(
Stanza
(
SN
pi
BenchStanzas
))
(
L
.
map
(
convCondTree
os
arch
cid
pi
fds
(
const
True
)
.
snd
)
benchs
))
fds
[]
-- TODO: add encaps
Nothing
...
...
cabal-install/Distribution/Client/Dependency/Modular/Package.hs
View file @
74ffcfd1
...
...
@@ -2,6 +2,7 @@ module Distribution.Client.Dependency.Modular.Package
(
module
Distribution
.
Client
.
Dependency
.
Modular
.
Package
,
module
Distribution
.
Package
)
where
import
Control.Arrow
(
first
)
import
Data.List
as
L
import
Data.Map
as
M
...
...
@@ -45,7 +46,7 @@ showI (I v (Inst (InstalledPackageId i))) = showVer v ++ "/installed" ++ shortId
where
-- A hack to extract the beginning of the package ABI hash
shortId
=
snip
(
splitAt
4
)
(
++
"..."
)
.
snip
(
(
\
(
x
,
y
)
->
(
reverse
x
,
y
))
.
break
(
==
'-'
)
.
reverse
)
(
'-'
:
)
snip
(
first
reverse
.
break
(
==
'-'
)
.
reverse
)
(
'-'
:
)
snip
p
f
xs
=
case
p
xs
of
(
ys
,
zs
)
->
(
if
L
.
null
zs
then
id
else
f
)
ys
...
...
@@ -82,7 +83,7 @@ data Q a = Q PP a
deriving
(
Eq
,
Ord
,
Show
)
-- | Standard string representation of a qualified entity.
showQ
::
(
a
->
String
)
->
(
Q
a
->
String
)
showQ
::
(
a
->
String
)
->
Q
a
->
String
showQ
showa
(
Q
[]
x
)
=
showa
x
showQ
showa
(
Q
pp
x
)
=
showPP
pp
++
"."
++
showa
x
...
...
cabal-install/Distribution/Client/Index.hs
View file @
74ffcfd1
...
...
@@ -62,18 +62,18 @@ index verbosity indexFlags path' = do
let
runRemoveSource
=
not
.
null
$
refsToRemove
let
runList
=
fromFlagOrDefault
False
(
indexList
indexFlags
)
unless
(
or
[
runInit
,
runLinkSource
,
runRemoveSource
,
runList
])
$
do
unless
(
or
[
runInit
,
runLinkSource
,
runRemoveSource
,
runList
])
$
die
"no arguments passed to the 'index' command"
path
<-
validateIndexPath
path'
when
runInit
$
do
when
runInit
$
createEmpty
verbosity
path
when
runLinkSource
$
do
when
runLinkSource
$
addBuildTreeRefs
verbosity
path
refsToAdd
when
runRemoveSource
$
do
when
runRemoveSource
$
removeBuildTreeRefs
verbosity
path
refsToRemove
when
runList
$
do
...
...
@@ -84,7 +84,7 @@ index verbosity indexFlags path' = do
buildTreeRefFromPath
::
FilePath
->
IO
(
Maybe
BuildTreeRef
)
buildTreeRefFromPath
dir
=
do
dirExists
<-
doesDirectoryExist
dir
when
(
not
dirExists
)
$
do
unless
dirExists
$
die
$
"directory '"
++
dir
++
"' does not exist"
_
<-
findPackageDesc
dir
return
.
Just
$
BuildTreeRef
{
buildTreePath
=
dir
}
...
...
@@ -103,7 +103,7 @@ readBuildTreePath entry = case Tar.entryContent entry of
readBuildTreePaths
::
Tar
.
Entries
->
[
FilePath
]
readBuildTreePaths
=
catMaybes
.
Tar
.
foldrEntries
(
\
e
r
->
(
readBuildTreePath
e
)
:
r
)
.
Tar
.
foldrEntries
(
\
e
r
->
readBuildTreePath
e
:
r
)
[]
error
-- | Given a path to a tar archive, extract all references to local build trees.
...
...
@@ -135,7 +135,7 @@ validateIndexPath path' = do
if
(
==
".tar"
)
.
takeExtension
$
path
then
return
path
else
do
dirExists
<-
doesDirectoryExist
path
unless
dirExists
$
do
unless
dirExists
$
die
$
"directory does not exist: '"
++
path
++
"'"
return
$
path
</>
defaultIndexFileName
...
...
@@ -163,7 +163,7 @@ addBuildTreeRefs verbosity path l' = do
-- Add only those paths that aren't already in the index.
treesToAdd
<-
mapM
buildTreeRefFromPath
(
l
\\
treesInIndex
)
let
entries
=
map
writeBuildTreeRef
(
catMaybes
treesToAdd
)
when
(
not
.
null
$
entries
)
$
do
unless
(
null
entries
)
$
do
offset
<-
fmap
(
Tar
.
foldrEntries
(
\
e
acc
->
Tar
.
entrySizeInBytes
e
+
acc
)
0
error
.
Tar
.
read
)
$
BS
.
readFile
path
...
...
@@ -194,7 +194,7 @@ removeBuildTreeRefs verbosity path l' = do
where
p
l
entry
=
case
readBuildTreePath
entry
of
Nothing
->
True
(
Just
pth
)
->
not
$
any
(
==
pth
)
l
(
Just
pth
)
->
pth
`
notElem
`
l
-- | List the local build trees that are referred to from the index.
listBuildTreeRefs
::
Verbosity
->
FilePath
->
IO
[
FilePath
]
...
...
@@ -205,7 +205,7 @@ listBuildTreeRefs verbosity path = do
pkgIndex
<-
fmap
packageIndex
.
getSourcePackages
verbosity
$
[
repo
]
let
buildTreeRefs
=
[
pkgPath
|
(
LocalUnpackedPackage
pkgPath
)
<-
map
packageSource
.
allPackages
$
pkgIndex
]
when
(
null
buildTreeRefs
)
$
do
when
(
null
buildTreeRefs
)
$
notice
verbosity
$
"Index file '"
++
path
++
"' has no references to local build trees."
return
buildTreeRefs
...
...
@@ -214,5 +214,5 @@ listBuildTreeRefs verbosity path = do
checkIndexExists
::
FilePath
->
IO
()
checkIndexExists
path
=
do
indexExists
<-
doesFileExist
path
when
(
not
indexExists
)
$
do
unless
indexExists
$
die
$
"index does not exist: '"
++
path
++
"'"
cabal-install/Distribution/Client/IndexUtils.hs
View file @
74ffcfd1
...
...
@@ -55,7 +55,7 @@ import Distribution.Simple.Utils
(
die
,
warn
,
info
,
fromUTF8
,
findPackageDesc
)
import
Data.Char
(
isAlphaNum
)
import
Data.Maybe
(
cat
Maybe
s
,
fromMaybe
)
import
Data.Maybe
(
map
Maybe
,
fromMaybe
)
import
Data.List
(
isPrefixOf
)
import
Data.Monoid
(
Monoid
(
..
))
import
qualified
Data.Map
as
Map
...
...
@@ -165,7 +165,7 @@ readRepoIndex verbosity repo =
in
handleNotFound
$
do
warnIfIndexIsOld
indexFile
whenCacheOutOfDate
indexFile
cacheFile
$
do
info
verbosity
$
"Updating the index cache file..."
info
verbosity
"Updating the index cache file..."
updatePackageIndexCacheFile
indexFile
cacheFile
readPackageIndexCacheFile
mkAvailablePackage
indexFile
cacheFile
...
...
@@ -212,7 +212,7 @@ readRepoIndex verbosity repo =
updateRepoIndexCache
::
Verbosity
->
Repo
->
IO
()
updateRepoIndexCache
verbosity
repo
=
whenCacheOutOfDate
indexFile
cacheFile
$
do
info
verbosity
$
"Updating the index cache file..."
info
verbosity
"Updating the index cache file..."
updatePackageIndexCacheFile
indexFile
cacheFile
where
indexFile
=
repoLocalDir
repo
</>
"00-index.tar"
...
...
@@ -338,8 +338,7 @@ extractPrefs entry = case Tar.entryContent entry of
_
->
Nothing
parsePreferredVersions
::
String
->
[
Dependency
]
parsePreferredVersions
=
catMaybes
.
map
simpleParse
parsePreferredVersions
=
mapMaybe
simpleParse
.
filter
(
not
.
isPrefixOf
"--"
)
.
lines
...
...
@@ -507,7 +506,7 @@ showIndexCacheEntry entry = case entry of
CachePreference
dep
->
"pref-ver: "
++
display
dep
readIndexCache
::
BSS
.
ByteString
->
[
IndexCacheEntry
]
readIndexCache
=
cat
Maybe
s
.
map
readIndexCacheEntry
.
BSS
.
lines
readIndexCache
=
map
Maybe
readIndexCacheEntry
.
BSS
.
lines
showIndexCache
::
[
IndexCacheEntry
]
->
String
showIndexCache
=
unlines
.
map
showIndexCacheEntry
cabal-install/Distribution/Client/Init.hs
View file @
74ffcfd1
...
...
@@ -48,7 +48,7 @@ import Control.Monad
(
(
>=>
),
join
)
#
endif
import
Control.Arrow
(
(
&&&
)
)
(
(
&&&
)
,
(
***
)
)
import
Text.PrettyPrint
hiding
(
mode
,
cat
)
...
...
@@ -59,7 +59,7 @@ import Distribution.Version
import
Distribution.Verbosity
(
Verbosity
)
import
Distribution.ModuleName
(
ModuleName
,
fromString
)
(
ModuleName
,
fromString
)
-- And for the Text instance
import
Distribution.InstalledPackageInfo
(
InstalledPackageInfo
,
sourcePackageId
,
exposed
)
import
qualified
Distribution.Package
as
P
...
...
@@ -74,8 +74,6 @@ import Distribution.Client.Init.Heuristics
import
Distribution.License
(
License
(
..
),
knownLicenses
)
import
Distribution.ModuleName
(
)
-- for the Text instance
import
Distribution.ReadE
(
runReadE
,
readP_to_E
)
...
...
@@ -186,7 +184,8 @@ getLicense flags = do
-- darcs repo.
getAuthorInfo
::
InitFlags
->
IO
InitFlags
getAuthorInfo
flags
=
do
(
authorName
,
authorEmail
)
<-
(
\
(
a
,
e
)
->
(
flagToMaybe
a
,
flagToMaybe
e
))
`
fmap
`
guessAuthorNameMail
(
authorName
,
authorEmail
)
<-
(
flagToMaybe
***
flagToMaybe
)
`
fmap
`
guessAuthorNameMail
authorName'
<-
return
(
flagToMaybe
$
author
flags
)
?>>
maybePrompt
flags
(
promptStr
"Author name"
authorName
)
?>>
return
authorName
...
...
@@ -237,9 +236,9 @@ getLibOrExec :: InitFlags -> IO InitFlags
getLibOrExec
flags
=
do
isLib
<-
return
(
flagToMaybe
$
packageType
flags
)
?>>
maybePrompt
flags
(
either
(
const
Library
)
id
`
fmap
`
(
promptList
"What does the package build"
[
Library
,
Executable
]
Nothing
display
False
)
)
promptList
"What does the package build"
[
Library
,
Executable
]
Nothing
display
False
)
?>>
return
(
Just
Library
)
return
$
flags
{
packageType
=
maybeToFlag
isLib
}
...
...
@@ -250,13 +249,9 @@ getLanguage flags = do
lang
<-
return
(
flagToMaybe
$
language
flags
)
?>>
maybePrompt
flags
(
either
UnknownLanguage
id
`
fmap
`
(
promptList
"What base language is the package written in"
[
Haskell2010
,
Haskell98
]
(
Just
Haskell2010
)
display
True
)
)
promptList
"What base language is the package written in"
[
Haskell2010
,
Haskell98
]
(
Just
Haskell2010
)
display
True
)
?>>
return
(
Just
Haskell2010
)
return
$
flags
{
language
=
maybeToFlag
lang
}
...
...
@@ -264,7 +259,7 @@ getLanguage flags = do
-- | Ask whether to generate explanatory comments.
getGenComments
::
InitFlags
->
IO
InitFlags
getGenComments
flags
=
do
genComments
<-
return
(
not
<$>
(
flagToMaybe
$
noComments
flags
))
genComments
<-
return
(
not
<$>
flagToMaybe
(
noComments
flags
))
?>>
maybePrompt
flags
(
promptYesNo
promptMsg
(
Just
False
))
?>>
return
(
Just
False
)
return
$
flags
{
noComments
=
maybeToFlag
(
fmap
not
genComments
)
}
...
...
@@ -275,7 +270,7 @@ getGenComments flags = do
getSrcDir
::
InitFlags
->
IO
InitFlags
getSrcDir
flags
=
do
srcDirs
<-
return
(
sourceDirs
flags
)
?>>
Just
`
fmap
`
(
guessSourceDirs
flags
)
?>>
Just
`
fmap
`
guessSourceDirs
flags
return
$
flags
{
sourceDirs
=
srcDirs
}
...
...
@@ -283,8 +278,8 @@ getSrcDir flags = do
-- moment just looks to see whether there is a directory called 'src'.
guessSourceDirs
::
InitFlags
->
IO
[
String
]
guessSourceDirs
flags
=
do
dir
<-
fromMaybe
getCurrentDirectory
(
fmap
return
.
flagToMaybe
$
packageDir
flags
)
dir
<-
maybe
getCurrentDirectory
return
.
flagToMaybe
$
packageDir
flags
srcIsDir
<-
doesDirectoryExist
(
dir
</>
"src"
)
if
srcIsDir
then
return
[
"src"
]
...
...
@@ -293,8 +288,7 @@ guessSourceDirs flags = do
-- | Get the list of exposed modules and extra tools needed to build them.
getModulesBuildToolsAndDeps
::
PackageIndex
->
InitFlags
->
IO
InitFlags
getModulesBuildToolsAndDeps
pkgIx
flags
=
do
dir
<-
fromMaybe
getCurrentDirectory
(
fmap
return
.
flagToMaybe
$
packageDir
flags
)
dir
<-
maybe
getCurrentDirectory
return
.
flagToMaybe
$
packageDir
flags
-- XXX really should use guessed source roots.
sourceFiles
<-
scanForModules
dir
...
...
@@ -359,7 +353,7 @@ chooseDep flags (m, Just ps)
grps
->
do
message
flags
(
"
\n
Warning: multiple packages found providing "
++
display
m
++
": "
++
intercalate
", "
(
map
(
display
.
P
.
pkgName
.
head
)
grps
))
message
flags
(
"You will need to pick one and manually add it to the Build-depends: field."
)
message
flags
"You will need to pick one and manually add it to the Build-depends: field."
return
Nothing
where
pkgGroups
=
groupBy
((
==
)
`
on
`
P
.
pkgName
)
(
map
sourcePackageId
ps
)
...
...
@@ -447,7 +441,7 @@ promptListOptional pr choices =
$
promptList
pr
(
Nothing
:
map
Just
choices
)
(
Just
Nothing
)
(
maybe
"(none)"
display
)
True
where
rearrange
=
either
(
Just
.
Left
)
(
ma
ybe
Nothing
(
Just
.
Right
)
)
rearrange
=
either
(
Just
.
Left
)
(
f
ma
p
Right
)
-- | Create a prompt from a list of items.
promptList
::
Eq
t
...
...
@@ -461,8 +455,7 @@ promptList pr choices def displayItem other = do
putStrLn
$
pr
++
":"
let
options1
=
map
(
\
c
->
(
Just
c
==
def
,
displayItem
c
))
choices
options2
=
zip
([
1
..
]
::
[
Int
])
(
options1
++
if
other
then
[(
False
,
"Other (specify)"
)]
else
[]
)
(
options1
++
[(
False
,
"Other (specify)"
)
|
other
])
mapM_
(
putStrLn
.
\
(
n
,(
i
,
s
))
->
showOption
n
i
++
s
)
options2
promptList'
displayItem
(
length
options2
)
choices
def
other
where
showOption
n
i
|
n
<
10
=
" "
++
star
i
++
" "
++
rest
...
...
@@ -598,7 +591,7 @@ findNewName oldName = findNewName' 0
generateCabalFile
::
String
->
InitFlags
->
String
generateCabalFile
fileName
c
=
renderStyle
style
{
lineLength
=
79
,
ribbonsPerLine
=
1.1
}
$
(
if
(
minimal
c
/=
Flag
True
)
(
if
minimal
c
/=
Flag
True
then
showComment
(
Just
$
"Initial "
++
fileName
++
" generated by cabal "
++
"init. For further documentation, see "
++
"http://haskell.org/cabal/users-guide/"
)
...
...
@@ -670,12 +663,12 @@ generateCabalFile fileName c =
,
case
packageType
c
of
Flag
Executable
->
text
"
\n
executable"
<+>
text
(
fromMaybe
""
.
flagToMaybe
$
packageName
c
)
$$
(
nest
2
$
vcat
text
"
\n
executable"
<+>
text
(
fromMaybe
""
.
flagToMaybe
$
packageName
c
)
$$
nest
2
(
vcat
[
fieldS
"main-is"
NoFlag
(
Just
".hs or .lhs file containing the Main module."
)
True
,
generateBuildInfo
Executable
c
])
Flag
Library
->
text
"
\n
library"
$$
(
nest
2
$
vcat
Flag
Library
->
text
"
\n
library"
$$
nest
2
(
vcat
[
fieldS
"exposed-modules"
(
listField
(
exposedModules
c
))
(
Just
"Modules exported by the library."
)
True
...
...
@@ -733,15 +726,15 @@ generateCabalFile fileName c =
(
False
,
_
,
_
)
->
(
$$
text
""
)
$
comment
f
<>
text
s
<>
colon
<>
text
(
tak
e
(
20
-
length
s
)
(
repeat
' '
)
)
<>
text
(
replicat
e
(
20
-
length
s
)
' '
)
<>
text
(
fromMaybe
""
.
flagToMaybe
$
f
)
comment
NoFlag
=
text
"-- "
comment
(
Flag
""
)
=
text
"-- "
comment
_
=
text
""
showComment
::
Maybe
String
->
Doc
showComment
(
Just
t
)
=
vcat
.
map
text
.
map
(
"-- "
++
)
.
lines
showComment
(
Just
t
)
=
vcat
.
map
(
text
.
(
"-- "
++
)
)
.
lines
.
renderStyle
style
{
lineLength
=
76
,
ribbonsPerLine
=
1.05
...
...
@@ -774,6 +767,6 @@ message _ s = putStrLn s
#
if
MIN_VERSION_base
(
3
,
0
,
0
)
#
else
(
>=>
)
::
Monad
m
=>
(
a
->
m
b
)
->
(
b
->
m
c
)
->
(
a
->
m
c
)
(
>=>
)
::
Monad
m
=>
(
a
->
m
b
)
->
(
b
->
m
c
)
->
a
->
m
c
f
>=>
g
=
\
x
->
f
x
>>=
g
#
endif
cabal-install/Distribution/Client/Init/Heuristics.hs
View file @
74ffcfd1
...
...
@@ -37,7 +37,7 @@ import Data.Char ( isUpper, isLower, isSpace )
import
Data.Either
(
partitionEithers
)
#
endif
import
Data.List
(
isPrefixOf
)
import
Data.Maybe
(
catMaybes
)
import
Data.Maybe
(
mapMaybe
,
catMaybes
,
maybeToList
)
import
Data.Monoid
(
mempty
,
mappend
)
import
qualified
Data.Set
as
Set
(
fromList
,
toList
)
import
System.Directory
(
getDirectoryContents
,
doesDirectoryExist
,
doesFileExist
,
...
...
@@ -104,13 +104,13 @@ findImports :: FilePath -> SourceFileEntry -> IO SourceFileEntry
findImports
projectRoot
sf
=
do
s
<-
readFile
(
sfToFileName
projectRoot
sf
)
let
modules
=
cat
Maybe
s
.
map
(
getModName
.
drop
1
.
filter
(
not
.
null
)
.
dropWhile
(
/=
"import"
)
.
words
)
let
modules
=
map
Maybe
(
getModName
.
drop
1
.
filter
(
not
.
null
)
.
dropWhile
(
/=
"import"
)
.
words
)
.
filter
(
not
.
(
"--"
`
isPrefixOf
`))
-- poor man's comment filtering
.
lines
$
s
...
...
@@ -148,7 +148,7 @@ neededBuildPrograms :: [SourceFileEntry] -> [String]
neededBuildPrograms
entries
=
[
handler
|
ext
<-
nubSet
(
map
fileExtension
entries
)
,
handler
<-
maybe
[]
(
:
[]
)
(
lookup
ext
knownSuffixHandlers
)
,
handler
<-
maybe
ToList
(
lookup
ext
knownSuffixHandlers
)
]
-- |Guess author and email
...
...
@@ -173,7 +173,7 @@ guessAuthorNameMail =
-- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached
knownCategories
::
SourcePackageDb
->
[
String
]
knownCategories
(
SourcePackageDb
sourcePkgIndex
_
)
=
nubSet
$
knownCategories
(
SourcePackageDb
sourcePkgIndex
_
)
=
nubSet
[
cat
|
pkg
<-
map
head
(
allPackagesByName
sourcePkgIndex
)
,
let
catList
=
(
PD
.
category
.
PD
.
packageDescription
.
packageDescription
)
pkg
,
cat
<-
splitString
','
catList
...
...
cabal-install/Distribution/Client/InstallSymlink.hs
View file @
74ffcfd1
...
...
@@ -234,6 +234,6 @@ makeRelative a b = assert (isAbsolute a && isAbsolute b) $
bs
=
splitPath
b
commonLen
=
length
$
takeWhile
id
$
zipWith
(
==
)
as
bs
in
joinPath
$
[
".."
|
_
<-
drop
commonLen
as
]
++
[
b'
|
b'
<-
drop
commonLen
bs
]
++
drop
commonLen
bs
#
endif
cabal-install/Distribution/Client/PackageIndex.hs
View file @
74ffcfd1
...
...
@@ -63,7 +63,7 @@ import qualified Data.Array as Array
import
Data.Array
((
!
))
import
Data.List
(
groupBy
,
sortBy
,
nub
,
isInfixOf
)
import
Data.Monoid
(
Monoid
(
..
))
import
Data.Maybe
(
isJust
,
isNothing
,
fromMaybe
)
import
Data.Maybe
(
isJust
,
isNothing
,
fromMaybe
,
catMaybes
)
import
Distribution.Package
(
PackageName
(
..
),
PackageIdentifier
(
..
)
...
...
@@ -90,7 +90,7 @@ newtype PackageIndex pkg = PackageIndex
deriving
(
Show
,
Read
)
instance
Package
pkg
=>
Monoid
(
PackageIndex
pkg
)
where
mempty
=
PackageIndex
(
Map
.
empty
)
mempty
=
PackageIndex
Map
.
empty
mappend
=
merge
--save one mappend with empty in the common case:
mconcat
[]
=
mempty
...
...
@@ -466,9 +466,8 @@ dependencyGraph :: PackageFixedDeps pkg
PackageIdentifier
->
Maybe
Graph
.
Vertex
)
dependencyGraph
index
=
(
graph
,
vertexToPkg
,
pkgIdToVertex
)
where
graph
=
Array
.
listArray
bounds
[
[
v
|
Just
v
<-
map
pkgIdToVertex
(
depends
pkg
)
]
|
pkg
<-
pkgs
]
graph
=
Array
.
listArray
bounds
$
map
(
catMaybes
.
map
pkgIdToVertex
.
depends
)
pkgs
vertexToPkg
vertex
=
pkgTable
!
vertex
pkgIdToVertex
=
binarySearch
0
topBound
...
...
cabal-install/Distribution/Client/ParseUtils.hs
View file @
74ffcfd1
...
...
@@ -23,7 +23,7 @@ import qualified Text.PrettyPrint as Disp
--FIXME: replace this with something better
parseFields
::
[
FieldDescr
a
]
->
a
->
[
ParseUtils
.
Field
]
->
ParseResult
a
parseFields
fields
initial
=
foldM
setField
initial
parseFields
fields
=
foldM
setField
where
fieldMap
=
Map
.
fromList
[
(
name
,
f
)
|
f
@
(
FieldDescr
name
_
_
)
<-
fields
]
...
...
cabal-install/Distribution/Client/Setup.hs
View file @
74ffcfd1
...
...
@@ -56,12 +56,9 @@ import Distribution.Simple.Program
(
defaultProgramConfiguration
)
import
Distribution.Simple.Command
hiding
(
boolOpt
)
import
qualified
Distribution.Simple.Setup
as
Cabal
(
configureCommand
,
buildCommand
,
sdistCommand
,
haddockCommand
,
buildOptions
,
defaultBuildFlags
)
import
Distribution.Simple.Setup
(
ConfigFlags
(
..
),
BuildFlags
(
..
),
SDistFlags
(
..
),
HaddockFlags
(
..
)
)
import
Distribution.Simple.Setup
(
Flag
(
..
),
toFlag
,
fromFlag
,
flagToMaybe
,
flagToList
(
ConfigFlags
(
..
),
BuildFlags
(
..
),
SDistFlags
(
..
),
HaddockFlags
(
..
)
,
Flag
(
..
),
toFlag
,
fromFlag
,
flagToMaybe
,
flagToList
,
optionVerbosity
,
boolOpt
,
trueArg
,
falseArg
)
import
Distribution.Simple.InstallDirs
(
PathTemplate
,
toPathTemplate
,
fromPathTemplate
)
...
...
@@ -826,11 +823,10 @@ installOptions showOrParseArgs =
(
map
(
fmap
show
)
.
flagToList
))
]
++
case
showOrParseArgs
of
-- TODO: remove when "cabal install" avoids
ParseArgs
->
option
[]
[
"only"
]
[
option
[]
[
"only"
]
"Only installs the package in the current directory."
installOnly
(
\
v
flags
->
flags
{
installOnly
=
v
})
trueArg
:
[]
trueArg
]
_
->
[]
instance
Monoid
InstallFlags
where
...
...
@@ -1422,7 +1418,7 @@ liftOptions :: (b -> a) -> (a -> b -> b)
->
[
OptionField
a
]
->
[
OptionField
b
]
liftOptions
get
set
=
map
(
liftOption
get
set
)
yesNoOpt
::
ShowOrParseArgs
->
MkOptDescr
(
b
->
Flag
Bool
)
(
Flag
Bool
->
(
b
->
b
)
)
b
yesNoOpt
::
ShowOrParseArgs
->
MkOptDescr
(
b
->
Flag
Bool
)
(
Flag
Bool
->
b
->
b
)
b
yesNoOpt
ShowArgs
sf
lf
=
trueArg
sf
lf
yesNoOpt
_
sf
lf
=
boolOpt'
flagToMaybe
Flag
(
sf
,
lf
)
(
[]
,
map
(
"no-"
++
)
lf
)
sf
lf
...
...
cabal-install/Distribution/Client/Tar.hs
View file @
74ffcfd1
...
...
@@ -114,7 +114,7 @@ extractTarGzFile :: FilePath -- ^ Destination directory
->
FilePath
-- ^ Expected subdir (to check for tarbombs)
->
FilePath
-- ^ Tarball
->
IO
()
extractTarGzFile
dir
expected
tar
=
do
extractTarGzFile
dir
expected
tar
=
unpack
dir
.
checkTarbomb
expected
.
read
.
GZipUtils
.
maybeDecompress
=<<
BS
.
readFile
tar
--
...
...
@@ -363,7 +363,7 @@ splitLongPath path =
Right
(
name
,
[]
)
->
Right
(
TarPath
name
""
)