Make GHCup isolate installs non-overwriting by default
This commit is contained in:
parent
a0c2a5ccec
commit
8c486e8d46
44
lib/GHCup.hs
44
lib/GHCup.hs
@ -483,6 +483,10 @@ installCabalUnpacked path inst mver' = do
|
|||||||
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
|
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
|
||||||
<> exeExt
|
<> exeExt
|
||||||
let destPath = inst </> destFileName
|
let destPath = inst </> destFileName
|
||||||
|
|
||||||
|
whenM (checkFileAlreadyExists destPath)
|
||||||
|
(throwE $ FileAlreadyExistsError destPath)
|
||||||
|
|
||||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||||
(path </> cabalFile <> exeExt)
|
(path </> cabalFile <> exeExt)
|
||||||
destPath
|
destPath
|
||||||
@ -556,6 +560,7 @@ installHLSBindist :: ( MonadMask m
|
|||||||
#if !defined(TAR)
|
#if !defined(TAR)
|
||||||
, ArchiveResult
|
, ArchiveResult
|
||||||
#endif
|
#endif
|
||||||
|
, FileAlreadyExistsError
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
()
|
()
|
||||||
@ -603,7 +608,7 @@ installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
|
|||||||
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
|
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
|
||||||
-> FilePath -- ^ Path to install to
|
-> FilePath -- ^ Path to install to
|
||||||
-> Maybe Version -- ^ Nothing for isolated install
|
-> Maybe Version -- ^ Nothing for isolated install
|
||||||
-> Excepts '[CopyError] m ()
|
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
|
||||||
installHLSUnpacked path inst mver' = do
|
installHLSUnpacked path inst mver' = do
|
||||||
lift $ $(logInfo) "Installing HLS"
|
lift $ $(logInfo) "Installing HLS"
|
||||||
liftIO $ createDirRecursive' inst
|
liftIO $ createDirRecursive' inst
|
||||||
@ -619,20 +624,34 @@ installHLSUnpacked path inst mver' = do
|
|||||||
let toF = dropSuffix exeExt f
|
let toF = dropSuffix exeExt f
|
||||||
<> maybe "" (("~" <>) . T.unpack . prettyVer) mver'
|
<> maybe "" (("~" <>) . T.unpack . prettyVer) mver'
|
||||||
<> exeExt
|
<> exeExt
|
||||||
|
|
||||||
|
let srcPath = path </> f
|
||||||
|
let destPath = inst </> toF
|
||||||
|
|
||||||
|
whenM (checkFileAlreadyExists destPath)
|
||||||
|
(throwE $ FileAlreadyExistsError destPath)
|
||||||
|
|
||||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||||
(path </> f)
|
srcPath
|
||||||
(inst </> toF)
|
destPath
|
||||||
lift $ chmod_755 (inst </> toF)
|
lift $ chmod_755 destPath
|
||||||
|
|
||||||
-- install haskell-language-server-wrapper
|
-- install haskell-language-server-wrapper
|
||||||
let wrapper = "haskell-language-server-wrapper"
|
let wrapper = "haskell-language-server-wrapper"
|
||||||
toF = wrapper
|
toF = wrapper
|
||||||
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
|
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
|
||||||
<> exeExt
|
<> exeExt
|
||||||
|
srcWrapperPath = path </> wrapper <> exeExt
|
||||||
|
destWrapperPath = inst </> toF
|
||||||
|
|
||||||
|
whenM (checkFileAlreadyExists destWrapperPath)
|
||||||
|
(throwE $ FileAlreadyExistsError destWrapperPath)
|
||||||
|
|
||||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||||
(path </> wrapper <> exeExt)
|
srcWrapperPath
|
||||||
(inst </> toF)
|
destWrapperPath
|
||||||
lift $ chmod_755 (inst </> toF)
|
|
||||||
|
lift $ chmod_755 destWrapperPath
|
||||||
|
|
||||||
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
|
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
|
||||||
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
|
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
|
||||||
@ -663,6 +682,7 @@ installHLSBin :: ( MonadMask m
|
|||||||
#if !defined(TAR)
|
#if !defined(TAR)
|
||||||
, ArchiveResult
|
, ArchiveResult
|
||||||
#endif
|
#endif
|
||||||
|
, FileAlreadyExistsError
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
()
|
()
|
||||||
@ -701,6 +721,7 @@ installStackBin :: ( MonadMask m
|
|||||||
#if !defined(TAR)
|
#if !defined(TAR)
|
||||||
, ArchiveResult
|
, ArchiveResult
|
||||||
#endif
|
#endif
|
||||||
|
, FileAlreadyExistsError
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
()
|
()
|
||||||
@ -738,6 +759,7 @@ installStackBindist :: ( MonadMask m
|
|||||||
#if !defined(TAR)
|
#if !defined(TAR)
|
||||||
, ArchiveResult
|
, ArchiveResult
|
||||||
#endif
|
#endif
|
||||||
|
, FileAlreadyExistsError
|
||||||
]
|
]
|
||||||
m
|
m
|
||||||
()
|
()
|
||||||
@ -783,7 +805,7 @@ installStackUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m)
|
|||||||
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
|
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
|
||||||
-> FilePath -- ^ Path to install to
|
-> FilePath -- ^ Path to install to
|
||||||
-> Maybe Version -- ^ Nothing for isolated installs
|
-> Maybe Version -- ^ Nothing for isolated installs
|
||||||
-> Excepts '[CopyError] m ()
|
-> Excepts '[CopyError, FileAlreadyExistsError] m ()
|
||||||
installStackUnpacked path inst mver' = do
|
installStackUnpacked path inst mver' = do
|
||||||
lift $ $(logInfo) "Installing stack"
|
lift $ $(logInfo) "Installing stack"
|
||||||
let stackFile = "stack"
|
let stackFile = "stack"
|
||||||
@ -791,7 +813,11 @@ installStackUnpacked path inst mver' = do
|
|||||||
let destFileName = stackFile
|
let destFileName = stackFile
|
||||||
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
|
<> maybe "" (("-" <>) . T.unpack . prettyVer) mver'
|
||||||
<> exeExt
|
<> exeExt
|
||||||
let destPath = inst </> destFileName
|
destPath = inst </> destFileName
|
||||||
|
|
||||||
|
whenM (checkFileAlreadyExists destPath)
|
||||||
|
(throwE $ FileAlreadyExistsError destPath)
|
||||||
|
|
||||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||||
(path </> stackFile <> exeExt)
|
(path </> stackFile <> exeExt)
|
||||||
destPath
|
destPath
|
||||||
|
@ -104,3 +104,6 @@ findFiles path regex = do
|
|||||||
contents <- listDirectory path
|
contents <- listDirectory path
|
||||||
pure $ filter (match regex) contents
|
pure $ filter (match regex) contents
|
||||||
|
|
||||||
|
|
||||||
|
checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool
|
||||||
|
checkFileAlreadyExists fp = liftIO $ doesFileExist fp
|
||||||
|
Loading…
Reference in New Issue
Block a user