Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
G
ghcup-hs
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Iterations
Wiki
Requirements
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Locked files
Build
Pipelines
Jobs
Pipeline schedules
Test cases
Artifacts
Deploy
Releases
Package Registry
Container Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Code review analytics
Issue analytics
Insights
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Haskell
ghcup-hs
Commits
202f3ea3
Verified
Commit
202f3ea3
authored
4 years ago
by
Julian Ospald
Browse files
Options
Downloads
Patches
Plain Diff
Fix bug where setting non-installed GHC unsets current one
parent
4f09e3ff
No related branches found
No related tags found
No related merge requests found
Pipeline
#23378
passed
4 years ago
Stage: test
Changes
1
Pipelines
2
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
lib/GHCup.hs
+35
-37
35 additions, 37 deletions
lib/GHCup.hs
with
35 additions
and
37 deletions
lib/GHCup.hs
+
35
−
37
View file @
202f3ea3
...
@@ -346,6 +346,8 @@ setGHC ver sghc = do
...
@@ -346,6 +346,8 @@ setGHC ver sghc = do
let
verBS
=
verToBS
(
_tvVersion
ver
)
let
verBS
=
verToBS
(
_tvVersion
ver
)
ghcdir
<-
lift
$
ghcupGHCDir
ver
ghcdir
<-
lift
$
ghcupGHCDir
ver
whenM
(
lift
$
fmap
not
$
ghcInstalled
ver
)
(
throwE
(
NotInstalled
GHC
(
ver
^.
tvVersion
%
to
prettyVer
)))
-- symlink destination
-- symlink destination
Settings
{
dirs
=
Dirs
{
..
}
}
<-
lift
ask
Settings
{
dirs
=
Dirs
{
..
}
}
<-
lift
ask
liftIO
$
hideError
AlreadyExists
$
createDirRecursive
newDirPerms
binDir
liftIO
$
hideError
AlreadyExists
$
createDirRecursive
newDirPerms
binDir
...
@@ -617,43 +619,39 @@ rmGHCVer :: ( MonadReader Settings m
...
@@ -617,43 +619,39 @@ rmGHCVer :: ( MonadReader Settings m
->
Excepts
'
[
NotInstalled
]
m
()
->
Excepts
'
[
NotInstalled
]
m
()
rmGHCVer
ver
=
do
rmGHCVer
ver
=
do
isSetGHC
<-
lift
$
fmap
(
maybe
False
(
==
ver
))
$
ghcSet
(
_tvTarget
ver
)
isSetGHC
<-
lift
$
fmap
(
maybe
False
(
==
ver
))
$
ghcSet
(
_tvTarget
ver
)
dir
<-
lift
$
ghcupGHCDir
ver
let
d'
=
toFilePath
dir
whenM
(
lift
$
fmap
not
$
ghcInstalled
ver
)
(
throwE
(
NotInstalled
GHC
(
ver
^.
tvVersion
%
to
prettyVer
)))
exists
<-
liftIO
$
doesDirectoryExist
dir
dir
<-
lift
$
ghcupGHCDir
ver
-- this isn't atomic, order matters
if
exists
when
isSetGHC
$
do
then
do
lift
$
$
(
logInfo
)
[
i
|
Removing ghc symlinks
|]
-- this isn't atomic, order matters
liftE
$
rmPlain
(
_tvTarget
ver
)
when
isSetGHC
$
do
lift
$
$
(
logInfo
)
[
i
|
Removing ghc symlinks
|]
lift
$
$
(
logInfo
)
[
i
|
Removing directory recursively: #{toFilePath dir}
|]
liftE
$
rmPlain
(
_tvTarget
ver
)
liftIO
$
deleteDirRecursive
dir
lift
$
$
(
logInfo
)
[
i
|
Removing directory recursively: #{d'}
|]
lift
$
$
(
logInfo
)
[
i
|
Removing ghc-x.y.z symlinks
|]
liftIO
$
deleteDirRecursive
dir
lift
$
rmMinorSymlinks
ver
lift
$
$
(
logInfo
)
[
i
|
Removing ghc-x.y.z symlinks
|]
lift
$
$
(
logInfo
)
[
i
|
Removing/rewiring ghc-x.y symlinks
|]
lift
$
rmMinorSymlinks
ver
-- first remove
handle
(
\
(
_
::
ParseError
)
->
pure
()
)
$
lift
$
rmMajorSymlinks
ver
lift
$
$
(
logInfo
)
[
i
|
Removing/rewiring ghc-x.y symlinks
|]
-- then fix them (e.g. with an earlier version)
-- first remove
v'
<-
handle
(
\
(
_
::
ParseError
)
->
pure
()
)
$
lift
$
rmMajorSymlinks
ver
handle
-- then fix them (e.g. with an earlier version)
(
\
(
e
::
ParseError
)
->
lift
$
$
(
logWarn
)
[
i
|
#{e}
|]
>>
pure
Nothing
)
v'
<-
$
fmap
Just
handle
$
getMajorMinorV
(
_tvVersion
ver
)
(
\
(
e
::
ParseError
)
->
lift
$
$
(
logWarn
)
[
i
|
#{e}
|]
>>
pure
Nothing
)
forM_
v'
$
\
(
mj
,
mi
)
->
lift
(
getGHCForMajor
mj
mi
(
_tvTarget
ver
))
$
fmap
Just
>>=
mapM_
(
\
v
->
liftE
$
setGHC
v
SetGHC_XY
)
$
getMajorMinorV
(
_tvVersion
ver
)
forM_
v'
$
\
(
mj
,
mi
)
->
lift
(
getGHCForMajor
mj
mi
(
_tvTarget
ver
))
Settings
{
dirs
=
Dirs
{
..
}
}
<-
lift
ask
>>=
mapM_
(
\
v
->
liftE
$
setGHC
v
SetGHC_XY
)
liftIO
Settings
{
dirs
=
Dirs
{
..
}
}
<-
lift
ask
$
hideError
doesNotExistErrorType
$
deleteFile
liftIO
$
(
baseDir
</>
[
rel
|
share
|]
)
$
hideError
doesNotExistErrorType
$
deleteFile
$
(
baseDir
</>
[
rel
|
share
|]
)
else
throwE
(
NotInstalled
GHC
(
ver
^.
tvVersion
%
to
prettyVer
))
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
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!
Save comment
Cancel
Please
register
or
sign in
to comment