hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'windows-hotfix'

Browse Source
This commit is contained in:
Julian Ospald 2022-05-12 18:33:19 +02:00
commit 25f9ac71ca
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
1 changed files with 6 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
lib/GHCup.hs
View File

@ -324,13 +324,16 @@ installUnpackedGHC :: ( MonadReader env m
-> InstallDirResolved -- ^ Path to install to -> InstallDirResolved -- ^ Path to install to
-> Version -- ^ The GHC version -> Version -- ^ The GHC version
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
installUnpackedGHC path (fromInstallDir -> inst) ver installUnpackedGHC path inst ver
| isWindows = do | isWindows = do
lift $ logInfo "Installing GHC (this may take a while)" lift $ logInfo "Installing GHC (this may take a while)"
-- Windows bindists are relocatable and don't need -- Windows bindists are relocatable and don't need
-- to run configure. -- to run configure.
-- We also must make sure to preserve mtime to not confuse ghc-pkg. -- We also must make sure to preserve mtime to not confuse ghc-pkg.
lift $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do lift $ withRunInIO $ \run -> flip onException (case inst of
IsolateDirResolved _ -> pure ()
GHCupDir d -> run $ recyclePathForcibly d
) $ copyDirectoryRecursive path (fromInstallDir inst) $ \source dest -> do
mtime <- getModificationTime source mtime <- getModificationTime source
moveFilePortable source dest moveFilePortable source dest
setModificationTime dest mtime setModificationTime dest mtime
@ -345,7 +348,7 @@ installUnpackedGHC path (fromInstallDir -> inst) ver
lift $ logInfo "Installing GHC (this may take a while)" lift $ logInfo "Installing GHC (this may take a while)"
lEM $ execLogged "sh" lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst) ("./configure" : ("--prefix=" <> fromInstallDir inst)
: alpineArgs : alpineArgs
) )
(Just path) (Just path)