diff --git a/.gitlab/before_script/freebsd/install_deps.sh b/.gitlab/before_script/freebsd/install_deps.sh
index c35fe9df2da279fd5c460058820fd4febc18ef93..b8bd04f8a67ea875efd6b448064ad4c435e52fea 100755
--- a/.gitlab/before_script/freebsd/install_deps.sh
+++ b/.gitlab/before_script/freebsd/install_deps.sh
@@ -8,7 +8,15 @@ set -eux
mkdir -p "${TMPDIR}"
-curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > ./ghcup-bin
+if freebsd-version | grep -E '^12.*' ; then
+ freebsd_ver=12
+elif freebsd-version | grep -E '^13.*' ; then
+ freebsd_ver=13
+else
+ (>&2 echo "Unsupported FreeBSD version! Please report a bug at https://gitlab.haskell.org/haskell/ghcup-hs/-/issues")
+ exit 1
+fi
+curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-freebsd${freebsd_ver}-ghcup > ./ghcup-bin
chmod +x ghcup-bin
./ghcup-bin -v upgrade -i -f
diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs
index c6e870c4da145bb2f5e453b46f5a2756eac127dd..8e07456cf7137e9ce87b2f9863c3aca80c933878 100644
--- a/app/ghcup/BrickMain.hs
+++ b/app/ghcup/BrickMain.hs
@@ -495,7 +495,7 @@ set' _ (_, ListResult {..}) = do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
- HLS -> liftE $ setHLS lVer $> ()
+ HLS -> liftE $ setHLS lVer SetHLSOnly $> ()
Stack -> liftE $ setStack lVer $> ()
GHCup -> pure ()
)
diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs
index fda68109e07faf691190c070fd8ec9a3df189a66..a79ef47d747dd7ca6277278168ce0b61be8faa5c 100644
--- a/app/ghcup/GHCup/OptParse/Compile.hs
+++ b/app/ghcup/GHCup/OptParse/Compile.hs
@@ -466,7 +466,7 @@ compile compileCommand settings Dirs{..} runAppState runLogger = do
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer HLS dls
when setCompile $ void $ liftE $
- setHLS targetVer
+ setHLS targetVer SetHLSOnly
pure (vi, targetVer)
)
>>= \case
diff --git a/app/ghcup/GHCup/OptParse/GC.hs b/app/ghcup/GHCup/OptParse/GC.hs
index b3488d191f41786571deb614db6b71c2e48abcaa..f8a131006c9227f12e7916513ead78b931bc4c3d 100644
--- a/app/ghcup/GHCup/OptParse/GC.hs
+++ b/app/ghcup/GHCup/OptParse/GC.hs
@@ -132,7 +132,7 @@ gc GCOptions{..} runAppState runLogger = runGC runAppState (do
when gcOldGHC rmOldGHC
lift $ when gcProfilingLibs rmProfilingLibs
lift $ when gcShareDir rmShareDir
- lift $ when gcHLSNoGHC rmHLSNoGHC
+ liftE $ when gcHLSNoGHC rmHLSNoGHC
lift $ when gcCache rmCache
lift $ when gcTmp rmTmp
) >>= \case
diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs
index 1eec1bf241550cdaad5a987cc2883061e6b33b6f..1204e5f26713dc4d5451b505a6cdd2a72ad0136a 100644
--- a/app/ghcup/GHCup/OptParse/Install.hs
+++ b/app/ghcup/GHCup/OptParse/Install.hs
@@ -469,8 +469,9 @@ install installCommand settings getAppState' runLogger = case installCommand of
Just uri -> do
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
(v, vi) <- liftE $ fromVersion instVer HLS
+ -- TODO: support legacy
liftE $ installHLSBindist
- (DownloadInfo uri Nothing "")
+ (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "")
(_tvVersion v)
isolateDir
forceInstall
diff --git a/app/ghcup/GHCup/OptParse/Set.hs b/app/ghcup/GHCup/OptParse/Set.hs
index b03d53ab453f51a55f687a30a0cb524e2692f625..a1f7b9403e9c8e1f126c15f5489462eae1b39492 100644
--- a/app/ghcup/GHCup/OptParse/Set.hs
+++ b/app/ghcup/GHCup/OptParse/Set.hs
@@ -311,10 +311,10 @@ set setCommand runAppState runLeanAppState runLogger = case setCommand of
-> m ExitCode
setHLS' SetOptions{ sToolVer } =
case sToolVer of
- (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) >> pure v)
+ (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly >> pure v)
_ -> runSetHLS runAppState (do
v <- liftE $ fst <$> fromVersion' sToolVer HLS
- liftE $ setHLS (_tvVersion v)
+ liftE $ setHLS (_tvVersion v) SetHLSOnly
pure v
)
>>= \case
diff --git a/lib/GHCup.hs b/lib/GHCup.hs
index 5a86ba2ab47c7d49d77d96a42d3190a850cef1fd..ca02662392bea49495c4f1745d7e5823dc872fab 100644
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@@ -5,8 +5,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
{-|
Module : GHCup
@@ -301,22 +301,6 @@ installPackedGHC dl msubdir inst ver forceInstall = do
liftE $ runBuildAction tmpUnpack
(Just inst)
(installUnpackedGHC workdir inst ver)
- where
- -- | Does basic checks for isolated installs
- -- Isolated Directory:
- -- 1. if it doesn't exist -> proceed
- -- 2. if it exists and is empty -> proceed
- -- 3. if it exists and is non-empty -> panic and leave the house
- installDestSanityCheck :: ( MonadIO m
- , MonadCatch m
- ) =>
- FilePath ->
- Excepts '[DirNotEmpty] m ()
- installDestSanityCheck isoDir = do
- hideErrorDef [doesNotExistErrorType] () $ do
- contents <- liftIO $ getDirectoryContentsRecursive isoDir
- unless (null contents) (throwE $ DirNotEmpty isoDir)
-
-- | Install an unpacked GHC distribution. This only deals with the GHC
@@ -582,6 +566,8 @@ installHLSBindist :: ( MonadMask m
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
+ , ProcessError
+ , DirNotEmpty
]
m
()
@@ -617,26 +603,55 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do
-- the subdir of the archive where we do the work
workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
+ legacy <- liftIO $ isLegacyHLSBindist workdir
+
+ if
+ | not forceInstall
+ , not legacy
+ , (Just fp) <- isoFilepath -> liftE $ installDestSanityCheck fp
+ | otherwise -> pure ()
case isoFilepath of
Just isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
- liftE $ installHLSUnpacked workdir isoDir Nothing forceInstall
+ if legacy
+ then liftE $ installHLSUnpackedLegacy workdir isoDir Nothing forceInstall
+ else liftE $ installHLSUnpacked workdir isoDir ver
Nothing -> do
- liftE $ installHLSUnpacked workdir binDir (Just ver) forceInstall
+ if legacy
+ then liftE $ installHLSUnpackedLegacy workdir binDir (Just ver) forceInstall
+ else do
+ inst <- ghcupHLSDir ver
+ liftE $ installHLSUnpacked workdir inst ver
+ liftE $ setHLS ver SetHLS_XYZ
liftE $ installHLSPostInst isoFilepath ver
+isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist
+ -> IO Bool
+isLegacyHLSBindist path = do
+ not <$> doesFileExist (path </> "GNUmakefile")
-- | Install an unpacked hls distribution.
-installHLSUnpacked :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
- => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
- -> FilePath -- ^ Path to install to
- -> Maybe Version -- ^ Nothing for isolated install
- -> Bool -- ^ is it a force install
- -> Excepts '[CopyError, FileAlreadyExistsError] m ()
-installHLSUnpacked path inst mver' forceInstall = do
+installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m)
+ => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
+ -> FilePath -- ^ Path to install to
+ -> Version
+ -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
+installHLSUnpacked path inst _ = do
+ lift $ logInfo "Installing HLS"
+ liftIO $ createDirRecursive' inst
+ lEM $ make ["PREFIX=" <> inst, "install"] (Just path)
+
+-- | Install an unpacked hls distribution (legacy).
+installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
+ => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
+ -> FilePath -- ^ Path to install to
+ -> Maybe Version -- ^ Nothing for isolated install
+ -> Bool -- ^ is it a force install
+ -> Excepts '[CopyError, FileAlreadyExistsError] m ()
+installHLSUnpackedLegacy path inst mver' forceInstall = do
lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst
@@ -692,7 +707,7 @@ installHLSPostInst isoFilepath ver =
-- create symlink if this is the latest version in a regular install
hlsVers <- lift $ fmap rights getInstalledHLSs
let lInstHLS = headMay . reverse . sort $ hlsVers
- when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver
+ when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver SetHLSOnly
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
@@ -725,6 +740,8 @@ installHLSBin :: ( MonadMask m
, TarDirDoesNotExist
, ArchiveResult
, FileAlreadyExistsError
+ , ProcessError
+ , DirNotEmpty
]
m
()
@@ -894,9 +911,9 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
case isolateDir of
Just isoDir -> do
lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
- liftE $ installHLSUnpacked installDir isoDir Nothing True
+ liftE $ installHLSUnpackedLegacy installDir isoDir Nothing True
Nothing -> do
- liftE $ installHLSUnpacked installDir binDir (Just installVer) True
+ liftE $ installHLSUnpackedLegacy installDir binDir (Just installVer) True
)
liftE $ installHLSPostInst isolateDir installVer
@@ -1088,9 +1105,9 @@ setGHC ver sghc = do
-- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup)
case sghc of
- SetGHCOnly -> liftE $ rmPlain (_tvTarget ver)
- SetGHC_XY -> liftE $ rmMajorSymlinks ver
- SetGHC_XYZ -> liftE $ rmMinorSymlinks ver
+ SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver)
+ SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver
+ SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver
-- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver
@@ -1109,9 +1126,10 @@ setGHC ver sghc = do
-- create symlink
forM_ mTargetFile $ \targetFile -> do
+ bindir <- ghcInternalBinDir ver
let fullF = binDir </> targetFile <> exeExt
- fileWithExt = file <> exeExt
- destL <- lift $ ghcLinkDestination fileWithExt ver
+ fileWithExt = bindir </> file <> exeExt
+ destL <- binarySymLinkDestination fileWithExt
lift $ createLink destL fullF
-- create symlink for share dir
@@ -1170,7 +1188,7 @@ unsetGHC :: ( MonadReader env m
)
=> Maybe Text
-> Excepts '[NotInstalled] m ()
-unsetGHC = rmPlain
+unsetGHC = rmPlainGHC
-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.
@@ -1222,35 +1240,52 @@ setHLS :: ( MonadReader env m
, MonadUnliftIO m
)
=> Version
+ -> SetHLS -- Nothing for legacy
-> Excepts '[NotInstalled] m ()
-setHLS ver = do
+setHLS ver shls = do
+ whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)))
+
+ -- symlink destination
Dirs {..} <- lift getDirs
- -- Delete old symlinks, since these might have different ghc versions than the
- -- selected version, so we could end up with stray or incorrect symlinks.
- oldSyms <- lift hlsSymlinks
- forM_ oldSyms $ \f -> do
- lift $ logDebug $ "rm " <> T.pack (binDir </> f)
- lift $ rmLink (binDir </> f)
+ -- first delete the old symlinks
+ case shls of
+ -- not for legacy
+ SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver
+ -- legacy and new
+ SetHLSOnly -> liftE rmPlainHLS
- -- set haskell-language-server-<ghcver> symlinks
- bins <- lift $ hlsServerBinaries ver Nothing
- when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
+ case shls of
+ -- not for legacy
+ SetHLS_XYZ -> do
+ bins <- lift $ hlsInternalServerScripts ver Nothing
- forM_ bins $ \f -> do
- let destL = f
- let target = (<> exeExt) . head . splitOn "~" $ f
- lift $ createLink destL (binDir </> target)
+ forM_ bins $ \f -> do
+ let fname = takeFileName f
+ destL <- binarySymLinkDestination f
+ let target = if "haskell-language-server-wrapper" `isPrefixOf` fname
+ then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt
+ else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt
+ lift $ createLink destL (binDir </> target)
- -- set haskell-language-server-wrapper symlink
- let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt
- let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
+ -- legacy and new
+ SetHLSOnly -> do
+ -- set haskell-language-server-<ghcver> symlinks
+ bins <- lift $ hlsServerBinaries ver Nothing
+ when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
- lift $ createLink destL wrapper
+ forM_ bins $ \f -> do
+ let destL = f
+ let target = (<> exeExt) . head . splitOn "~" $ f
+ lift $ createLink destL (binDir </> target)
- lift warnAboutHlsCompatibility
+ -- set haskell-language-server-wrapper symlink
+ let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt
+ let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
- pure ()
+ lift $ createLink destL wrapper
+
+ lift warnAboutHlsCompatibility
unsetHLS :: ( MonadMask m
@@ -1720,14 +1755,14 @@ rmGHCVer ver = do
-- this isn't atomic, order matters
when isSetGHC $ do
lift $ logInfo "Removing ghc symlinks"
- liftE $ rmPlain (_tvTarget ver)
+ liftE $ rmPlainGHC (_tvTarget ver)
lift $ logInfo "Removing ghc-x.y.z symlinks"
- liftE $ rmMinorSymlinks ver
+ liftE $ rmMinorGHCSymlinks ver
lift $ logInfo "Removing/rewiring ghc-x.y symlinks"
-- first remove
- handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
+ handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver
-- then fix them (e.g. with an earlier version)
lift $ logInfo $ "Removing directory recursively: " <> T.pack dir
@@ -1794,24 +1829,19 @@ rmHLSVer :: ( MonadMask m
rmHLSVer ver = do
whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))
- isHlsSet <- lift hlsSet
-
- Dirs {..} <- lift getDirs
+ isHlsSet <- lift hlsSet
- bins <- lift $ hlsAllBinaries ver
- forM_ bins $ \f -> lift $ recycleFile (binDir </> f)
+ liftE $ rmMinorHLSSymlinks ver
+ hlsDir <- ghcupHLSDir ver
+ recyclePathForcibly hlsDir
when (Just ver == isHlsSet) $ do
-- delete all set symlinks
- oldSyms <- lift hlsSymlinks
- forM_ oldSyms $ \f -> do
- let fullF = binDir </> f
- lift $ logDebug $ "rm " <> T.pack fullF
- lift $ rmLink fullF
+ rmPlainHLS
-- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs
case headMay . reverse . sort $ hlsVers of
- Just latestver -> setHLS latestver
+ Just latestver -> setHLS latestver SetHLSOnly
Nothing -> pure ()
@@ -2687,7 +2717,11 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
HLS -> do
whenM (lift $ fmap not $ hlsInstalled _tvVersion)
$ throwE (NotInstalled HLS (GHCTargetVersion Nothing _tvVersion))
- pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt)
+ ifM (lift $ isLegacyHLS _tvVersion)
+ (pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt))
+ $ do
+ bdir <- lift $ ghcupHLSDir _tvVersion
+ pure (bdir </> "bin" </> "haskell-language-server-wrapper" <> exeExt)
Stack -> do
whenM (lift $ fmap not $ stackInstalled _tvVersion)
@@ -2800,21 +2834,31 @@ rmHLSNoGHC :: ( MonadReader env m
, HasLog env
, MonadIO m
, MonadMask m
+ , MonadFail m
+ , MonadUnliftIO m
)
- => m ()
+ => Excepts '[NotInstalled] m ()
rmHLSNoGHC = do
Dirs {..} <- getDirs
ghcs <- fmap rights getInstalledGHCs
hlses <- fmap rights getInstalledHLSs
forM_ hlses $ \hls -> do
hlsGHCs <- fmap mkTVer <$> hlsGHCVersions' hls
- forM_ hlsGHCs $ \ghc -> do
- when (ghc `notElem` ghcs) $ do
- bins <- hlsServerBinaries hls (Just $ _tvVersion ghc)
- forM_ bins $ \bin -> do
- let f = binDir </> bin
+ let candidates = filter (`notElem` ghcs) hlsGHCs
+ if (length hlsGHCs - length candidates) <= 0
+ then rmHLSVer hls
+ else
+ forM_ candidates $ \ghc -> do
+ bins1 <- fmap (binDir </>) <$> hlsServerBinaries hls (Just $ _tvVersion ghc)
+ bins2 <- ifM (isLegacyHLS hls) (pure []) $ do
+ shs <- hlsInternalServerScripts hls (Just $ _tvVersion ghc)
+ bins <- hlsInternalServerBinaries hls (Just $ _tvVersion ghc)
+ libs <- hlsInternalServerLibs hls (_tvVersion ghc)
+ pure (shs ++ bins ++ libs)
+ forM_ (bins1 ++ bins2) $ \f -> do
logDebug $ "rm " <> T.pack f
rmFile f
+ pure ()
rmCache :: ( MonadReader env m
diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs
index d4fb570da4f22a9ffcff85cedc97c842b5e821ac..5014196c03338ad9394150c30f024c8eaed080a5 100644
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@@ -484,6 +484,10 @@ data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
| SetGHC_XYZ -- ^ ghc-x.y.z
deriving (Eq, Show)
+data SetHLS = SetHLSOnly -- ^ unversioned 'hls'
+ | SetHLS_XYZ -- ^ haskell-language-server-a.b.c~x.y.z, where a.b.c is GHC version and x.y.z is HLS version
+ deriving (Eq, Show)
+
data PlatformResult = PlatformResult
{ _platform :: Platform
diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs
index db686d6fcf8d2b3df43f9bd0eb328c8973b18387..a05dbfb66f8a512f58ca646d299565dd0f03fe4e 100644
--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@@ -125,31 +125,34 @@ import qualified Data.List.NonEmpty as NE
------------------------
--- | The symlink destination of a ghc tool.
-ghcLinkDestination :: ( MonadReader env m
- , HasDirs env
- , MonadThrow m, MonadIO m)
- => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
- -> GHCTargetVersion
- -> m FilePath
-ghcLinkDestination tool ver = do
+-- | Create a relative symlink destination for the binary directory,
+-- given a target toolpath.
+binarySymLinkDestination :: ( MonadReader env m
+ , HasDirs env
+ , MonadThrow m
+ , MonadIO m
+ )
+ => FilePath -- ^ the full toolpath
+ -> m FilePath
+binarySymLinkDestination toolPath = do
Dirs {..} <- getDirs
- ghcd <- ghcupGHCDir ver
- pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
+ toolPath' <- liftIO $ canonicalizePath toolPath
+ binDir' <- liftIO $ canonicalizePath binDir
+ pure (relativeSymlink binDir' toolPath')
-- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
-rmMinorSymlinks :: ( MonadReader env m
- , HasDirs env
- , MonadIO m
- , HasLog env
- , MonadThrow m
- , MonadFail m
- , MonadMask m
- )
- => GHCTargetVersion
- -> Excepts '[NotInstalled] m ()
-rmMinorSymlinks tv@GHCTargetVersion{..} = do
+rmMinorGHCSymlinks :: ( MonadReader env m
+ , HasDirs env
+ , MonadIO m
+ , HasLog env
+ , MonadThrow m
+ , MonadFail m
+ , MonadMask m
+ )
+ => GHCTargetVersion
+ -> Excepts '[NotInstalled] m ()
+rmMinorGHCSymlinks tv@GHCTargetVersion{..} = do
Dirs {..} <- lift getDirs
files <- liftE $ ghcToolFiles tv
@@ -161,17 +164,17 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
-- | Removes the set ghc version for the given target, if any.
-rmPlain :: ( MonadReader env m
- , HasDirs env
- , HasLog env
- , MonadThrow m
- , MonadFail m
- , MonadIO m
- , MonadMask m
- )
- => Maybe Text -- ^ target
- -> Excepts '[NotInstalled] m ()
-rmPlain target = do
+rmPlainGHC :: ( MonadReader env m
+ , HasDirs env
+ , HasLog env
+ , MonadThrow m
+ , MonadFail m
+ , MonadIO m
+ , MonadMask m
+ )
+ => Maybe Text -- ^ target
+ -> Excepts '[NotInstalled] m ()
+rmPlainGHC target = do
Dirs {..} <- lift getDirs
mtv <- lift $ ghcSet target
forM_ mtv $ \tv -> do
@@ -187,17 +190,17 @@ rmPlain target = do
-- | Remove the major GHC symlink, e.g. ghc-8.6.
-rmMajorSymlinks :: ( MonadReader env m
- , HasDirs env
- , MonadIO m
- , HasLog env
- , MonadThrow m
- , MonadFail m
- , MonadMask m
- )
- => GHCTargetVersion
- -> Excepts '[NotInstalled] m ()
-rmMajorSymlinks tv@GHCTargetVersion{..} = do
+rmMajorGHCSymlinks :: ( MonadReader env m
+ , HasDirs env
+ , MonadIO m
+ , HasLog env
+ , MonadThrow m
+ , MonadFail m
+ , MonadMask m
+ )
+ => GHCTargetVersion
+ -> Excepts '[NotInstalled] m ()
+rmMajorGHCSymlinks tv@GHCTargetVersion{..} = do
Dirs {..} <- lift getDirs
(mj, mi) <- getMajorMinorV _tvVersion
let v' = intToText mj <> "." <> intToText mi
@@ -210,6 +213,62 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
lift $ hideError doesNotExistErrorType $ rmLink fullF
+-- | Removes the minor HLS files, e.g. 'haskell-language-server-8.10.7~1.6.1.0'
+-- and 'haskell-language-server-wrapper-1.6.1.0'.
+rmMinorHLSSymlinks :: ( MonadReader env m
+ , HasDirs env
+ , MonadIO m
+ , HasLog env
+ , MonadThrow m
+ , MonadFail m
+ , MonadMask m
+ )
+ => Version
+ -> Excepts '[NotInstalled] m ()
+rmMinorHLSSymlinks ver = do
+ Dirs {..} <- lift getDirs
+
+ hlsBins <- hlsAllBinaries ver
+ forM_ hlsBins $ \f -> do
+ let fullF = binDir </> f <> exeExt
+ lift $ logDebug ("rm -f " <> T.pack fullF)
+ -- on unix, this may be either a file (legacy) or a symlink
+ -- on windows, this is always a file... hence 'rmFile'
+ -- works consistently across platforms
+ lift $ rmFile fullF
+
+-- | Removes the set HLS version, if any.
+rmPlainHLS :: ( MonadReader env m
+ , HasDirs env
+ , HasLog env
+ , MonadThrow m
+ , MonadFail m
+ , MonadIO m
+ , MonadMask m
+ )
+ => Excepts '[NotInstalled] m ()
+rmPlainHLS = do
+ Dirs {..} <- lift getDirs
+
+ -- delete 'haskell-language-server-8.10.7'
+ hlsBins <- fmap (filter (\f -> not ("haskell-language-server-wrapper" `isPrefixOf` f) && ('~' `notElem` f)))
+ $ liftIO $ handleIO (\_ -> pure []) $ findFiles
+ binDir
+ (makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString))
+ forM_ hlsBins $ \f -> do
+ let fullF = binDir </> f
+ lift $ logDebug ("rm -f " <> T.pack fullF)
+ if isWindows
+ then lift $ rmLink fullF
+ else lift $ rmFile fullF
+
+ -- 'haskell-language-server-wrapper'
+ let hlswrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
+ lift $ logDebug ("rm -f " <> T.pack hlswrapper)
+ if isWindows
+ then lift $ hideError doesNotExistErrorType $ rmLink hlswrapper
+ else lift $ hideError doesNotExistErrorType $ rmFile hlswrapper
+
-----------------------------------
@@ -353,7 +412,8 @@ cabalSet = do
-- | Get all installed hls, by matching on
--- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
+-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@,
+-- as well as @~\/.ghcup\/hls\/<\hlsver\>@
getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
=> m [Either FilePath Version]
getInstalledHLSs = do
@@ -364,7 +424,7 @@ getInstalledHLSs = do
execBlank
([s|^haskell-language-server-wrapper-.*$|] :: ByteString)
)
- forM bins $ \f ->
+ legacy <- forM bins $ \f ->
case
version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f)
of
@@ -372,6 +432,14 @@ getInstalledHLSs = do
Just (Left _) -> pure $ Left f
Nothing -> pure $ Left f
+ hlsdir <- ghcupHLSBaseDir
+ fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory hlsdir
+ new <- forM fs $ \f -> case parseGHCupHLSDir f of
+ Right r -> pure $ Right r
+ Left _ -> pure $ Left f
+ pure (nub (new <> legacy))
+
+
-- | Get all installed stacks, by matching on
-- @~\/.ghcup\/bin/stack-<\stackver\>@.
getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
@@ -447,6 +515,10 @@ hlsInstalled ver = do
vers <- fmap rights getInstalledHLSs
pure $ elem ver vers
+isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
+isLegacyHLS ver = do
+ bdir <- ghcupHLSDir ver
+ not <$> liftIO (doesDirectoryExist bdir)
-- Return the currently set hls version, if any.
@@ -518,7 +590,7 @@ hlsGHCVersions' v' = do
pure . sortBy (flip compare) . rights $ vers
--- | Get all server binaries for an hls version, if any.
+-- | Get all server binaries for an hls version from the ~/.ghcup/bin directory, if any.
hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
=> Version
-> Maybe Version -- ^ optional GHC version
@@ -539,6 +611,44 @@ hlsServerBinaries ver mghcVer = do
)
)
+-- | Get all scripts for a hls version from the ~/.ghcup/hls/<ver>/bin directory, if any.
+-- Returns the full path.
+hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
+ => Version
+ -> Maybe Version -- ^ optional GHC version
+ -> m [FilePath]
+hlsInternalServerScripts ver mghcVer = do
+ dir <- ghcupHLSDir ver
+ let bdir = dir </> "bin"
+ fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
+ <$> liftIO (listDirectory bdir)
+
+-- | Get all binaries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/bin directory, if any.
+-- Returns the full path.
+hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
+ => Version
+ -> Maybe Version -- ^ optional GHC version
+ -> m [FilePath]
+hlsInternalServerBinaries ver mghcVer = do
+ dir <- ghcupHLSDir ver
+ let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
+ (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left "bin"]
+ fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)
+ <$> liftIO (listDirectory bdir)
+
+-- | Get all libraries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/lib/<ghc-ver>/
+-- directory, if any.
+-- Returns the full path.
+hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)
+ => Version
+ -> Version -- ^ GHC version
+ -> m [FilePath]
+hlsInternalServerLibs ver ghcVer = do
+ dir <- ghcupHLSDir ver
+ let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString)
+ (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left ("lib" </> T.unpack (prettyVer ghcVer))]
+ fmap (bdir </>) <$> liftIO (listDirectory bdir)
+
-- | Get the wrapper binary for an hls version, if any.
hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
@@ -569,22 +679,6 @@ hlsAllBinaries ver = do
pure (maybeToList wrapper ++ hls)
--- | Get the active symlinks for hls.
-hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath]
-hlsSymlinks = do
- Dirs {..} <- getDirs
- oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles
- binDir
- (makeRegexOpts compExtended
- execBlank
- ([s|^haskell-language-server-.*$|] :: ByteString)
- )
- filterM
- ( liftIO
- . pathIsLink
- . (binDir </>)
- )
- oldSyms
@@ -809,8 +903,16 @@ getLatestBaseVersion av pvpVer =
--[ Other ]--
-------------
+-- | Usually @~\/.ghcup\/ghc\/\<ver\>\/bin\/@
+ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
+ => GHCTargetVersion
+ -> m FilePath
+ghcInternalBinDir ver = do
+ ghcdir <- ghcupGHCDir ver
+ pure (ghcdir </> "bin")
+
--- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
+-- | Get tool files from @~\/.ghcup\/ghc\/\<ver\>\/bin\/\*@
-- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
--
-- Returns unversioned relative files without extension, e.g.:
@@ -820,11 +922,10 @@ ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, Mona
=> GHCTargetVersion
-> Excepts '[NotInstalled] m [FilePath]
ghcToolFiles ver = do
- ghcdir <- lift $ ghcupGHCDir ver
- let bindir = ghcdir </> "bin"
+ bindir <- ghcInternalBinDir ver
-- fail if ghc is not installed
- whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
+ whenM (fmap not $ ghcInstalled ver)
(throwE (NotInstalled GHC ver))
files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir </>)))
@@ -1157,3 +1258,19 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
ghcBinaryName :: GHCTargetVersion -> String
ghcBinaryName (GHCTargetVersion (Just t) _) = T.unpack (t <> "-ghc" <> T.pack exeExt)
ghcBinaryName (GHCTargetVersion Nothing _) = T.unpack ("ghc" <> T.pack exeExt)
+
+
+-- | Does basic checks for isolated installs
+-- Isolated Directory:
+-- 1. if it doesn't exist -> proceed
+-- 2. if it exists and is empty -> proceed
+-- 3. if it exists and is non-empty -> panic and leave the house
+installDestSanityCheck :: ( MonadIO m
+ , MonadCatch m
+ ) =>
+ FilePath ->
+ Excepts '[DirNotEmpty] m ()
+installDestSanityCheck isoDir = do
+ hideErrorDef [doesNotExistErrorType] () $ do
+ contents <- liftIO $ getDirectoryContentsRecursive isoDir
+ unless (null contents) (throwE $ DirNotEmpty isoDir)
diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs
index 9af0747563802787a116b0b0ba113d2fc9c9e913..15e6fcb912a11ffbc8f2943fb273314664916871 100644
--- a/lib/GHCup/Utils/Dirs.hs
+++ b/lib/GHCup/Utils/Dirs.hs
@@ -20,8 +20,11 @@ module GHCup.Utils.Dirs
, ghcupCacheDir
, ghcupGHCBaseDir
, ghcupGHCDir
+ , ghcupHLSBaseDir
+ , ghcupHLSDir
, mkGhcupTmpDir
, parseGHCupGHCDir
+ , parseGHCupHLSDir
, relativeSymlink
, withGHCupTmpDir
, getConfigFilePath
@@ -46,6 +49,7 @@ import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor
import Data.Maybe
+import Data.Versions
import GHC.IO.Exception ( IOErrorType(NoSuchThing) )
import Haskus.Utils.Variant.Excepts
import Optics
@@ -244,6 +248,24 @@ parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
parseGHCupGHCDir (T.pack -> fp) =
throwEither $ MP.parse ghcTargetVerP "" fp
+parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
+parseGHCupHLSDir (T.pack -> fp) =
+ throwEither $ MP.parse version' "" fp
+
+-- | ~/.ghcup/hls by default, for new-style installs.
+ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
+ghcupHLSBaseDir = do
+ Dirs {..} <- getDirs
+ pure (baseDir </> "hls")
+
+-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.
+ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)
+ => Version
+ -> m FilePath
+ghcupHLSDir ver = do
+ basedir <- ghcupHLSBaseDir
+ let verdir = T.unpack $ prettyVer ver
+ pure (basedir </> verdir)
mkGhcupTmpDir :: ( MonadReader env m
, HasDirs env
@@ -313,6 +335,7 @@ useXDG :: IO Bool
useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
+-- | Like 'relpath'. Assumes the inputs are resolved in case of symlinks.
relativeSymlink :: FilePath -- ^ the path in which to create the symlink
-> FilePath -- ^ the symlink destination
-> FilePath
diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Utils/File/Common.hs
index 23ba8afab1d766874d1cc5a5e2516ebd31cb79a0..f777c611b6020f417334c9ae14831cc7582a08f4 100644
--- a/lib/GHCup/Utils/File/Common.hs
+++ b/lib/GHCup/Utils/File/Common.hs
@@ -13,7 +13,7 @@ import Data.Text ( Text )
import Data.Void
import GHC.IO.Exception
import Optics hiding ((<|), (|>))
-import System.Directory
+import System.Directory hiding (findFiles)
import System.FilePath
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix
@@ -100,6 +100,21 @@ isInPath p = do
else pure False
+-- | Follows the first match in case of Regex.
+expandFilePath :: [Either FilePath Regex] -> IO [FilePath]
+expandFilePath = go ""
+ where
+ go :: FilePath -> [Either FilePath Regex] -> IO [FilePath]
+ go p [] = pure [p]
+ go p (x:xs) = do
+ case x of
+ Left s -> go (p </> s) xs
+ Right regex -> do
+ fps <- findFiles p regex
+ res <- forM fps $ \fp -> go (p </> fp) xs
+ pure $ mconcat res
+
+
findFiles :: FilePath -> Regex -> IO [FilePath]
findFiles path regex = do
contents <- listDirectory path