Skip to content
GitLab
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
b5fe957a
Commit
b5fe957a
authored
Nov 24, 2015
by
martinvlk
Browse files
Addressing review comments.
parent
9832269a
Changes
8
Hide whitespace changes
Inline
Side-by-side
cabal-install/Distribution/Client/Sandbox.hs
View file @
b5fe957a
...
...
@@ -74,7 +74,8 @@ import Distribution.Client.SetupWrapper
import
Distribution.Client.Types
(
PackageLocation
(
..
)
,
SourcePackage
(
..
)
)
import
Distribution.Client.Utils
(
inDir
,
tryCanonicalizePath
,
tryFindAddSourcePackageDesc
)
,
tryFindAddSourcePackageDesc
,
canonicalizePathNoThrow
)
import
Distribution.PackageDescription.Configuration
(
flattenPackageDescription
)
import
Distribution.PackageDescription.Parse
(
readPackageDescription
)
...
...
@@ -113,8 +114,8 @@ import Control.Monad ( forM, liftM2, unless, when )
import
Data.Bits
(
shiftL
,
shiftR
,
xor
)
import
Data.Char
(
ord
)
import
Data.IORef
(
newIORef
,
writeIORef
,
readIORef
)
import
Data.List
(
delete
,
foldl'
,
i
sSuffixOf
,
intersperse
)
import
Data.Maybe
(
fromJust
)
import
Data.List
(
delete
,
foldl'
,
i
ntersperse
,
find
,
(
\\
)
)
import
Data.Maybe
(
fromJust
,
fromMaybe
)
#
if
!
MIN_VERSION_base
(
4
,
8
,
0
)
import
Data.Monoid
(
mempty
,
mappend
)
#
endif
...
...
@@ -452,20 +453,31 @@ sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
(
sandboxDir
,
pkgEnv
)
<-
tryLoadSandboxConfig
verbosity
globalFlags
indexFile
<-
tryGetIndexFilePath
(
pkgEnvSavedConfig
pkgEnv
)
withRemoveTimestamps
sandboxDir
$
do
removedRefs
<-
Index
.
removeBuildTreeRefs
verbosity
indexFile
buildTreeRefs
when
(
length
buildTreeRefs
>
length
removedRefs
)
$
die
$
"Skipping nonregistered sources: "
++
(
showL
$
prune
buildTreeRefs
removedRefs
)
notice
verbosity
$
"Success deleting sources: "
++
showL
buildTreeRefs
++
"
\n\n
"
return
removedRefs
removedPaths
<-
Index
.
removeBuildTreeRefs
verbosity
indexFile
buildTreeRefs
withRemoveTimestamps
sandboxDir
$
return
removedPaths
-- FIXME: we canonicalize paths here as well as in Index.removeBuildTreeRefs,
-- but we need the info here and there is no good way to share without larger
-- refactoring
convDict
<-
mapM
(
\
btr
->
do
pth
<-
canonicalizePathNoThrow
btr
return
(
btr
,
pth
))
buildTreeRefs
let
removedRefs
=
fmap
(
convertWith
convDict
)
removedPaths
when
(
not
.
null
$
removedPaths
)
$
notice
verbosity
$
"Success deleting sources: "
++
showL
removedRefs
++
"
\n\n
"
when
(
length
buildTreeRefs
>
length
removedPaths
)
$
die
$
"Skipped the following nonregistered sources: "
++
(
showL
$
buildTreeRefs
\\
removedRefs
)
notice
verbosity
$
"Note: 'sandbox delete-source' only unregisters the "
++
"source dependency, but does not remove the package "
++
"from the sandbox package DB.
\n\n
"
++
"Use 'sandbox hc-pkg -- unregister' to do that."
where
prune
inp
out
=
filter
(
\
btr
->
not
.
or
$
map
(
btr
`
isSuffixOf
`)
out
)
inp
showL
=
concat
.
intersperse
" "
.
fmap
show
convertWith
dict
pth
=
fromMaybe
pth
$
f
map
fst
$
find
((
==
pth
)
.
snd
)
dict
showL
=
concat
.
intersperse
" "
.
fmap
show
-- | Entry point for the 'cabal sandbox list-sources' command.
sandboxListSources
::
Verbosity
->
SandboxFlags
->
GlobalFlags
...
...
cabal-install/Distribution/Client/Sandbox/Index.hs
View file @
b5fe957a
...
...
@@ -162,21 +162,27 @@ removeBuildTreeRefs _ _ [] =
error
"Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected"
removeBuildTreeRefs
verbosity
indexPath
l'
=
do
checkIndexExists
indexPath
l
<-
mapM
canonicalizePathNoThrow
l'
let
tmpFile
=
indexPath
<.>
"tmp"
l
<-
mapM
canonicalizePathNoThrow
l'
-- Performance note: on my system, it takes 'index --remove-source'
-- approx. 3,5s to filter a 65M file. Real-life indices are expected to be
-- much smaller.
removedRefs
<-
doRemove
l
tmpFile
renameFile
tmpFile
indexPath
debug
verbosity
$
"Successfully renamed '"
++
tmpFile
++
"' to '"
++
indexPath
++
"'"
updatePackageIndexCacheFile
verbosity
indexPath
(
indexPath
`
replaceExtension
`
"cache"
)
return
removedRefs
where
doRemove
srcRefs
tmpFile
=
do
(
newIdx
,
changedPaths
)
<-
Tar
.
read
`
fmap
`
BS
.
readFile
indexPath
>>=
runWriterT
.
Tar
.
filterEntries
W
(
p
srcRefs
)
>>=
runWriterT
.
Tar
.
filterEntries
M
(
p
srcRefs
)
BS
.
writeFile
tmpFile
$
Tar
.
writeEntries
newIdx
return
changedPaths
p
::
[
FilePath
]
->
Tar
.
Entry
->
WriterT
[
FilePath
]
IO
Bool
...
...
cabal-install/Distribution/Client/Tar.hs
View file @
b5fe957a
...
...
@@ -59,12 +59,12 @@ module Distribution.Client.Tar (
-- ** Sequences of tar entries
Entries
(
..
),
foldrEntries
,
foldrEntries
W
,
foldrEntries
M
,
foldlEntries
,
unfoldrEntries
,
mapEntries
,
filterEntries
,
filterEntries
W
,
filterEntries
M
,
entriesIndex
,
)
where
...
...
@@ -441,7 +441,7 @@ unfoldrEntries f = unfold
Right
(
Just
(
e
,
x'
))
->
Next
e
(
unfold
x'
)
foldrEntries
::
(
Entry
->
a
->
a
)
->
a
->
(
String
->
a
)
->
Entries
->
a
foldrEntries
next
done
fail'
=
isoR
.
foldrEntries
W
(
isoL
.:
next
)
(
isoL
done
)
(
isoL
.
fail'
)
foldrEntries
next
done
fail'
=
isoR
.
foldrEntries
M
(
isoL
.:
next
)
(
isoL
done
)
(
isoL
.
fail'
)
where
isoL
::
a
->
WriterT
()
Identity
a
isoL
=
return
...
...
@@ -461,12 +461,11 @@ mapEntries :: (Entry -> Entry) -> Entries -> Entries
mapEntries
f
=
foldrEntries
(
Next
.
f
)
Done
Fail
filterEntries
::
(
Entry
->
Bool
)
->
Entries
->
Entries
filterEntries
p
=
isoR
.
filterEntries
W
(
return
.
p
)
filterEntries
p
=
isoR
.
filterEntries
M
(
return
.
p
)
filterEntriesW
::
(
Monoid
w
,
Monad
m
)
=>
(
Entry
->
WriterT
w
m
Bool
)
->
Entries
->
WriterT
w
m
Entries
filterEntriesW
p
=
foldrEntriesW
filterEntriesM
::
(
Monad
m
)
=>
(
Entry
->
m
Bool
)
->
Entries
->
m
Entries
filterEntriesM
p
=
foldrEntriesM
(
\
entry
rest
->
do
include
<-
p
entry
if
include
...
...
@@ -474,10 +473,8 @@ filterEntriesW p =
else
return
rest
)
(
return
Done
)
(
return
.
Fail
)
foldrEntriesW
::
(
Monoid
w
,
Monad
m
)
=>
(
Entry
->
a
->
WriterT
w
m
a
)
->
WriterT
w
m
a
->
(
String
->
WriterT
w
m
a
)
->
Entries
->
WriterT
w
m
a
foldrEntriesW
next
done
fail'
=
fold
foldrEntriesM
::
(
Monad
m
)
=>
(
Entry
->
a
->
m
a
)
->
m
a
->
(
String
->
m
a
)
->
Entries
->
m
a
foldrEntriesM
next
done
fail'
=
fold
where
fold
(
Next
e
es
)
=
fold
es
>>=
next
e
fold
Done
=
done
...
...
cabal-install/tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.err
View file @
b5fe957a
cabal: Skipping nonregistered sources: "q"
cabal: Skipp
ed the follow
ing nonregistered sources: "q"
cabal-install/tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.out
View file @
b5fe957a
Success deleting sources: "
p
" "
q
"
Success deleting sources: "
q
" "
p
"
Note: 'sandbox delete-source' only unregisters the source dependency, but does
not remove the package from the sandbox package DB.
...
...
cabal-install/tests/IntegrationTests/sandbox-sources/should_run/tolerate_nonexistent_source.out
0 → 100644
View file @
b5fe957a
Success deleting sources: "p"
Note: 'sandbox delete-source' only unregisters the source dependency, but does
not remove the package from the sandbox package DB.
Use 'sandbox hc-pkg -- unregister' to do that.
cabal-install/tests/IntegrationTests/sandbox-sources/should_run/tolerate_nonexistent_source.sh
0 → 100644
View file @
b5fe957a
.
../common.sh
# Create the sandbox
cabal sandbox init
>
/dev/null
# Add the sources
cabal sandbox add-source p
>
/dev/null
cabal sandbox add-source q
>
/dev/null
# delete the directory on disk
# FIXME: the following line needs to be uncommented, but this depends on fixing a regression to #1360 first
#rm -R p
# Remove the registered source which is no longer on disk
cabal sandbox delete-source p
cabal-install/tests/UnitTests/Distribution/Client/Tar.hs
View file @
b5fe957a
...
...
@@ -4,8 +4,8 @@ module UnitTests.Distribution.Client.Tar (
import
Distribution.Client.Tar
(
foldrEntries
,
filterEntries
,
foldrEntries
W
,
filterEntries
W
,
foldrEntries
M
,
filterEntries
M
,
EntryContent
(
..
)
,
simpleEntry
,
Entry
(
..
)
...
...
@@ -23,8 +23,8 @@ import Control.Monad.Writer.Lazy (runWriterT, tell)
tests
::
[
TestTree
]
tests
=
[
testCase
"foldrEntries"
foldrTest
,
testCase
"filterEntries"
filterTest
,
testCase
"foldrEntries
W
"
foldr
W
Test
,
testCase
"filterEntries
W
"
filter
W
Test
,
testCase
"foldrEntries
M
"
foldr
M
Test
,
testCase
"filterEntries
M
"
filter
M
Test
]
foldrTest
::
Assertion
...
...
@@ -57,14 +57,14 @@ filterTest = do
assertEqual
"Unexpected result for filter"
"xf"
$
entriesToString
$
filterEntries
p
$
Next
e1
$
Next
e2
$
Fail
"f"
foldr
W
Test
::
Assertion
foldr
W
Test
=
do
(
r
,
w
)
<-
runWriterT
$
foldrEntries
W
undefined
foldr
M
Test
::
Assertion
foldr
M
Test
=
do
(
r
,
w
)
<-
runWriterT
$
foldrEntries
M
undefined
(
tell
[
1
::
Int
]
>>
tell
[
2
::
Int
]
>>
return
"x"
)
undefined
Done
assertEqual
"Unexpected result for Done"
"x"
r
assertEqual
"Unexpected result for Done w"
[
1
,
2
]
w
(
r1
,
w1
)
<-
runWriterT
$
foldrEntries
W
undefined
undefined
(
r1
,
w1
)
<-
runWriterT
$
foldrEntries
M
undefined
undefined
(
return
.
id
)
$
Fail
"x"
assertEqual
"Unexpected result for Fail"
"x"
r1
assertEqual
"Unexpected result for Fail w"
""
w1
...
...
@@ -75,36 +75,36 @@ foldrWTest = do
str
=
BS
.
Char8
.
unpack
dta
in
tell
"a"
>>
return
(
str
++
acc
))
done
=
tell
"b"
>>
return
"z"
(
r2
,
w2
)
<-
runWriterT
$
foldrEntries
W
next
done
undefined
$
(
r2
,
w2
)
<-
runWriterT
$
foldrEntries
M
next
done
undefined
$
Next
e1
$
Next
e2
Done
assertEqual
"Unexpected result for Next"
"xyz"
r2
assertEqual
"Unexpected result for Next w"
"baa"
w2
let
fail'
=
(
\
f
->
tell
"c"
>>
return
f
)
.
id
(
r3
,
w3
)
<-
runWriterT
$
foldrEntries
W
next
done
fail'
$
(
r3
,
w3
)
<-
runWriterT
$
foldrEntries
M
next
done
fail'
$
Next
e1
$
Next
e2
$
Fail
"f"
assertEqual
"Unexpected result for Next"
"xyf"
r3
assertEqual
"Unexpected result for Next w"
"caa"
w3
filter
W
Test
::
Assertion
filter
W
Test
=
do
filter
M
Test
::
Assertion
filter
M
Test
=
do
let
e1
=
getFileEntry
"file1"
"x"
e2
=
getFileEntry
"file2"
"y"
p
=
(
\
e
->
let
(
NormalFile
dta
_
)
=
entryContent
e
str
=
BS
.
Char8
.
unpack
dta
in
tell
"t"
>>
return
(
not
.
(
==
"y"
)
$
str
))
(
r
,
w
)
<-
runWriterT
$
filterEntries
W
p
$
Next
e1
$
Next
e2
Done
assertEqual
"Unexpected result for filter
W
"
"xz"
$
entriesToString
r
assertEqual
"Unexpected result for filter
W
w"
"tt"
w
(
r
,
w
)
<-
runWriterT
$
filterEntries
M
p
$
Next
e1
$
Next
e2
Done
assertEqual
"Unexpected result for filter
M
"
"xz"
$
entriesToString
r
assertEqual
"Unexpected result for filter
M
w"
"tt"
w
(
r1
,
w1
)
<-
runWriterT
$
filterEntries
W
p
$
Done
assertEqual
"Unexpected result for filter
W
"
"z"
$
entriesToString
r1
assertEqual
"Unexpected result for filter
W
w"
""
w1
(
r1
,
w1
)
<-
runWriterT
$
filterEntries
M
p
$
Done
assertEqual
"Unexpected result for filter
M
"
"z"
$
entriesToString
r1
assertEqual
"Unexpected result for filter
M
w"
""
w1
(
r2
,
w2
)
<-
runWriterT
$
filterEntries
W
p
$
Next
e1
$
Next
e2
$
Fail
"f"
assertEqual
"Unexpected result for filter
W
"
"xf"
$
entriesToString
r2
assertEqual
"Unexpected result for filter
W
w"
"tt"
w2
(
r2
,
w2
)
<-
runWriterT
$
filterEntries
M
p
$
Next
e1
$
Next
e2
$
Fail
"f"
assertEqual
"Unexpected result for filter
M
"
"xf"
$
entriesToString
r2
assertEqual
"Unexpected result for filter
M
w"
"tt"
w2
getFileEntry
::
FilePath
->
[
Char
]
->
Entry
getFileEntry
pth
dta
=
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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