Merge branch 'hls-dynamic-builds'

.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

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 ()
     )

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

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

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

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

docs/guide.md

@@ -224,66 +224,10 @@ For the full list of env variables and parameters to tweak the script behavior,
 * [bootstrap-haskell for linux/darwin/freebsd](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/scripts/bootstrap/bootstrap-haskell#L7)
 * [bootstrap-haskell.ps1 for windows](https://gitlab.haskell.org/haskell/ghcup-hs/-/blob/master/scripts/bootstrap/bootstrap-haskell.ps1#L17)
 
-### Example github workflow
+### github workflows
 
-On github workflows you can use [https://github.com/haskell/actions/](https://github.com/haskell/actions/)
+On github workflows you can use [https://github.com/haskell/actions/](https://github.com/haskell/actions/).
-
+GHCup itself is also pre-installed on all platforms, but may use non-standard install locations.
-If you want to install ghcup manually though, here's an example config:
-
-```yml
-name: Haskell CI
-
-on:
-  push:
-    branches: [ master ]
-  pull_request:
-    branches: [ master ]
-
-jobs:
-  build-cabal:
-
-    runs-on: ${{ matrix.os }}
-    strategy:
-      fail-fast: false
-      matrix:
-        os: [ubuntu-latest, macOS-latest, windows-latest]
-        ghc: ['8.10.7', '9.0.1']
-        cabal: ['3.4.0.0']
-
-    steps:
-    - uses: actions/checkout@v2
-
-    - if: matrix.os == 'windows-latest'
-      name: Install ghcup on windows
-      run: Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $false,$true,$true,$false,$false,$false,$false,"C:\"
-
-    - if: matrix.os == 'windows-latest'
-      name: Add ghcup to PATH
-      run: echo "/c/ghcup/bin" >> $GITHUB_PATH
-      shell: bash
-
-    - if: matrix.os != 'windows-latest'
-      name: Install ghcup on non-windows
-      run: curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh
-
-    - name: Install ghc/cabal
-      run: |
-        ghcup install ghc ${{ matrix.ghc }}
-        ghcup install cabal ${{ matrix.cabal }}
-      shell: bash
-
-    - name: Update cabal index
-      run: cabal update
-      shell: bash
-
-    - name: Build
-      run: cabal build --enable-tests --enable-benchmarks
-      shell: bash
-
-    - name: Run tests
-      run: cabal test
-      shell: bash
-```
 
 ## GPG verification
 

docs/install.md

@@ -35,7 +35,9 @@ Also see [tags and shortcuts](../guide/#tags-and-shortcuts) for more information
 ## First steps
 
 1. To get started with creating a Haskell project, follow the [Getting Started with Haskell and Cabal](https://cabal.readthedocs.io/en/latest/getting-started.html) guide
-2. To properly learn Haskell, run through the [CIS 194 Haskell course](https://www.cis.upenn.edu/~cis194/spring13/) including exercises
+2. To learn Haskell, try any of those:
+    - A beginner friendly [4-lectures course](https://github.com/haskell-beginners-2022/course-plan) with exercises (by [Kowainik](https://kowainik.github.io/))
+    - An in-depth university [CIS 194 Haskell course](https://www.cis.upenn.edu/~cis194/spring13/) including exercises (by [Brent Yorgey](https://byorgey.wordpress.com/))
 3. To learn more about Haskell Toolchain management, check out the [ghcup user guide](./guide.md)
 
 ## Uninstallation
@@ -86,14 +88,15 @@ May or may not work, several issues:
 
 Unsupported. GHC may or may not work. Upgrade to WSL2.
 
-### MacOS <13
+### MacOS <10.13
 
-Not supported. Would require separate binaries, since >=13 binaries are incompatible.
+Not supported. Would require separate binaries, since >=10.13 binaries are incompatible.
 Please upgrade.
 
 ### MacOS aarch64
 
-HLS bindists are still experimental. Stack is theoretically supported, but has no binaries yet.
+HLS bindists are still experimental. Stack has only unofficial binaries for this platform.
+There are various issues with GHC itself.
 
 ### FreeBSD
 
@@ -102,7 +105,7 @@ HLS bindists are experimental.
 
 ### Linux ARMv7/AARCH64
 
-Lower availability of bindists. HLS only has experimental ones. Stack not supported currently.
+Lower availability of bindists. Stack and HLS binaries are experimental.
 
 ## Manual install
 

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)
+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 the unpacked hls bindist (where the executable resides)
-              -> FilePath      -- ^ Path to install to
+                   -> FilePath      -- ^ Path to install to
-              -> Maybe Version -- ^ Nothing for isolated install
+                   -> Version
-              -> Bool          -- ^ is it a force install
+                   -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
-              -> Excepts '[CopyError, FileAlreadyExistsError] m ()
+installHLSUnpacked path inst _ = do
-installHLSUnpacked path inst mver' forceInstall = 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)
+    SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver)
-    SetGHC_XY  -> liftE $ rmMajorSymlinks ver
+    SetGHC_XY  -> liftE $ rmMajorGHCSymlinks ver
-    SetGHC_XYZ -> liftE $ rmMinorSymlinks 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
+          fileWithExt = bindir </> file <> exeExt
-      destL <- lift $ ghcLinkDestination fileWithExt ver
+      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
+  -- first delete the old symlinks
-  -- selected version, so we could end up with stray or incorrect symlinks.
+  case shls of
-  oldSyms <- lift hlsSymlinks
+    -- not for legacy
-  forM_ oldSyms $ \f -> do
+    SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver
-    lift $ logDebug $ "rm " <> T.pack (binDir </> f)
+    -- legacy and new
-    lift $ rmLink (binDir </> f)
+    SetHLSOnly -> liftE rmPlainHLS
 
-  -- set haskell-language-server-<ghcver> symlinks
+  case shls of
-  bins <- lift $ hlsServerBinaries ver Nothing
+    -- not for legacy
-  when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
+    SetHLS_XYZ -> do
+      bins <- lift $ hlsInternalServerScripts ver Nothing
 
-  forM_ bins $ \f -> do
+      forM_ bins $ \f -> do
-    let destL = f
+        let fname = takeFileName f
-    let target = (<> exeExt) . head . splitOn "~" $ f
+        destL <- binarySymLinkDestination f
-    lift $ createLink destL (binDir </> target)
+        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
+    -- legacy and new
-  let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt
+    SetHLSOnly -> do
-  let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
+      -- 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
+  isHlsSet <- lift hlsSet
 
-  Dirs {..} <- lift getDirs
+  liftE $ rmMinorHLSSymlinks ver
-
+  hlsDir <- ghcupHLSDir ver
-  bins <- lift $ hlsAllBinaries ver
+  recyclePathForcibly hlsDir
-  forM_ bins $ \f -> lift $ recycleFile (binDir </> f)
 
   when (Just ver == isHlsSet) $ do
     -- delete all set symlinks
-    oldSyms <- lift hlsSymlinks
+    rmPlainHLS
-    forM_ oldSyms $ \f -> do
-      let fullF = binDir </> f
-      lift $ logDebug $ "rm " <> T.pack fullF
-      lift $ rmLink fullF
     -- 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 
+    let candidates = filter (`notElem` ghcs) hlsGHCs
-      when (ghc `notElem` ghcs) $ do
+    if (length hlsGHCs - length candidates) <= 0
-        bins <- hlsServerBinaries hls (Just $ _tvVersion ghc)
+    then rmHLSVer hls
-        forM_ bins $ \bin -> do
+    else
-          let f = binDir </> bin
+      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

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

lib/GHCup/Utils.hs

@@ -125,31 +125,34 @@ import qualified Data.List.NonEmpty            as NE
     ------------------------
 
 
--- | The symlink destination of a ghc tool.
+-- | Create a relative symlink destination for the binary directory,
-ghcLinkDestination :: ( MonadReader env m
+-- given a target toolpath.
-                      , HasDirs env
+binarySymLinkDestination :: ( MonadReader env m
-                      , MonadThrow m, MonadIO m)
+                            , HasDirs env
-                   => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
+                            , MonadThrow m
-                   -> GHCTargetVersion
+                            , MonadIO m
-                   -> m FilePath
+                            )
-ghcLinkDestination tool ver = do
+                         => FilePath -- ^ the full toolpath
+                         -> m FilePath
+binarySymLinkDestination toolPath = do
   Dirs {..}  <- getDirs
-  ghcd <- ghcupGHCDir ver
+  toolPath' <- liftIO $ canonicalizePath toolPath
-  pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
+  binDir' <- liftIO $ canonicalizePath binDir
+  pure (relativeSymlink binDir' toolPath')
 
 
 -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
-rmMinorSymlinks :: ( MonadReader env m
+rmMinorGHCSymlinks :: ( MonadReader env m
-                   , HasDirs env
+                      , HasDirs env
-                   , MonadIO m
+                      , MonadIO m
-                   , HasLog env
+                      , HasLog env
-                   , MonadThrow m
+                      , MonadThrow m
-                   , MonadFail m
+                      , MonadFail m
-                   , MonadMask m
+                      , MonadMask m
-                   )
+                      )
-                => GHCTargetVersion
+                   => GHCTargetVersion
-                -> Excepts '[NotInstalled] m ()
+                   -> Excepts '[NotInstalled] m ()
-rmMinorSymlinks tv@GHCTargetVersion{..} = do
+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
+rmPlainGHC :: ( MonadReader env m
-           , HasDirs env
+              , HasDirs env
-           , HasLog env
+              , HasLog env
-           , MonadThrow m
+              , MonadThrow m
-           , MonadFail m
+              , MonadFail m
-           , MonadIO m
+              , MonadIO m
-           , MonadMask m
+              , MonadMask m
-           )
+              )
-        => Maybe Text -- ^ target
+           => Maybe Text -- ^ target
-        -> Excepts '[NotInstalled] m ()
+           -> Excepts '[NotInstalled] m ()
-rmPlain target = do
+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
+rmMajorGHCSymlinks :: ( MonadReader env m
-                   , HasDirs env
+                      , HasDirs env
-                   , MonadIO m
+                      , MonadIO m
-                   , HasLog env
+                      , HasLog env
-                   , MonadThrow m
+                      , MonadThrow m
-                   , MonadFail m
+                      , MonadFail m
-                   , MonadMask m
+                      , MonadMask m
-                   )
+                      )
-                => GHCTargetVersion
+                   => GHCTargetVersion
-                -> Excepts '[NotInstalled] m ()
+                   -> Excepts '[NotInstalled] m ()
-rmMajorSymlinks tv@GHCTargetVersion{..} = do
+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
+  bindir <- ghcInternalBinDir ver
-  let bindir = ghcdir </> "bin"
 
   -- 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)

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

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

scripts/update-sftp.sh

@@ -0,0 +1,38 @@
+#!/bin/bash
+
+url=$1
+ver=$2
+
+die() {
+    (>&2 printf "%s\\n" "$1")
+    exit 2
+}
+
+[ -z $url ] && die "no url set"
+[ -z $ver ] && die "no version set"
+
+sftp $url <<EOF
+cd ghcup
+
+rm aarch64-apple-darwin-ghcup
+rm aarch64-linux-ghcup
+rm armv7-linux-ghcup
+rm i386-linux-ghcup
+rm x86_64-apple-darwin-ghcup
+rm x86_64-linux-ghcup
+rm x86_64-mingw64-ghcup.exe
+rm x86_64-freebsd12-ghcup
+rm x86_64-freebsd13-ghcup
+
+symlink ${ver}/aarch64-apple-darwin-ghcup-${ver} aarch64-apple-darwin-ghcup
+symlink ${ver}/aarch64-linux-ghcup-${ver} aarch64-linux-ghcup
+symlink ${ver}/armv7-linux-ghcup-${ver} armv7-linux-ghcup
+symlink ${ver}/i386-linux-ghcup-${ver} i386-linux-ghcup
+symlink ${ver}/x86_64-apple-darwin-ghcup-${ver} x86_64-apple-darwin-ghcup
+symlink ${ver}/x86_64-freebsd12-ghcup-${ver} x86_64-freebsd12-ghcup
+symlink ${ver}/x86_64-freebsd13-ghcup-${ver} x86_64-freebsd13-ghcup
+symlink ${ver}/x86_64-linux-ghcup-${ver} x86_64-linux-ghcup
+symlink ${ver}/x86_64-mingw64-ghcup-${ver}.exe x86_64-mingw64-ghcup.exe
+EOF
+
+curl -X PURGE https://downloads.haskell.org/~ghcup/