diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml new file mode 100644 index 0000000000..3f05374956 --- /dev/null +++ b/.github/workflows/build.yml @@ -0,0 +1,116 @@ +name: Builds + +on: + release: + types: [created] +jobs: + + build: + runs-on: ${{ matrix.os }} + + strategy: + fail-fast: false + matrix: + ghc: ['8.10.1', '8.8.3', '8.8.2', '8.6.5', '8.6.4'] + os: [ubuntu-latest, macOS-latest, windows-latest] + exclude: + - os: windows-latest + ghc: '8.8.3' # fails due to segfault + - os: windows-latest + ghc: '8.8.2' # fails due to error with Cabal + + steps: + - uses: actions/checkout@v2 + with: + submodules: true + - uses: actions/setup-haskell@v1.1.1 + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: '3.2' + + - name: Cache Cabal + uses: actions/cache@v1.2.0 + with: + path: ~/.cabal + key: ${{ runner.OS }}-${{ matrix.ghc }}-${{ hashFiles('**/*.cabal') }} + + - name: Shorten binary names + shell: bash + run: | + sed -i.bak -e 's/haskell-language-server/hls/g' \ + -e 's/haskell_language_server/hls/g' \ + haskell-language-server.cabal + sed -i.bak -e 's/Paths_haskell_language_server/Paths_hls/g' \ + src/**/*.hs exe/*.hs + + - name: Set some window specific things + if: matrix.os == 'windows-latest' + shell: bash + run: | + echo '::set-env name=EXE_EXT::.exe' + + - name: Set some linux specific things + if: matrix.os == 'ubuntu-latest' + run: | + echo '::set-env name=LINUX_CABAL_ARGS::--enable-executable-static --ghc-options=-split-sections' + + - name: Build Server + shell: bash + # Try building it twice in case of flakey builds on Windows + run: | + cabal build exe:hls -O2 --disable-documentation $LINUX_CABAL_ARGS || \ + cabal build exe:hls -O2 --disable-documentation $LINUX_CABAL_ARGS + + - name: Find Server Binary + id: find_server_binary + shell: bash + run: | + HLS=$(find dist-newstyle \( -name 'hls' -o -name 'hls.exe' \) -type f) + gzip --best $HLS + echo ::set-output name=hls_binary::$HLS.gz + + - name: Upload Server Binary + uses: actions/upload-release-asset@v1.0.2 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + upload_url: ${{ github.event.release.upload_url }} + asset_path: ${{ steps.find_server_binary.outputs.hls_binary }} + asset_name: haskell-language-server-${{ runner.OS }}-${{ matrix.ghc }}${{env.EXE_EXT}}.gz + asset_content_type: application/gzip + + - uses: actions/upload-artifact@v2 + with: + name: haskell-language-server-${{ runner.OS }}-${{ matrix.ghc }}${{env.EXE_EXT}}.gz + path: ${{ steps.find_server_binary.outputs.hls_binary }} + + - name: Build Wrapper + if: matrix.ghc == '8.10.1' + run: cabal build exe:hls-wrapper -O2 --disable-documentation $WIN_CABAL_ARGS $LINUX_CABAL_ARGS + + - name: Find Wrapper Binary + if: matrix.ghc == '8.10.1' + id: find_wrapper_binary + shell: bash + run: | + HLS_WRAPPER=$(find dist-newstyle \( -name 'hls-wrapper' -o -name 'hls-wrapper.exe' \) -type f) + gzip --best $HLS_WRAPPER + echo ::set-output name=hls_wrapper_binary::$HLS_WRAPPER.gz + + - name: Upload Wrapper + if: matrix.ghc == '8.10.1' + uses: actions/upload-release-asset@v1.0.2 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + upload_url: ${{ github.event.release.upload_url }} + asset_path: ${{ steps.find_wrapper_binary.outputs.hls_wrapper_binary }} + asset_name: haskell-language-server-wrapper-${{ runner.OS }}${{env.EXE_EXT}}.gz + asset_content_type: application/gzip + + - uses: actions/upload-artifact@v2 + if: matrix.ghc == '8.10.1' + with: + name: haskell-language-server-wrapper-${{ runner.OS }}${{env.EXE_EXT}}.gz + path: ${{ steps.find_wrapper_binary.outputs.hls_wrapper_binary }} + diff --git a/.gitignore b/.gitignore index 9058bdc494..2b61164aa0 100644 --- a/.gitignore +++ b/.gitignore @@ -19,5 +19,8 @@ shake.yaml.lock stack*.yaml.lock shake.yaml.lock +# ignore hie.yaml's for testdata +test/testdata/**/hie.yaml + # metadata files on macOS .DS_Store diff --git a/.gitmodules b/.gitmodules index c64555bbb2..839d96ebdc 100644 --- a/.gitmodules +++ b/.gitmodules @@ -13,4 +13,5 @@ # url = https://github.com/digital-asset/ghcide.git # url = https://github.com/alanz/ghcide.git # url = https://github.com/wz1000/ghcide.git - url = https://github.com/fendor/ghcide.git + # url = https://github.com/fendor/ghcide.git + url = https://github.com/bubba/ghcide.git diff --git a/docs/releases.md b/docs/releases.md new file mode 100644 index 0000000000..a8645c1950 --- /dev/null +++ b/docs/releases.md @@ -0,0 +1,72 @@ +# Releases and distributable binaries + +Starting with 0.3.0.0 haskell-language-server provides pre-built binaries on +each [GitHub +release](https://github.com/haskell/haskell-language-server/releases). These +binaries are used by the [vscode-hie-server +extension](https://github.com/alanz/vscode-hie-server) to provide automatic +installation for users on VS Code, but they can also be installed manually +when added to the path. + +## Making a new release of haskell-language-server + +Go to the [GitHub releases +page](https://github.com/haskell/haskell-language-server/releases) for +haskell-language-server and start to create a new release. Choose or create a +tag, fill out the release notes etc., but before you create it +**make sure to check the pre-release checkbox**. This will prevent VS Code +*extension +users from attempting to install this version before the binaries are +created. + +Once the release is created the [GitHub Actions +workflow](https://github.com/haskell/haskell-language-server/actions) will be +kicked off and will start creating binaries. They will be gzipped and +uploaded to the release. + +It creates a `haskell-language-server-OS-GHC` binary for each platform +(Linux, macOS, Windows) and each GHC version that we currently support, as well +as a `haskell-language-server-wrapper-OS` binary for each platform. Note that +only one wrapper binary is created per platform, and it should be built with the +most recent GHC version. + +Once all these binaries are present + +## Distributable binaries +In order to compile a hls binary on one machine and have it run on another, you +need to make sure there are **no hardcoded paths or data-files**. + +### ghc libdir +One noteable thing which cannot be hardcoded is the **GHC libdir** – this is +a path to `/usr/local/lib/ghc` or something like that, which was previously +baked in at compile-time with ghc-paths. Note that with static binaries we +can no longer use this because the GHC libdir of the GitHub Actions machine +will most almost certainly not exist on the end user's machine. +Therefore, hie-bios provides `getGhcRuntimeLibDir` to obtain this path on the fly +by consulting the cradle. + +### Static binaries +We use the word "distributable" here because technically only the Linux builds +are static. They are built by passing `--enable-executable-static` to cabal. +Static binaries don't really exist on macOS, and there are issues with +proprietary code being linked in on Windows. However, the `.dylib`s linked on +macOS are all already provided by the system: + +``` +$ objdump -macho --dylibs-used haskell-language-server +haskell-language-server: + /usr/lib/libncurses.5.4.dylib (compatibility version 5.4.0, current version 5.4.0) + /usr/lib/libiconv.2.dylib (compatibility version 7.0.0, current version 7.0.0) + /usr/lib/libSystem.B.dylib (compatibility version 1.0.0, current version 1281.100.1) + /usr/lib/libcharset.1.dylib (compatibility version 2.0.0, current version 2.0.0) +``` + +## The GitHub Actions workflow +It just kicks off a matrix of jobs varying across GHC versions and OSs, building +the binaries with Cabal and extracting them from the dist-newstyle directory. +The binaries are built with -O2. + +One caveat is that we need to rename the binaries from +haskell-language-server/haskell-language-server-wrapper to hls/hls-wrapper due to +path length limitations on windows. But whenever we upload them to the release, +we make sure to upload them as their full name variant. diff --git a/exe/Arguments.hs b/exe/Arguments.hs index 1dcf3e6da0..81e388d3de 100644 --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -10,14 +10,11 @@ module Arguments ( Arguments(..) , getArguments - , ghcideVersion - , getLibdir + , haskellLanguageServerVersion ) where -import Data.Maybe import Data.Version import Development.GitRev -import qualified GHC.Paths import Options.Applicative import Paths_haskell_language_server import System.Environment @@ -37,6 +34,7 @@ data Arguments = Arguments , argsDebugOn :: Bool , argsLogFile :: Maybe String , argsThreads :: Int + , argsProjectGhcVersion :: Bool } deriving Show getArguments :: String -> IO Arguments @@ -80,21 +78,19 @@ arguments exeName = Arguments <> value 0 <> showDefault ) + <*> switch (long "project-ghc-version" + <> help "Work out the project GHC version and print it") -- --------------------------------------------------------------------- --- Set the GHC libdir to the nix libdir if it's present. -getLibdir :: IO FilePath -getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR" -ghcideVersion :: IO String -ghcideVersion = do +haskellLanguageServerVersion :: IO String +haskellLanguageServerVersion = do path <- getExecutablePath let gitHashSection = case $(gitHash) of x | x == "UNKNOWN" -> "" x -> " (GIT hash: " <> x <> ")" - return $ "ghcide version: " <> showVersion version + return $ "haskell-language-server version: " <> showVersion version <> " (GHC: " <> VERSION_ghc <> ") (PATH: " <> path <> ")" <> gitHashSection --- --------------------------------------------------------------------- diff --git a/exe/Main.hs b/exe/Main.hs index 0e4d299900..54e2354e8e 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -16,33 +16,15 @@ module Main(main) where import Arguments -import Control.Concurrent.Async import Control.Concurrent.Extra --- import Control.Exception -import Control.Exception.Safe import Control.Monad.Extra -import Control.Monad.IO.Class -import qualified Crypto.Hash.SHA1 as H -import Data.Aeson (ToJSON(toJSON)) -import Data.Bifunctor (Bifunctor(second)) -import Data.ByteString.Base16 (encode) -import qualified Data.ByteString.Char8 as B import Data.Default -import Data.Either -import Data.Either.Extra -import Data.Foldable -import Data.Function -import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet -import Data.IORef import Data.List.Extra import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Time.Clock (UTCTime) -import Data.Version --- import Development.GitRev import Development.IDE.Core.Debouncer import Development.IDE.Core.FileStore import Development.IDE.Core.OfInterest @@ -50,25 +32,15 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Rules import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Util import Development.IDE.LSP.LanguageServer import Development.IDE.LSP.Protocol import Development.IDE.Plugin +import Development.IDE.Session import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options -import Development.Shake (Action) -import DynFlags (gopt_set, gopt_unset, - updOptLevel) -import DynFlags (PackageFlag(..), PackageArg(..)) -import GHC hiding (def) -import GHC.Check --- import GhcMonad import HIE.Bios.Cradle -import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute) -import HIE.Bios.Types -import HscTypes (HscEnv(..), ic_dflags) import qualified Language.Haskell.LSP.Core as LSP import Ide.Logger import Ide.Plugin @@ -76,14 +48,7 @@ import Ide.Plugin.Config import Ide.Types (IdePlugins, ipMap) import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types -import Linker (initDynLinker) -import Module -import NameCache -import Packages --- import Paths_ghcide -import System.Directory import qualified System.Directory.Extra as IO --- import System.Environment import System.Exit import System.FilePath import System.IO @@ -108,7 +73,6 @@ import Ide.Plugin.StylishHaskell as StylishHaskell import Ide.Plugin.Brittany as Brittany #endif import Ide.Plugin.Pragmas as Pragmas --- import Data.Typeable (Typeable) -- --------------------------------------------------------------------- @@ -157,18 +121,15 @@ ghcIdePlugins pid ps = (asGhcIdePlugin ps, allLspCmdIds' pid ps) -- --------------------------------------------------------------------- --- -- Set the GHC libdir to the nix libdir if it's present. --- getLibdir :: IO FilePath --- getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR" - main :: IO () main = do -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work args@Arguments{..} <- getArguments "haskell-language-server" - if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess - else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion + hlsVer <- haskellLanguageServerVersion + if argsVersion then putStrLn hlsVer + else hPutStrLn stderr hlsVer {- see WARNING above -} LSP.setupLogger argsLogFile ["hls", "hie-bios"] $ if argsDebugOn then L.DEBUG else L.INFO @@ -198,6 +159,7 @@ main = do hPutStrLn stderr "Starting (haskell-language-server)LSP server..." hPutStrLn stderr $ " with arguments: " <> show args hPutStrLn stderr $ " with plugins: " <> show (Map.keys $ ipMap idePlugins') + hPutStrLn stderr $ " in directory: " <> dir hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" runLanguageServer options (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps wProg wIndefProg -> do t <- t @@ -267,570 +229,3 @@ showEvent _ (EventFileDiagnostics _ []) = return () showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) = withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags showEvent lock e = withLock lock $ print e - - --- | Run the specific cradle on a specific FilePath via hie-bios. -cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions) -cradleToSessionOpts cradle file = do - let showLine s = putStrLn ("> " ++ s) - cradleRes <- runCradle (cradleOptsProg cradle) showLine file - case cradleRes of - CradleSuccess r -> pure (Right r) - CradleFail err -> return (Left [err]) - -- For the None cradle perhaps we still want to report an Info - -- message about the fact that the file is being ignored. - CradleNone -> return (Left []) - -emptyHscEnv :: IORef NameCache -> IO HscEnv -emptyHscEnv nc = do - libdir <- getLibdir - env <- runGhc (Just libdir) getSession - initDynLinker env - pure $ setNameCache nc env - --- | Convert a target to a list of potential absolute paths. --- A TargetModule can be anywhere listed by the supplied include --- directories --- A target file is a relative path but with a specific prefix so just need --- to canonicalise it. -targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath] -targetToFile is (TargetModule mod) = do - let fps = [i moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ] - exts = ["hs", "hs-boot", "lhs"] - mapM (fmap toNormalizedFilePath' . canonicalizePath) fps -targetToFile _ (TargetFile f _) = do - f' <- canonicalizePath f - return [toNormalizedFilePath' f'] - -setNameCache :: IORef NameCache -> HscEnv -> HscEnv -setNameCache nc hsc = hsc { hsc_NC = nc } - --- | This is the key function which implements multi-component support. All --- components mapping to the same hie.yaml file are mapped to the same --- HscEnv which is updated as new components are discovered. -loadSession :: FilePath -> IO (Action IdeGhcSession) -loadSession dir = do - -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file - hscEnvs <- newVar Map.empty :: IO (Var HieMap) - -- Mapping from a Filepath to HscEnv - fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) - -- Version of the mappings above - version <- newVar 0 - let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) - let invalidateShakeCache = do - modifyVar_ version (return . succ) - -- This caches the mapping from Mod.hs -> hie.yaml - cradleLoc <- liftIO $ memoIO $ \v -> do - res <- findCradle v - -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path - -- try and normalise that - -- e.g. see https://github.com/digital-asset/ghcide/issues/126 - res' <- traverse IO.makeAbsolute res - return $ normalise <$> res' - - libdir <- getLibdir - installationCheck <- ghcVersionChecker libdir - - dummyAs <- async $ return (error "Uninitialised") - runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) - - case installationCheck of - InstallationNotFound{..} -> - error $ "GHC installation not found in libdir: " <> libdir - InstallationMismatch{..} -> - return $ returnWithVersion $ \fp -> return (([renderPackageSetupException compileTime fp GhcVersionMismatch{..}], Nothing),[]) - InstallationChecked compileTime ghcLibCheck -> return $ do - ShakeExtras{logger, eventer, withIndefiniteProgress, ideNc, session=ideSession} <- getShakeExtras - IdeOptions{optTesting = IdeTesting optTesting} <- getIdeOptions - - -- Create a new HscEnv from a hieYaml root and a set of options - -- If the hieYaml file already has an HscEnv, the new component is - -- combined with the components in the old HscEnv into a new HscEnv - -- which contains the union. - let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) - -> IO (HscEnv, ComponentInfo, [ComponentInfo]) - packageSetup (hieYaml, cfp, opts) = do - -- Parse DynFlags for the newly discovered component - hscEnv <- emptyHscEnv ideNc - (df, targets) <- evalGhcEnv hscEnv $ - setOptions opts (hsc_dflags hscEnv) - let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- getDependencyInfo deps - -- Now lookup to see whether we are combining with an existing HscEnv - -- or making a new one. The lookup returns the HscEnv and a list of - -- information about other components loaded into the HscEnv - -- (unitId, DynFlag, Targets) - modifyVar hscEnvs $ \m -> do - -- Just deps if there's already an HscEnv - -- Nothing is it's the first time we are making an HscEnv - let oldDeps = Map.lookup hieYaml m - let -- Add the raw information about this component to the list - -- We will modify the unitId and DynFlags used for - -- compilation but these are the true source of - -- information. - new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info - : maybe [] snd oldDeps - -- Get all the unit-ids for things in this component - inplace = map rawComponentUnitId new_deps - - new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do - -- Remove all inplace dependencies from package flags for - -- components in this HscEnv - let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags - let prefix = show rawComponentUnitId - -- See Note [Avoiding bad interface files] - processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2 - -- The final component information, mostly the same but the DynFlags don't - -- contain any packages which are also loaded - -- into the same component. - pure $ ComponentInfo rawComponentUnitId - processed_df - uids - rawComponentTargets - rawComponentFP - rawComponentCOptions - rawComponentDependencyInfo - -- Make a new HscEnv, we have to recompile everything from - -- scratch again (for now) - -- It's important to keep the same NameCache though for reasons - -- that I do not fully understand - logInfo logger (T.pack ("Making new HscEnv" ++ show inplace)) - hscEnv <- emptyHscEnv ideNc - newHscEnv <- - -- Add the options for the current component to the HscEnv - evalGhcEnv hscEnv $ do - _ <- setSessionDynFlags df - checkSession logger ghcLibCheck - getSession - - -- Modify the map so the hieYaml now maps to the newly created - -- HscEnv - -- Returns - -- . the new HscEnv so it can be used to modify the - -- FilePath -> HscEnv map (fileToFlags) - -- . The information for the new component which caused this cache miss - -- . The modified information (without -inplace flags) for - -- existing packages - pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps')) - - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO ([NormalizedFilePath],(IdeResult HscEnvEq,[FilePath])) - session (hieYaml, cfp, opts) = do - (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts) - -- Make a map from unit-id to DynFlags, this is used when trying to - -- resolve imports. (especially PackageImports) - let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps) - - -- For each component, now make a new HscEnvEq which contains the - -- HscEnv for the hie.yaml file but the DynFlags for that component - - -- New HscEnv for the component in question, returns the new HscEnvEq and - -- a mapping from FilePath to the newly created HscEnvEq. - let new_cache = newComponentCache logger hscEnv uids - (cs, res) <- new_cache new - -- Modified cache targets for everything else in the hie.yaml file - -- which now uses the same EPS and so on - cached_targets <- concatMapM (fmap fst . new_cache) old_deps - modifyVar_ fileToFlags $ \var -> do - pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var - - -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - invalidateShakeCache - -- restartShakeSession [kick] - - return (map fst cs, second Map.keys res) - - let consultCradle :: Maybe FilePath -> FilePath -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath])) - consultCradle hieYaml cfp = do - when optTesting $ eventer $ notifyCradleLoaded cfp - logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp) - - cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml - -- Display a user friendly progress message here: They probably don't know what a - -- cradle is - let progMsg = "Setting up project " <> T.pack (takeBaseName (cradleRootDir cradle)) - eopts <- withIndefiniteProgress progMsg LSP.NotCancellable $ - cradleToSessionOpts cradle cfp - - logDebug logger $ T.pack ("Session loading result: " <> show eopts) - case eopts of - -- The cradle gave us some options so get to work turning them - -- into and HscEnv. - Right opts -> do - session (hieYaml, toNormalizedFilePath' cfp, opts) - -- Failure case, either a cradle error or the none cradle - Left err -> do - dep_info <- getDependencyInfo (maybeToList hieYaml) - let ncfp = toNormalizedFilePath' cfp - let res = (map (renderCradleError ncfp) err, Nothing) - modifyVar_ fileToFlags $ \var -> do - pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var - return ([ncfp],(res,[])) - - -- This caches the mapping from hie.yaml + Mod.hs -> [String] - -- Returns the Ghc session and the cradle dependencies - let sessionOpts :: (Maybe FilePath, FilePath) -> IO ([NormalizedFilePath], (IdeResult HscEnvEq, [FilePath])) - sessionOpts (hieYaml, file) = do - v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags - cfp <- canonicalizePath file - case HM.lookup (toNormalizedFilePath' cfp) v of - Just (opts, old_di) -> do - deps_ok <- checkDependencyInfo old_di - if not deps_ok - then do - -- If the dependencies are out of date then clear both caches and start - -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - -- Keep the same name cache - modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml ) - consultCradle hieYaml cfp - else return ([], (opts, Map.keys old_di)) - Nothing -> consultCradle hieYaml cfp - - -- The main function which gets options for a file. We only want one of these running - -- at a time. Therefore the IORef contains the currently running cradle, if we try - -- to get some more options then we wait for the currently running action to finish - -- before attempting to do so. - let getOptions :: FilePath -> IO ([NormalizedFilePath],(IdeResult HscEnvEq, [FilePath])) - getOptions file = do - hieYaml <- cradleLoc file - sessionOpts (hieYaml, file) `catch` \e -> - return ([],(([renderPackageSetupException compileTime file e], Nothing),[])) - - returnWithVersion $ \file -> do - (cs, opts) <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do - -- If the cradle is not finished, then wait for it to finish. - void $ wait as - as <- async $ getOptions file - return $ (fmap snd as, wait as) - unless (null cs) $ - void $ shakeEnqueueSession ideSession $ mkDelayedAction "InitialLoad" Info $ void $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) cs - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - uses GetModIface cs_exist - pure opts - --- | Create a mapping from FilePaths to HscEnvEqs -newComponentCache - :: Logger - -> HscEnv - -> [(InstalledUnitId, DynFlags)] - -> ComponentInfo - -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo)) -newComponentCache logger hsc_env uids ci = do - let df = componentDynFlags ci - let hscEnv' = hsc_env { hsc_dflags = df - , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } - - henv <- newHscEnvEq hscEnv' uids - let res = (([], Just henv), componentDependencyInfo ci) - logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) - - let is = importPaths df - ctargets <- concatMapM (targetToFile is . targetId) (componentTargets ci) - -- A special target for the file which caused this wonderful - -- component to be created. In case the cradle doesn't list all the targets for - -- the component, in which case things will be horribly broken anyway. - -- Otherwise, we will immediately attempt to reload this module which - -- causes an infinite loop and high CPU usage. - let special_target = (componentFP ci, res) - let xs = map (,res) ctargets - return (special_target:xs, res) - -{- Note [Avoiding bad interface files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Originally, we set the cache directory for the various components once -on the first occurrence of the component. -This works fine if these components have no references to each other, -but you have components that depend on each other, the interface files are -updated for each component. -After restarting the session and only opening the component that depended -on the other, suddenly the interface files of this component are stale. -However, from the point of view of `ghcide`, they do not look stale, -thus, not regenerated and the IDE shows weird errors such as: -``` -typecheckIface -Declaration for Rep_ClientRunFlags -Axiom branches Rep_ClientRunFlags: - Failed to load interface for ‘Distribution.Simple.Flag’ - Use -v to see a list of the files searched for. -``` -and -``` -expectJust checkFamInstConsistency -CallStack (from HasCallStack): - error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes - expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst -``` - -To mitigate this, we set the cache directory for each component dependent -on the components of the current `HscEnv`, additionally to the component options -of the respective components. -Assume two components, c1, c2, where c2 depends on c1, and the options of the -respective components are co1, co2. -If we want to load component c2, followed by c1, we set the cache directory for -each component in this way: - - * Load component c2 - * (Cache Directory State) - - name of c2 + co2 - * Load component c1 - * (Cache Directory State) - - name of c2 + name of c1 + co2 - - name of c2 + name of c1 + co1 - -Overall, we created three cache directories. If we opened c1 first, then we -create a fourth cache directory. -This makes sure that interface files are always correctly updated. - -Since this causes a lot of recompilation, we only update the cache-directory, -if the dependencies of a component have really changed. -E.g. when you load two executables, they can not depend on each other. They -should be filtered out, such that we dont have to re-compile everything. --} - --- | Set the cache-directory based on the ComponentOptions and a list of --- internal packages. --- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags -setCacheDir logger prefix hscComponents comps dflags = do - cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps) - liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir - pure $ dflags - & setHiDir cacheDir - & setHieDir cacheDir - - -renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic -renderCradleError nfp (CradleError _ _ec t) = - ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t)) - --- See Note [Multi Cradle Dependency Info] -type DependencyInfo = Map.Map FilePath (Maybe UTCTime) -type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo]) -type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) - --- This is pristine information about a component -data RawComponentInfo = RawComponentInfo - { rawComponentUnitId :: InstalledUnitId - -- | Unprocessed DynFlags. Contains inplace packages such as libraries. - -- We do not want to use them unprocessed. - , rawComponentDynFlags :: DynFlags - -- | All targets of this components. - , rawComponentTargets :: [Target] - -- | Filepath which caused the creation of this component - , rawComponentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , rawComponentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info]. - , rawComponentDependencyInfo :: DependencyInfo - } - --- This is processed information about the component, in particular the dynflags will be modified. -data ComponentInfo = ComponentInfo - { componentUnitId :: InstalledUnitId - -- | Processed DynFlags. Does not contain inplace packages such as local - -- libraries. Can be used to actually load this Component. - , componentDynFlags :: DynFlags - -- | Internal units, such as local libraries, that this component - -- is loaded with. These have been extracted from the original - -- ComponentOptions. - , componentInternalUnits :: [InstalledUnitId] - -- | All targets of this components. - , componentTargets :: [Target] - -- | Filepath which caused the creation of this component - , componentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , componentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info] - , componentDependencyInfo :: DependencyInfo - } - --- | Check if any dependency has been modified lately. -checkDependencyInfo :: DependencyInfo -> IO Bool -checkDependencyInfo old_di = do - di <- getDependencyInfo (Map.keys old_di) - return (di == old_di) - --- Note [Multi Cradle Dependency Info] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Why do we implement our own file modification tracking here? --- The primary reason is that the custom caching logic is quite complicated and going into shake --- adds even more complexity and more indirection. I did try for about 5 hours to work out how to --- use shake rules rather than IO but eventually gave up. - --- | Computes a mapping from a filepath to its latest modification date. --- See Note [Multi Cradle Dependency Info] why we do this ourselves instead --- of letting shake take care of it. -getDependencyInfo :: [FilePath] -> IO DependencyInfo -getDependencyInfo fs = Map.fromList <$> mapM do_one fs - - where - tryIO :: IO a -> IO (Either IOException a) - tryIO = try - - do_one :: FilePath -> IO (FilePath, Maybe UTCTime) - do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp) - --- | This function removes all the -package flags which refer to packages we --- are going to deal with ourselves. For example, if a executable depends --- on a library component, then this function will remove the library flag --- from the package flags for the executable --- --- There are several places in GHC (for example the call to hptInstances in --- tcRnImports) which assume that all modules in the HPT have the same unit --- ID. Therefore we create a fake one and give them all the same unit id. -removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId]) -removeInplacePackages us df = (df { packageFlags = ps - , thisInstalledUnitId = fake_uid }, uids) - where - (uids, ps) = partitionEithers (map go (packageFlags df)) - fake_uid = toInstalledUnitId (stringToUnitId "fake_uid") - go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us - then Left (toInstalledUnitId u) - else Right p - go p = Right p - --- | Memoize an IO function, with the characteristics: --- --- * If multiple people ask for a result simultaneously, make sure you only compute it once. --- --- * If there are exceptions, repeatedly reraise them. --- --- * If the caller is aborted (async exception) finish computing it anyway. -memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b) -memoIO op = do - ref <- newVar Map.empty - return $ \k -> join $ mask_ $ modifyVar ref $ \mp -> - case Map.lookup k mp of - Nothing -> do - res <- onceFork $ op k - return (Map.insert k res mp, res) - Just res -> return (mp, res) - --- | Throws if package flags are unsatisfiable -setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target]) -setOptions (ComponentOptions theOpts compRoot _) dflags = do - (dflags', targets) <- addCmdOpts theOpts dflags - let dflags'' = - -- disabled, generated directly by ghcide instead - flip gopt_unset Opt_WriteInterface $ - -- disabled, generated directly by ghcide instead - -- also, it can confuse the interface stale check - dontWriteHieFiles $ - setIgnoreInterfacePragmas $ - setLinkerOptions $ - disableOptimisation $ - makeDynFlagsAbsolute compRoot dflags' - -- initPackages parses the -package flags and - -- sets up the visibility for each component. - -- Throws if a -package flag cannot be satisfied. - (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags'' - return (final_df, targets) - - --- we don't want to generate object code so we compile to bytecode --- (HscInterpreted) which implies LinkInMemory --- HscInterpreted -setLinkerOptions :: DynFlags -> DynFlags -setLinkerOptions df = df { - ghcLink = LinkInMemory - , hscTarget = HscNothing - , ghcMode = CompManager - } - -setIgnoreInterfacePragmas :: DynFlags -> DynFlags -setIgnoreInterfacePragmas df = - gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges - -disableOptimisation :: DynFlags -> DynFlags -disableOptimisation df = updOptLevel 0 df - -setHiDir :: FilePath -> DynFlags -> DynFlags -setHiDir f d = - -- override user settings to avoid conflicts leading to recompilation - d { hiDir = Just f} - -getCacheDir :: String -> [String] -> IO FilePath -getCacheDir prefix opts = IO.getXdgDirectory IO.XdgCache (cacheDir prefix ++ "-" ++ opts_hash) - where - -- Create a unique folder per set of different GHC options, assuming that each different set of - -- GHC options will create incompatible interface files. - opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts) - --- | Sub directory for the cache path -cacheDir :: String -cacheDir = "ghcide" - -notifyCradleLoaded :: FilePath -> FromServerMessage -notifyCradleLoaded fp = - NotCustomServer $ - NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $ - toJSON fp - -cradleLoadedMethod :: T.Text -cradleLoadedMethod = "ghcide/cradle/loaded" - ----------------------------------------------------------------------------------------------------- - -ghcVersionChecker :: GhcVersionChecker -ghcVersionChecker = $$(makeGhcVersionChecker getLibdir) - --- | Throws a 'PackageSetupException' if the 'Session' cannot be used by ghcide -checkSession :: Logger -> Ghc PackageCheckResult -> Ghc () -checkSession logger ghcLibCheck = - ghcLibCheck >>= \res -> case guessCompatibility res of - ProbablyCompatible mbWarning -> - for_ mbWarning $ liftIO . logInfo logger . T.pack - NotCompatible err -> - liftIO $ throwIO $ PackageCheckFailed err - -data PackageSetupException - = PackageSetupException - { message :: !String - } - | GhcVersionMismatch - { compileTime :: !Version - , runTime :: !Version - } - | PackageCheckFailed !NotCompatibleReason - deriving (Eq, Show, Typeable) - -instance Exception PackageSetupException - --- | Wrap any exception as a 'PackageSetupException' -wrapPackageSetupException :: IO a -> IO a -wrapPackageSetupException = handleAny $ \case - e | Just (pkgE :: PackageSetupException) <- fromException e -> throwIO pkgE - e -> (throwIO . PackageSetupException . show) e - -showPackageSetupException :: Version -> PackageSetupException -> String -showPackageSetupException _ GhcVersionMismatch{..} = unwords - ["ghcide compiled against GHC" - ,showVersion compileTime - ,"but currently using" - ,showVersion runTime - ,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project." - ] -showPackageSetupException compileTime PackageSetupException{..} = unwords - [ "ghcide compiled by GHC", showVersion compileTime - , "failed to load packages:", message <> "." - , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."] -showPackageSetupException _ (PackageCheckFailed PackageVersionMismatch{..}) = unwords - ["ghcide compiled with package " - , packageName <> "-" <> showVersion compileTime - ,"but project uses package" - , packageName <> "-" <> showVersion runTime - ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." - ] -showPackageSetupException _ (PackageCheckFailed BasePackageAbiMismatch{..}) = unwords - ["ghcide compiled with base-" <> showVersion compileTime <> "-" <> compileTimeAbi - ,"but project uses base-" <> showVersion compileTime <> "-" <> runTimeAbi - ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." - ] - -renderPackageSetupException :: Version -> FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) -renderPackageSetupException compileTime fp e = - ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException compileTime e) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 395eae6972..703ceedaf3 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -1,33 +1,24 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} -- | This module is based on the hie-wrapper.sh script in -- https://github.com/alanz/vscode-hie-server module Main where -#if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup -#endif - import Arguments --- import Control.Concurrent.Extra import Control.Monad.Extra -import Data.Foldable -import Data.List --- import Data.List.Extra --- import qualified Data.Text as T --- import qualified Data.Text.IO as T --- import Development.IDE.Types.Logger +import Data.Foldable +import Data.List +import Data.Void import HIE.Bios -import Ide.Cradle (findLocalCradle) -import Ide.Logger (logm) -import Ide.Version -import System.Directory -import System.Environment +import HIE.Bios.Environment +import HIE.Bios.Types +import Ide.Version +import System.Directory +import System.Environment import System.Exit -import System.FilePath +import System.FilePath import System.IO -import System.Info -import System.Process +import System.Info +import System.Process -- --------------------------------------------------------------------- @@ -37,41 +28,31 @@ main = do -- then the language server will not work Arguments{..} <- getArguments "haskell-language-server-wrapper" - if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess - else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion - - -- lock to avoid overlapping output on stdout - -- lock <- newLock - -- let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $ - -- T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg - - whenJust argsCwd setCurrentDirectory + d <- getCurrentDirectory - -- let mLogFileName = optLogFile opts + -- Get the cabal directory from the cradle + cradle <- findLocalCradle (d "a") + setCurrentDirectory $ cradleRootDir cradle - -- logLevel = if optDebugOn opts - -- then L.DEBUG - -- else L.INFO + when argsProjectGhcVersion $ getRuntimeGhcVersion' cradle >>= putStrLn >> exitSuccess + when argsVersion $ haskellLanguageServerVersion >>= putStrLn >> exitSuccess - -- Core.setupLogger mLogFileName ["hie"] logLevel + whenJust argsCwd setCurrentDirectory progName <- getProgName - logm $ "run entered for haskell-language-server-wrapper(" ++ progName ++ ") " - ++ hlsVersion - d <- getCurrentDirectory - logm $ "Current directory:" ++ d - logm $ "Operating system:" ++ os + hPutStrLn stderr $ "Run entered for haskell-language-server-wrapper(" ++ progName ++ ") " + ++ hlsVersion + hPutStrLn stderr $ "Current directory: " ++ d + hPutStrLn stderr $ "Operating system: " ++ os args <- getArgs - logm $ "args:" ++ show args - - -- Get the cabal directory from the cradle - cradle <- findLocalCradle (d "File.hs") - let dir = cradleRootDir cradle - logm $ "Cradle directory:" ++ dir - setCurrentDirectory dir + hPutStrLn stderr $ "Arguments: " ++ show args + hPutStrLn stderr $ "Cradle directory: " ++ cradleRootDir cradle + hPutStrLn stderr $ "Cradle type: " ++ show (actionName (cradleOptsProg cradle)) - ghcVersion <- getProjectGhcVersion cradle - logm $ "Project GHC version:" ++ ghcVersion + -- Get the ghc version -- this might fail! + hPutStrLn stderr $ "Consulting the cradle to get project GHC version..." + ghcVersion <- getRuntimeGhcVersion' cradle + hPutStrLn stderr $ "Project GHC version: " ++ ghcVersion let hlsBin = "haskell-language-server-" ++ ghcVersion @@ -82,17 +63,62 @@ main = do candidates' = [hlsBin, backupHlsBin, "haskell-language-server"] candidates = map (++ exeExtension) candidates' - logm $ "haskell-language-server exe candidates :" ++ show candidates + hPutStrLn stderr $ "haskell-language-server exe candidates: " ++ show candidates mexes <- traverse findExecutable candidates case asum mexes of - Nothing -> logm $ "cannot find any haskell-language-server exe, looked for:" ++ intercalate ", " candidates + Nothing -> hPutStrLn stderr $ "Cannot find any haskell-language-server exe, looked for: " ++ intercalate ", " candidates Just e -> do - logm $ "found haskell-language-server exe at:" ++ e - logm $ "args:" ++ show args - logm "launching ....\n\n\n" + hPutStrLn stderr $ "Launching haskell-language-server exe at:" ++ e callProcess e args - logm "done" --- --------------------------------------------------------------------- +-- | Version of 'getRuntimeGhcVersion' that dies if we can't get it, and also +-- checks to see if the tool is missing if it is one of +getRuntimeGhcVersion' :: Show a => Cradle a -> IO String +getRuntimeGhcVersion' cradle = do + + -- See if the tool is installed + case actionName (cradleOptsProg cradle) of + Stack -> checkToolExists "stack" + Cabal -> checkToolExists "cabal" + Default -> checkToolExists "ghc" + Direct -> checkToolExists "ghc" + _ -> pure () + + ghcVersionRes <- getRuntimeGhcVersion cradle + case ghcVersionRes of + CradleSuccess ver -> do + return ver + CradleFail error -> die $ "Failed to get project GHC version:" ++ show error + CradleNone -> die "Failed get project GHC version, since we have a none cradle" + where + checkToolExists exe = do + exists <- findExecutable exe + case exists of + Just _ -> pure () + Nothing -> + die $ "Cradle requires " ++ exe ++ " but couldn't find it" ++ "\n" + ++ show cradle + +-- | Find the cradle that the given File belongs to. +-- +-- First looks for a "hie.yaml" file in the directory of the file +-- or one of its parents. If this file is found, the cradle +-- is read from the config. If this config does not comply to the "hie.yaml" +-- specification, an error is raised. +-- +-- If no "hie.yaml" can be found, the implicit config is used. +-- The implicit config uses different heuristics to determine the type +-- of the project that may or may not be accurate. +findLocalCradle :: FilePath -> IO (Cradle Void) +findLocalCradle fp = do + cradleConf <- findCradle fp + crdl <- case cradleConf of + Just yaml -> do + hPutStrLn stderr $ "Found \"" ++ yaml ++ "\" for \"" ++ fp ++ "\"" + loadCradle yaml + Nothing -> loadImplicitCradle fp + hPutStrLn stderr $ "Module \"" ++ fp ++ "\" is loaded by Cradle: " ++ show crdl + return crdl + diff --git a/ghcide b/ghcide index 8530b98087..7e895cfa53 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit 8530b980871f9bc4f6fc2e688a4620e5fe1a0340 +Subproject commit 7e895cfa53260b41996df707baec496a8f2c75dc diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index d4095fa735..48366782de 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -38,7 +38,6 @@ common agpl library import: agpl exposed-modules: - Ide.Cradle Ide.Logger Ide.Plugin Ide.Plugin.Config @@ -63,7 +62,6 @@ library , aeson , binary , bytestring - , cabal-helper >= 1.1 , containers , data-default , deepseq @@ -136,33 +134,20 @@ executable haskell-language-server build-depends: base >=4.7 && <5 - , aeson - , async - , base16-bytestring , binary - , bytestring - , cryptohash-sha1 , containers , data-default - , deepseq , directory , extra , filepath - -------------------------------------------------------------- - -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas - -- which require depending on ghc. So the tests need to depend - -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a - -- better solution can be found, but this is a quick solution - -- which works for now. + , process , ghc -------------------------------------------------------------- - , ghc-check >= 0.5.0.1 && < 0.6 - , ghc-paths , ghcide , gitrev , hashable , haskell-lsp - , hie-bios >= 0.4 + , hie-bios , haskell-language-server , hslogger , optparse-applicative @@ -233,7 +218,9 @@ common hls-test-utils , lsp-test , stm , tasty-hunit + , temporary , text + , transformers , unordered-containers , yaml ghc-options: -Wall -Wredundant-constraints @@ -291,3 +278,18 @@ test-suite func-test -threaded -rtsopts -with-rtsopts=-N if flag(pedantic) ghc-options: -Werror -Wredundant-constraints + +test-suite wrapper-test + import: agpl, hls-test-utils + type: exitcode-stdio-1.0 + build-tool-depends: haskell-language-server:haskell-language-server-wrapper + default-language: Haskell2010 + build-depends: base == 4.* + , directory + , process + , tasty + , tasty-hunit + , tasty-ant-xml >= 1.1.6 + hs-source-dirs: test/wrapper + main-is: Main.hs + ghc-options: -Wall diff --git a/src/Ide/Cradle.hs b/src/Ide/Cradle.hs deleted file mode 100644 index a2d976d29e..0000000000 --- a/src/Ide/Cradle.hs +++ /dev/null @@ -1,913 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE GADTs #-} - -module Ide.Cradle where - -import Control.Exception -import Data.Foldable (toList) -import Data.Function ((&)) -import Data.List (isPrefixOf, sortOn, find) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map as Map -import Data.Maybe (listToMaybe, mapMaybe, isJust) -import Data.Ord (Down(..)) -import Data.String (IsString(..)) -import qualified Data.Text as T -import Distribution.Helper (Package, projectPackages, pUnits, - pSourceDir, ChComponentInfo(..), - unChModuleName, Ex(..), ProjLoc(..), - QueryEnv, mkQueryEnv, runQuery, - Unit, unitInfo, uiComponents, - ChEntrypoint(..), UnitInfo(..), - qePrograms, ghcProgram) -import Distribution.Helper.Discover (findProjects, getDefaultDistDir) -import Ide.Logger -import HIE.Bios as Bios -import qualified HIE.Bios.Cradle as Bios -import HIE.Bios.Types (CradleAction(..)) -import qualified HIE.Bios.Types as Bios -import System.Directory (getCurrentDirectory, canonicalizePath, findExecutable) -import System.Exit -import System.FilePath -import System.Process (readCreateProcessWithExitCode, shell, CreateProcess(..)) - - --- --------------------------------------------------------------------- - --- | Find the cradle that the given File belongs to. --- --- First looks for a "hie.yaml" file in the directory of the file --- or one of its parents. If this file is found, the cradle --- is read from the config. If this config does not comply to the "hie.yaml" --- specification, an error is raised. --- --- If no "hie.yaml" can be found, the implicit config is used. --- The implicit config uses different heuristics to determine the type --- of the project that may or may not be accurate. -findLocalCradle :: FilePath -> IO (Cradle CabalHelper) -findLocalCradle fp = do - cradleConf <- Bios.findCradle fp - crdl <- case cradleConf of - Just yaml -> do - debugm $ "Found \"" ++ yaml ++ "\" for \"" ++ fp ++ "\"" - crdl <- Bios.loadCradle yaml - return $ fmap (const CabalNone) crdl - Nothing -> cabalHelperCradle fp - logm $ "Module \"" ++ fp ++ "\" is loaded by Cradle: " ++ show crdl - return crdl - --- | Check if the given cradle is a stack cradle. --- This might be used to determine the GHC version to use on the project. --- If it is a stack-cradle, we have to use @"stack path --compiler-exe"@ --- otherwise we may ask `ghc` directly what version it is. -isStackCradle :: Cradle CabalHelper -> Bool -isStackCradle crdl = Bios.isStackCradle crdl || cabalHelperStackCradle crdl - where - cabalHelperStackCradle = - (`elem` [Bios.Other Stack, Bios.Other StackNone]) - . Bios.actionName - . Bios.cradleOptsProg - - --- | Check if the given cradle is a cabal cradle. --- This might be used to determine the GHC version to use on the project. --- If it is a stack-cradle, we have to use @"stack path --compiler-exe"@ --- otherwise we may ask @ghc@ directly what version it is. -isCabalCradle :: Cradle CabalHelper -> Bool -isCabalCradle crdl = Bios.isCabalCradle crdl || cabalHelperCabalCradle crdl - where - cabalHelperCabalCradle = - (`elem` [Bios.Other CabalV2, Bios.Other CabalNone]) - . Bios.actionName - . Bios.cradleOptsProg - -data CabalHelper - = Stack - | StackNone - | CabalV2 - | CabalNone - deriving (Show, Eq, Ord) - --- | Execute @ghc@ that is based on the given cradle. --- Output must be a single line. If an error is raised, e.g. the command --- failed, a 'Nothing' is returned. --- The exact error is written to logs. --- --- E.g. for a stack cradle, we use @stack ghc@ and for a cabal cradle --- we are taking the @ghc@ that is on the path. -execProjectGhc :: Cradle CabalHelper -> [String] -> IO (Maybe String) -execProjectGhc crdl args = do - isStackInstalled <- isJust <$> findExecutable "stack" - -- isCabalInstalled <- isJust <$> findExecutable "cabal" - ghcOutput <- if isStackCradle crdl && isStackInstalled - then do - logm $ "Executing Stack GHC with args: " <> unwords args - catch (Just <$> tryCommand crdl stackCmd) $ \(_ :: IOException) -> do - errorm $ "Command `" ++ stackCmd ++"` failed." - execWithGhc - -- The command `cabal v2-exec -v0 ghc` only works if the project has been - -- built already. - -- This command must work though before the project is build. - -- Therefore, fallback to "ghc" on the path. - -- - -- else if isCabalCradle crdl && isCabalInstalled then do - -- let cmd = "cabal v2-exec -v0 ghc -- " ++ unwords args - -- catch (Just <$> tryCommand crdl cmd) $ \(_ ::IOException) -> do - -- errorm $ "Command `" ++ cmd ++ "` failed." - -- return Nothing - else do - logm $ "Executing GHC on path with args: " <> unwords args - execWithGhc - debugm $ "GHC Output: \"" ++ show ghcOutput ++ "\"" - return ghcOutput - where - stackCmd = "stack ghc -- " ++ unwords args - plainCmd = "ghc " ++ unwords args - - execWithGhc = - catch (Just <$> tryCommand crdl plainCmd) $ \(_ :: IOException) -> do - errorm $ "Command `" ++ plainCmd ++"` failed." - return Nothing - -tryCommand :: Cradle CabalHelper -> String -> IO String -tryCommand crdl cmd = do - let p = (shell cmd) { cwd = Just (cradleRootDir crdl) } - (code, sout, serr) <- readCreateProcessWithExitCode p "" - case code of - ExitFailure e -> do - let errmsg = concat - [ "`" - , cmd - , "`: Exit failure: " - , show e - , ", stdout: " - , sout - , ", stderr: " - , serr - ] - errorm errmsg - throwIO $ userError errmsg - - ExitSuccess -> return $ T.unpack . T.strip . head . T.lines $ T.pack sout - - --- | Get the directory of the libdir based on the project ghc. -getProjectGhcLibDir :: Cradle CabalHelper -> IO (Maybe FilePath) -getProjectGhcLibDir crdl = - execProjectGhc crdl ["--print-libdir"] >>= \case - Nothing -> do - errorm "Could not obtain the libdir." - return Nothing - mlibdir -> return mlibdir - - -- --------------------------------------------------------------------- - - -{- | Finds a Cabal v2-project, Cabal v1-project or a Stack project -relative to the given FilePath. -Cabal v2-project and Stack have priority over Cabal v1-project. -This entails that if a Cabal v1-project can be identified, it is -first checked whether there are Stack projects or Cabal v2-projects -before it is concluded that this is the project root. -Cabal v2-projects and Stack projects are equally important. -Due to the lack of user-input we have to guess which project it -should rather be. -This guessing has no guarantees and may change at any time. - -=== Example: - -Assume the following project structure: - -@ - / - └── Foo/ - ├── Foo.cabal - ├── stack.yaml - ├── cabal.project - ├── src - │ └── Lib.hs - └── B/ - ├── B.cabal - └── src/ - └── Lib2.hs -@ - -Assume the call @findCabalHelperEntryPoint "\/Foo\/B\/src\/Lib2.hs"@. -We now want to know to which project "\/Foo\/B\/src\/Lib2.hs" belongs to -and what the projects root is. If we only do a naive search to find the -first occurrence of either "B.cabal", "stack.yaml", "cabal.project" -or "Foo.cabal", we might assume that the location of "B.cabal" marks -the project's root directory of which "\/Foo\/B\/src\/Lib2.hs" is part of. -However, there is also a "cabal.project" and "stack.yaml" in the parent -directory, which add the package @B@ as a package. -So, the compilation of the package @B@, and the file "src\/Lib2.hs" in it, -does not only depend on the definitions in "B.cabal", but also -on "stack.yaml" and "cabal.project". -The project root is therefore "\/Foo\/". -Only if there is no "stack.yaml" or "cabal.project" in any of the ancestor -directories, it is safe to assume that "B.cabal" marks the root of the project. - -Thus: - ->>> findCabalHelperEntryPoint "/Foo/B/src/Lib2.hs -Just (Ex (ProjLocStackYaml { plStackYaml = "/Foo/"})) - -or - ->>> findCabalHelperEntryPoint "/Foo/B/src/Lib2.hs" -Just (Ex (ProjLocV2File { plProjectDirV2 = "/Foo/"})) - -In the given example, it is not guaranteed which project type is found, -it is only guaranteed that it will not identify the project -as a cabal v1-project. Note that with cabal-helper version (1.0), -by default a *.cabal file is identified as a 'ProjLocV2Dir' project. -The same issue as before exists and we look for a 'ProjLocV2File' or -'ProjLocStackYaml' before deciding that 'ProjLocV2Dir' marks the project root. - -Note that this will not return any project types for which the corresponding -build tool is not on the PATH. This is "stack" and "cabal" for stack and cabal -(both v1 and v2) projects respectively. --} -findCabalHelperEntryPoint :: FilePath -> IO (Maybe (Ex ProjLoc)) -findCabalHelperEntryPoint fp = do - allProjs <- concat <$> mapM findProjects (ancestors (takeDirectory fp)) - - debugm $ "Cabal-Helper found these projects: " ++ show (map (\(Ex x) -> show x) allProjs) - - -- We only want to return projects that we have the build tools installed for - isStackInstalled <- isJust <$> findExecutable "stack" - isCabalInstalled <- isJust <$> findExecutable "cabal" - let supportedProjs = filter (\x -> supported x isStackInstalled isCabalInstalled) allProjs - debugm $ "These projects have the build tools installed: " ++ show (map (\(Ex x) -> show x) supportedProjs) - - case filter (\p -> isCabalV2FileProject p || isStackProject p) supportedProjs of - (x:_) -> return $ Just x - [] -> case filter isCabalProject supportedProjs of - (x:_) -> return $ Just x - [] -> return Nothing - where - supported :: Ex ProjLoc -> Bool -> Bool -> Bool - supported (Ex ProjLocStackYaml {}) stackInstalled _ = stackInstalled - supported (Ex ProjLocV2Dir {}) _ cabalInstalled = cabalInstalled - supported (Ex ProjLocV2File {}) _ cabalInstalled = cabalInstalled - supported (Ex ProjLocV1Dir {}) _ cabalInstalled = cabalInstalled - supported (Ex ProjLocV1CabalFile {}) _ cabalInstalled = cabalInstalled - -isStackProject :: Ex ProjLoc -> Bool -isStackProject (Ex ProjLocStackYaml {}) = True -isStackProject _ = False - -isCabalV2FileProject :: Ex ProjLoc -> Bool -isCabalV2FileProject (Ex ProjLocV2File {}) = True -isCabalV2FileProject _ = False - -isCabalProject :: Ex ProjLoc -> Bool -isCabalProject (Ex ProjLocV1CabalFile {}) = True -isCabalProject (Ex ProjLocV1Dir {}) = True -isCabalProject (Ex ProjLocV2File {}) = True -isCabalProject (Ex ProjLocV2Dir {}) = True -isCabalProject _ = False - -{- | Given a FilePath, find the cradle the FilePath belongs to. - -Finds the Cabal Package the FilePath is most likely a part of -and creates a cradle whose root directory is the directory -of the package the File belongs to. - -It is not required that the FilePath given actually exists. If it does not -exist or is not part of any of the packages in the project, a "None"-cradle is -produced. -See for what a "None"-cradle is. -The "None"-cradle can still be used to query for basic information, such as -the GHC version used to build the project. However, it can not be used to -load any of the files in the project. - -== General Approach - -Given a FilePath that we want to load, we need to create a cradle -that can compile and load the given FilePath. -In Cabal-Helper, there is no notion of a cradle, but a project -consists of multiple packages that contain multiple units. -Each unit may consist of multiple components. -A unit is the smallest part of code that Cabal (the library) can compile. -Examples are executables, libraries, tests or benchmarks are all units. -Each of this units has a name that is unique within a build-plan, -such as "exe:hie" which represents the executable of the Haskell IDE Engine. - -In principle, a unit is what hie-bios considers to be a cradle. -However, to find out to which unit a FilePath belongs, we have to initialise -the unit, e.g. configure its dependencies and so on. When discovering a cradle -we do not want to pay for this upfront, but rather when we actually want to -load a Module in the project. Therefore, we only identify the package the -FilePath is part of and decide which unit to load when 'runCradle' is executed. - -Thus, to find the options required to compile and load the given FilePath, -we have to do the following: - - 1. Identify the package that contains the FilePath (should be unique) - Happens in 'cabalHelperCradle' - 2. Find the unit that that contains the FilePath (May be non-unique) - Happens in 'cabalHelperAction' - 3. Find the component that exposes the FilePath (May be non-unique) - Happens in 'cabalHelperAction' - -=== Identify the package that contains the FilePath - -The function 'cabalHelperCradle' does the first step only. -It starts by querying Cabal-Helper to find the project's root. -See 'findCabalHelperEntryPoint' for details how this is done. -Once the root of the project is defined, we query Cabal-Helper for all packages -that are defined in the project and match by the packages source directory -which package the given FilePath is most likely to be a part of. -E.g. if the source directory of the package is the most concrete -prefix of the FilePath, the FilePath is in that package. -After the package is identified, we create a cradle where cradle's root -directory is set to the package's source directory. This is necessary, -because compiler options obtained from a component, are relative -to the source directory of the package the component is part of. - -=== Find the unit that that contains the FilePath - -In 'cabalHelperAction' we want to load a given FilePath, already knowing -which package the FilePath is part of. Now we obtain all Units that are part -of the package and match by the source directories (plural is intentional), -to which unit the given FilePath most likely belongs to. If no unit can be -obtained, e.g. for every unit, no source directory is a prefix of the FilePath, -we return an error code, since this is not allowed to happen. -If there are multiple matches, which is possible, we check whether any of the -components defined in the unit exposes or defines the given FilePath as a module. - -=== Find the component that exposes the FilePath - -A component defines the options that are necessary to compile a FilePath that -is in the component. It also defines which modules are in the component. -Therefore, we translate the given FilePath into a module name, relative to -the unit's source directory, and check if the module name is exposed by the -component. There is a special case, executables define a FilePath, for the -file that contains the 'main'-function, that is relative to the unit's source -directory. - -After the component has been identified, we can actually retrieve the options -required to load and compile the given file. - -== Examples - -=== Mono-Repo - -Assume the project structure: - -@ - / - └── Mono/ - ├── cabal.project - ├── stack.yaml - ├── A/ - │ ├── A.cabal - │ └── Lib.hs - └── B/ - ├── B.cabal - └── Exe.hs -@ - -Currently, Haskell IDE Engine needs to know on startup which GHC version is -needed to compile the project. This information is needed to show warnings to -the user if the GHC version on the project does not agree with the GHC version -that was used to compile Haskell IDE Engine. - -Therefore, the function 'findLocalCradle' is invoked with a dummy FilePath, -such as "\/Mono\/Lib.hs". Since there will be no package that contains this -dummy FilePath, the result will be a None-cradle. - -Either - ->>> findLocalCradle "/Mono/Lib.hs" -Cradle { cradleRootDir = "/Mono/", CradleAction { actionName = "Cabal-Helper-Stack-None", ..} } - -or - ->>> findLocalCradle "/Mono/Lib.hs" -Cradle { cradleRootDir = "/Mono/", CradleAction { actionName = "Cabal-Helper-Cabal-V2-None", ..} } - -The cradle result of this invocation is only used to obtain the GHC version, -which is safe, since it only checks if the cradle is a 'stack' project or -a 'cabal' project. - - -If we are trying to load the executable: - ->>> findLocalCradle "/Mono/B/Exe.hs" -Cradle { cradleRootDir = "/Mono/", CradleAction { actionName = "Cabal-Helper-Cabal-V2", ..} } - -we will detect correctly the compiler options, by first finding the appropriate -package, followed by traversing the units in the package and finding the -component that exposes the executable by FilePath. - -=== No explicit executable folder - -Assume the project structure: - -@ - / - └── Library/ - ├── cabal.project - ├── stack.yaml - ├── Library.cabal - └── src - ├── Lib.hs - └── Exe.hs -@ - -There are different dependencies for the library "Lib.hs" and the -executable "Exe.hs". If we are trying to load the executable "src\/Exe.hs" -we will correctly identify the executable unit, and correctly initialise -dependencies of "exe:Library". -It will be correct even if we load the unit "lib:Library" before -the "exe:Library" because the unit "lib:Library" does not expose -a module @"Exe"@. - -=== Sub package - -Assume the project structure: - -@ - / - └── Repo/ - ├── cabal.project - ├── stack.yaml - ├── Library.cabal - ├── src - | └── Lib.hs - └── SubRepo - ├── SubRepo.cabal - └── Lib2.hs -@ - -When we try to load "\/Repo\/SubRepo\/Lib2.hs", we need to identify root -of the project, which is "\/Repo\/" but set the root directory of the cradle -responsible to load "\/Repo\/SubRepo\/Lib2.hs" to "\/Repo\/SubRepo", since -the compiler options obtained from Cabal-Helper are relative to the package -source directory, which is "\/Repo\/SubRepo". - --} -cabalHelperCradle :: FilePath -> IO (Cradle CabalHelper) -cabalHelperCradle file = do - projM <- findCabalHelperEntryPoint file - case projM of - Nothing -> do - errorm $ "Could not find a Project for file: " ++ file - cwd <- getCurrentDirectory - return - Cradle { cradleRootDir = cwd - , cradleOptsProg = - CradleAction { actionName = Bios.Direct - , runCradle = \_ _ -> - return - $ CradleSuccess - ComponentOptions - { componentOptions = [file, fixImportDirs cwd "-i."] - , componentRoot = cwd - , componentDependencies = [] - } - , runGhcCmd = \args -> Bios.readProcessWithCwd cwd "ghc" args "" - } - } - Just (Ex proj) -> do - logm $ "Cabal-Helper decided to use: " ++ show proj - -- Find the root of the project based on project type. - let root = projectRootDir proj - -- Create a suffix for the cradle name. - -- Purpose is mainly for easier debugging. - let actionNameSuffix = projectType proj - debugm $ "Cabal-Helper dirs: " ++ show [root, file] - let dist_dir = getDefaultDistDir proj - env <- mkQueryEnv proj dist_dir - packages <- runQuery projectPackages env - -- Find the package the given file may belong to. - -- If it does not belong to any package, create a none-cradle. - -- We might want to find a cradle without actually loading anything. - -- Useful if we only want to determine a ghc version to use. - case packages `findPackageFor` file of - Nothing -> do - debugm $ "Could not find a package for the file: " ++ file - debugm - "This is perfectly fine if we only want to determine the GHC version." - return - Cradle { cradleRootDir = root - , cradleOptsProg = - CradleAction { actionName = Bios.Other (projectNoneType proj) - , runCradle = \_ _ -> return CradleNone - , runGhcCmd = \_ -> pure CradleNone - } - } - Just realPackage -> do - debugm $ "Cabal-Helper cradle package: " ++ show realPackage - -- Field `pSourceDir` often has the form `/./plugin` - -- but we only want `/plugin` - normalisedPackageLocation <- canonicalizePath $ pSourceDir realPackage - debugm - $ "Cabal-Helper normalisedPackageLocation: " - ++ normalisedPackageLocation - return - Cradle { cradleRootDir = normalisedPackageLocation - , cradleOptsProg = - CradleAction { actionName = Bios.Other actionNameSuffix - , runCradle = \_ fp -> cabalHelperAction - (Ex proj) - env - realPackage - normalisedPackageLocation - fp - , runGhcCmd = \args -> do - let programs = qePrograms env - Bios.readProcessWithCwd normalisedPackageLocation (ghcProgram programs) args "" - } - } - --- | Cradle Action to query for the ComponentOptions that are needed --- to load the given FilePath. --- This Function is not supposed to throw any exceptions and use --- 'CradleLoadResult' to indicate errors. -cabalHelperAction :: Ex ProjLoc -- ^ Project location, can be used - -- to present build-tool - -- agnostic error messages. - -> QueryEnv v -- ^ Query Env created by 'mkQueryEnv' - -- with the appropriate 'distdir' - -> Package v -- ^ Package this cradle is part for. - -> FilePath -- ^ Root directory of the cradle - -- this action belongs to. - -> FilePath -- ^ FilePath to load, expected to be an absolute path. - -> IO (CradleLoadResult ComponentOptions) -cabalHelperAction proj env package root fp = do - -- Get all unit infos the given FilePath may belong to - let units = pUnits package - -- make the FilePath to load relative to the root of the cradle. - let relativeFp = makeRelative root fp - debugm $ "Relative Module FilePath: " ++ relativeFp - getComponent proj env (toList units) relativeFp - >>= \case - Right comp -> do - let fs' = getFlags comp - let fs = map (fixImportDirs root) fs' - let targets = getTargets comp relativeFp - let ghcOptions = fs ++ targets - debugm $ "Flags for \"" ++ fp ++ "\": " ++ show ghcOptions - debugm $ "Component Infos: " ++ show comp - return - $ CradleSuccess - ComponentOptions { componentOptions = ghcOptions - , componentRoot = root - , componentDependencies = [] - } - Left err -> return - $ CradleFail - $ CradleError - [] - (ExitFailure 2) - err - --- | Fix occurrences of "-i." to "-i" --- Flags obtained from cabal-helper are relative to the package --- source directory. This is less resilient to using absolute paths, --- thus, we fix it here. -fixImportDirs :: FilePath -> String -> String -fixImportDirs base_dir arg = - if "-i" `isPrefixOf` arg - then let dir = drop 2 arg - -- the flag "-i" has special meaning. - in if not (null dir) && isRelative dir then ("-i" ++ base_dir dir) - else arg - else arg - - --- | Get the component the given FilePath most likely belongs to. --- Lazily ask units whether the given FilePath is part of one of their --- component's. --- If a Module belongs to multiple components, it is not specified which --- component will be loaded. --- The given FilePath must be relative to the Root of the project --- the given units belong to. -getComponent - :: forall pt. Ex ProjLoc -> QueryEnv pt -> [Unit pt] -> FilePath -> IO (Either [String] ChComponentInfo) -getComponent proj env unitCandidates fp = getComponent' [] [] unitCandidates >>= - \case - (tried, failed, Nothing) -> return (Left $ buildErrorMsg tried failed) - (_, _, Just comp) -> return (Right comp) - where - getComponent' :: [UnitInfo] -> [(Unit pt, IOException)] -> [Unit pt] -> IO ([UnitInfo], [(Unit pt, IOException)], Maybe ChComponentInfo) - getComponent' triedUnits failedUnits [] = return (triedUnits, failedUnits, Nothing) - getComponent' triedUnits failedUnits (unit : units) = - try (runQuery (unitInfo unit) env) >>= \case - Left (e :: IOException) -> do - warningm $ "Catching and swallowing an IOException: " ++ show e - warningm - $ "The Exception was thrown in the context of finding" - ++ " a component for \"" - ++ fp - ++ "\" in the unit: " - ++ show unit - getComponent' triedUnits ((unit, e):failedUnits) units - Right ui -> do - let components = Map.elems (uiComponents ui) - debugm $ "Unit Info: " ++ show ui - case find (fp `partOfComponent`) components of - Nothing -> getComponent' (ui:triedUnits) failedUnits units - comp -> return (triedUnits, failedUnits, comp) - - buildErrorMsg :: [UnitInfo] -> [(Unit pt, IOException)] -> [String] - buildErrorMsg triedUnits failedUnits = - concat - [ [ "Could not obtain flags for: \"" ++ fp ++ "\"." - , "" - ] - , concat - [ concat - [ [ "This module was not part of any component we are aware of." - , "" - ] - , concatMap ppShowUnitInfo triedUnits - , [ "" - , "" - ] - , if isStackProject proj - then stackSpecificInstructions - else cabalSpecificInstructions - ] - | not (null triedUnits) - ] - , concat - [ - [ "We could not build all components." - , "If one of these components exposes this Module, make sure they compile." - , "You can try to invoke the commands yourself." - , "The following commands failed:" - ] - ++ concatMap (ppShowIOException . snd) failedUnits - | not (null failedUnits) - ] - ] - - stackSpecificInstructions :: [String] - stackSpecificInstructions = - [ "To expose a module, refer to:" - , "https://docs.haskellstack.org/en/stable/GUIDE/" - , "If you are using `package.yaml` then you don't have to manually expose modules." - , "Maybe you didn't set the source directories for your project correctly." - ] - - cabalSpecificInstructions :: [String] - cabalSpecificInstructions = - [ "To expose a module, refer to:" - , "https://www.haskell.org/cabal/users-guide/developing-packages.html" - , "" - ] - - ppShowUnitInfo :: UnitInfo -> [String] - ppShowUnitInfo u = - u - & uiComponents - & Map.toList - & map - (\(name, info) -> - "Component: " ++ show name ++ " with source directory: " ++ show (ciSourceDirs info) - ) - - - ppShowIOException :: IOException -> [String] - ppShowIOException e = - [ "" - , show e - ] - --- | Check whether the given FilePath is part of the Component. --- A FilePath is part of the Component if and only if: --- --- * One Component's 'ciSourceDirs' is a prefix of the FilePath --- * The FilePath, after converted to a module name, --- is a in the Component's Targets, or the FilePath is --- the executable in the component. --- --- The latter is achieved by making the FilePath relative to the 'ciSourceDirs' --- and then replacing Path separators with ".". --- To check whether the given FilePath is the executable of the Component, --- we have to check whether the FilePath, including 'ciSourceDirs', --- is part of the targets in the Component. -partOfComponent :: - -- | FilePath relative to the package root. - FilePath -> - -- | Component to check whether the given FilePath is part of it. - ChComponentInfo -> - Bool -partOfComponent fp' comp = - inTargets (ciSourceDirs comp) fp' (getTargets comp fp') - where - -- Check if the FilePath is in an executable or setup's main-is field - inMainIs :: FilePath -> Bool - inMainIs fp - | ChExeEntrypoint mainIs _ <- ciEntrypoints comp = mainIs == fp - | ChSetupEntrypoint mainIs <- ciEntrypoints comp = mainIs == fp - | otherwise = False - - inTargets :: [FilePath] -> FilePath -> [String] -> Bool - inTargets sourceDirs fp targets = - let candidates = relativeTo fp sourceDirs - in any (existsInTargets targets fp) candidates - - existsInTargets :: [String] -> FilePath -> FilePath -> Bool - existsInTargets targets absFp relFp = or - [ any (`elem` targets) [getModuleName relFp, absFp] - , inMainIs relFp - ] - - getModuleName :: FilePath -> String - getModuleName fp = map - (\c -> if isPathSeparator c - then '.' - else c) - (dropExtension fp) - --- | Get the flags necessary to compile the given component. -getFlags :: ChComponentInfo -> [String] -getFlags = ciGhcOptions - --- | Get all Targets of a Component, since we want to load all components. --- FilePath is needed for the special case that the Component is an Exe. --- The Exe contains a Path to the Main which is relative to some entry --- in 'ciSourceDirs'. --- We monkey-patch this by supplying the FilePath we want to load, --- which is part of this component, and select the 'ciSourceDir' we actually want. --- See the Documentation of 'ciSourceDir' to why this contains multiple entries. -getTargets :: ChComponentInfo -> FilePath -> [String] -getTargets comp fp = case ciEntrypoints comp of - ChSetupEntrypoint {} -> [] - ChLibEntrypoint { chExposedModules, chOtherModules } - -> map unChModuleName (chExposedModules ++ chOtherModules) - ChExeEntrypoint { chMainIs, chOtherModules } - -> [sourceDir chMainIs | Just sourceDir <- [sourceDirs]] - ++ map unChModuleName chOtherModules - where - sourceDirs = find (`isFilePathPrefixOf` fp) (ciSourceDirs comp) - --- | For all packages in a project, find the project the given FilePath --- belongs to most likely. -findPackageFor :: NonEmpty (Package pt) -> FilePath -> Maybe (Package pt) -findPackageFor packages fp = packages - & NonEmpty.toList - & sortOn (Down . pSourceDir) - & filter (\p -> pSourceDir p `isFilePathPrefixOf` fp) - & listToMaybe - - -projectRootDir :: ProjLoc qt -> FilePath -projectRootDir ProjLocV1CabalFile { plProjectDirV1 } = plProjectDirV1 -projectRootDir ProjLocV1Dir { plProjectDirV1 } = plProjectDirV1 -projectRootDir ProjLocV2File { plProjectDirV2 } = plProjectDirV2 -projectRootDir ProjLocV2Dir { plProjectDirV2 } = plProjectDirV2 -projectRootDir ProjLocStackYaml { plStackYaml } = takeDirectory plStackYaml - -projectType :: ProjLoc qt -> CabalHelper -projectType ProjLocV1CabalFile {} = CabalV2 -projectType ProjLocV1Dir {} = CabalV2 -projectType ProjLocV2File {} = CabalV2 -projectType ProjLocV2Dir {} = CabalV2 -projectType ProjLocStackYaml {} = Stack - -projectNoneType :: ProjLoc qt -> CabalHelper -projectNoneType ProjLocV1CabalFile {} = CabalNone -projectNoneType ProjLocV1Dir {} = CabalNone -projectNoneType ProjLocV2File {} = CabalNone -projectNoneType ProjLocV2Dir {} = CabalNone -projectNoneType ProjLocStackYaml {} = StackNone - --- ---------------------------------------------------------------------------- --- --- Utility functions to manipulate FilePath's --- --- ---------------------------------------------------------------------------- - --- | Helper function to make sure that both FilePaths are normalised. --- Checks whether the first FilePath is a Prefix of the second FilePath. --- Intended usage: --- --- >>> isFilePathPrefixOf "./src/" "./src/File.hs" --- True --- --- >>> isFilePathPrefixOf "./src" "./src/File.hs" --- True --- --- >>> isFilePathPrefixOf "./src/././" "./src/File.hs" --- True --- --- >>> isFilePathPrefixOf "./src" "./src-dir/File.hs" --- False -isFilePathPrefixOf :: FilePath -> FilePath -> Bool -isFilePathPrefixOf dir fp = isJust $ stripFilePath dir fp - --- | Strip the given directory from the filepath if and only if --- the given directory is a prefix of the filepath. --- --- >>> stripFilePath "app" "app/File.hs" --- Just "File.hs" --- --- >>> stripFilePath "src" "app/File.hs" --- Nothing --- --- >>> stripFilePath "src" "src-dir/File.hs" --- Nothing --- --- >>> stripFilePath "." "src/File.hs" --- Just "src/File.hs" --- --- >>> stripFilePath "app/" "./app/Lib/File.hs" --- Just "Lib/File.hs" --- --- >>> stripFilePath "/app/" "./app/Lib/File.hs" --- Nothing -- Nothing since '/app/' is absolute --- --- >>> stripFilePath "/app" "/app/Lib/File.hs" --- Just "Lib/File.hs" -stripFilePath :: FilePath -> FilePath -> Maybe FilePath -stripFilePath "." fp - | isRelative fp = Just fp - | otherwise = Nothing -stripFilePath dir' fp' - | Just relativeFpParts <- splitDir `stripPrefix` splitFp = Just (joinPath relativeFpParts) - | otherwise = Nothing - where - dir = normalise dir' - fp = normalise fp' - splitFp = splitPath fp - splitDir = splitPath dir - stripPrefix (x:xs) (y:ys) - | x `equalFilePath` y = stripPrefix xs ys - | otherwise = Nothing - stripPrefix [] ys = Just ys - stripPrefix _ [] = Nothing - --- | Obtain all ancestors from a given directory. --- --- >>> ancestors "a/b/c/d/e" --- [ "a/b/c/d/e", "a/b/c/d", "a/b/c", "a/b", "a", "." ] --- --- >>> ancestors "/a/b/c/d/e" --- [ "/a/b/c/d/e", "/a/b/c/d", "/a/b/c", "/a/b", "/a", "/" ] --- --- >>> ancestors "/a/b.hs" --- [ "/a/b.hs", "/a", "/" ] --- --- >>> ancestors "a/b.hs" --- [ "a/b.hs", "a", "." ] --- --- >>> ancestors "a/b/" --- [ "a/b" ] -ancestors :: FilePath -> [FilePath] -ancestors dir - | subdir `equalFilePath` dir = [dir] - | otherwise = dir : ancestors subdir - where - subdir = takeDirectory dir - --- | Assuming a FilePath @"src\/Lib\/Lib.hs"@ and a list of directories --- such as @["src", "app"]@, returns the given FilePath --- with a matching directory stripped away. --- If there are multiple matches, e.g. multiple directories are a prefix --- of the given FilePath we return all matches. --- Returns an empty list if no prefix matches the given FilePath. --- --- >>> relativeTo "src/Lib/Lib.hs" ["src"] --- ["Lib/Lib.hs"] --- --- >>> relativeTo "src/Lib/Lib.hs" ["app"] --- [] --- --- >>> relativeTo "src/Lib/Lib.hs" ["src", "src/Lib"] --- ["Lib/Lib.hs", "Lib.hs"] -relativeTo :: FilePath -> [FilePath] -> [FilePath] -relativeTo file sourceDirs = - mapMaybe (`stripFilePath` file) sourceDirs - --- | Returns a user facing display name for the cradle type, --- e.g. "Stack project" or "GHC session" -cradleDisplay :: IsString a => Cradle CabalHelper -> a -cradleDisplay cradle = fromString result - where - result - | Bios.isStackCradle cradle - || name - `elem` [Bios.Other Stack, Bios.Other StackNone] - = "Stack project" - | Bios.isCabalCradle cradle - || name - `elem` [Bios.Other CabalV2, Bios.Other CabalNone] - = "Cabal project" - | Bios.isDirectCradle cradle - = "GHC session" - | Bios.isMultiCradle cradle - = "Multi Component project" - | otherwise - = "project" - name = Bios.actionName (Bios.cradleOptsProg cradle) - --- --------------------------------------------------------------------- diff --git a/src/Ide/Version.hs b/src/Ide/Version.hs index fe6908e973..fcb9f2376b 100644 --- a/src/Ide/Version.hs +++ b/src/Ide/Version.hs @@ -5,14 +5,9 @@ -- and the current project's version module Ide.Version where -import Data.Maybe import Development.GitRev (gitCommitCount) import Options.Applicative.Simple (simpleVersion) -import Ide.Cradle (execProjectGhc) -import qualified HIE.Bios.Types as Bios -import qualified Ide.Cradle as Bios import qualified Paths_haskell_language_server as Meta -import System.Directory import System.Info hlsVersion :: String @@ -27,25 +22,5 @@ hlsVersion = , [" ", arch] , [" ", hlsGhcDisplayVersion] ] - --- --------------------------------------------------------------------- - -hlsGhcDisplayVersion :: String -hlsGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc - -getProjectGhcVersion :: Bios.Cradle Bios.CabalHelper -> IO String -getProjectGhcVersion crdl = - fmap - (fromMaybe "No System GHC Found.") - (execProjectGhc crdl ["--numeric-version"]) - - -hlsGhcVersion :: String -hlsGhcVersion = VERSION_ghc - --- --------------------------------------------------------------------- - -checkCabalInstall :: IO Bool -checkCabalInstall = isJust <$> findExecutable "cabal" - --- --------------------------------------------------------------------- + where + hlsGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc diff --git a/stack-8.10.1.yaml b/stack-8.10.1.yaml index 73b0855aff..c28931ef18 100644 --- a/stack-8.10.1.yaml +++ b/stack-8.10.1.yaml @@ -6,10 +6,7 @@ packages: extra-deps: - Cabal-3.0.2.0 -# - cabal-helper-1.1.0.0 - hie-bios-0.6.1 -- github: DanielG/cabal-helper - commit: 79a5608778493bf32e74b54bbf1ea2729941e50f - cabal-plan-0.7.0.0 - clock-0.7.2 - floskell-0.10.3 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 2f673b24f8..56eb41a9ad 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -11,7 +11,6 @@ extra-deps: - bytestring-trie-0.2.5.0 - Cabal-3.0.2.0 - cabal-doctest-1.0.8 -- cabal-helper-1.1.0.0 - cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 - deque-0.4.3 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 2a6f9298e7..62db328d8c 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -10,7 +10,6 @@ extra-deps: - brittany-0.12.1.1@rev:2 - butcher-1.3.3.1 - Cabal-3.0.2.0 -- cabal-helper-1.1.0.0 - cabal-plan-0.6.2.0 - clock-0.7.2 - extra-1.7.3 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index af8599e938..ad95d9ea5b 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -9,7 +9,6 @@ extra-deps: - brittany-0.12.1.1 - butcher-1.3.3.2 - bytestring-trie-0.2.5.0 -- cabal-helper-1.1.0.0 - clock-0.7.2 - constrained-dynamic-0.1.0.0 - extra-1.7.3 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index de106549a8..bba9679ccc 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -7,7 +7,6 @@ packages: extra-deps: - apply-refact-0.7.0.0 - bytestring-trie-0.2.5.0 -- cabal-helper-1.1.0.0 - cabal-plan-0.6.2.0 - clock-0.7.2 - constrained-dynamic-0.1.0.0 diff --git a/stack.yaml b/stack.yaml index 88eb9f5d82..1ff400f465 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,7 +10,6 @@ extra-deps: - brittany-0.12.1.1@rev:2 - butcher-1.3.3.1 - Cabal-3.0.2.0 -- cabal-helper-1.1.0.0 - cabal-plan-0.6.2.0 - clock-0.7.2 - extra-1.7.3 diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs index 65b024167e..c6b14a6ea1 100644 --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -14,6 +14,8 @@ module Test.Hls.Util , noLogConfig , setupBuildToolFiles , withFileLogging + , findExe + , withCurrentDirectoryInTmp -- , makeRequest -- , runIGM -- , runIGM' @@ -25,8 +27,10 @@ module Test.Hls.Util ) where +import Control.Applicative -- import Control.Concurrent.STM import Control.Monad +import Control.Monad.Trans.Maybe import Data.Default import Data.List (intercalate) -- import Data.Typeable @@ -43,6 +47,7 @@ import System.Directory import System.Environment import System.FilePath import qualified System.Log.Logger as L +import System.IO.Temp -- import Test.Hspec import Test.Hspec.Runner import Test.Hspec.Core.Formatters @@ -309,4 +314,53 @@ dummyLspFuncs = LspFuncs { clientCapabilities = def , getWorkspaceFolders = return Nothing , withProgress = \_ _ f -> f (const (return ())) , withIndefiniteProgress = \_ _ f -> f - } \ No newline at end of file + } + +findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath) +findExeRecursive exe dir = do + me <- listToMaybe <$> findExecutablesInDirectories [dir] exe + case me of + Just e -> return (Just e) + Nothing -> do + subdirs <- (fmap (dir )) <$> listDirectory dir >>= filterM doesDirectoryExist + foldM (\acc subdir -> case acc of + Just y -> pure $ Just y + Nothing -> findExeRecursive exe subdir) + Nothing + subdirs + +-- | So we can find an executable with cabal run +-- since it doesnt put build tools on the path (only cabal test) +findExe :: String -> IO FilePath +findExe name = do + fp <- fmap fromJust $ runMaybeT $ + MaybeT (findExecutable name) <|> + MaybeT (findExeRecursive name "dist-newstyle") + makeAbsolute fp + +-- | Like 'withCurrentDirectory', but will copy the directory over to the system +-- temporary directory first to avoid haskell-language-server's source tree from +-- interfering with the cradle +withCurrentDirectoryInTmp :: FilePath -> IO a -> IO a +withCurrentDirectoryInTmp dir f = + withTempCopy dir $ \newDir -> + withCurrentDirectory newDir f + +withTempCopy :: FilePath -> (FilePath -> IO a) -> IO a +withTempCopy srcDir f = do + withSystemTempDirectory "hls-test" $ \newDir -> do + copyDir srcDir newDir + f newDir + +copyDir :: FilePath -> FilePath -> IO () +copyDir src dst = do + cnts <- listDirectory src + forM_ cnts $ \file -> do + unless (file `elem` ignored) $ do + let srcFp = src file + dstFp = dst file + isDir <- doesDirectoryExist srcFp + if isDir + then createDirectory dstFp >> copyDir srcFp dstFp + else copyFile srcFp dstFp + where ignored = ["dist", "dist-newstyle", ".stack-work"] diff --git a/test/wrapper/Main.hs b/test/wrapper/Main.hs new file mode 100644 index 0000000000..6f2795a579 --- /dev/null +++ b/test/wrapper/Main.hs @@ -0,0 +1,33 @@ +import Data.List +import Data.Char +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit +import System.Process + +main :: IO () +main = do + flushStackEnvironment + defaultMain $ + testGroup "haskell-language-server-wrapper" [projectGhcVersionTests] + +projectGhcVersionTests :: TestTree +projectGhcVersionTests = testGroup "--project-ghc-version" + [ testCase "stack with ghc 8.10.1" $ + testDir "test/wrapper/testdata/stack-8.10.1" "8.10.1" + , testCase "stack with ghc 8.8.3" $ + testDir "test/wrapper/testdata/stack-8.8.3" "8.8.3" + , testCase "cabal with global ghc" $ do + ghcVer <- trim <$> readProcess "ghc" ["--numeric-version"] "" + testDir "test/wrapper/testdata/cabal-cur-ver" ghcVer + ] + +testDir :: FilePath -> String -> Assertion +testDir dir expectedVer = do + wrapper <- findExe "haskell-language-server-wrapper" + withCurrentDirectoryInTmp dir $ do + actualVer <- trim <$> readProcess wrapper ["--project-ghc-version"] "" + actualVer @?= expectedVer + +trim :: String -> String +trim = dropWhileEnd isSpace diff --git a/test/wrapper/testdata/cabal-cur-ver/Lib.hs b/test/wrapper/testdata/cabal-cur-ver/Lib.hs new file mode 100644 index 0000000000..30bf1ec6b8 --- /dev/null +++ b/test/wrapper/testdata/cabal-cur-ver/Lib.hs @@ -0,0 +1,2 @@ +module Lib where +foo = 42 diff --git a/test/wrapper/testdata/cabal-cur-ver/cabal-cur-ver.cabal b/test/wrapper/testdata/cabal-cur-ver/cabal-cur-ver.cabal new file mode 100644 index 0000000000..a64735e4d4 --- /dev/null +++ b/test/wrapper/testdata/cabal-cur-ver/cabal-cur-ver.cabal @@ -0,0 +1,7 @@ +cabal-version: 2.4 +name: cabal-cur-ver +version: 0.1.0.0 +library + exposed-modules: Lib + build-depends: base + default-language: Haskell2010 diff --git a/test/wrapper/testdata/cabal-cur-ver/cabal.project b/test/wrapper/testdata/cabal-cur-ver/cabal.project new file mode 100644 index 0000000000..e6fdbadb43 --- /dev/null +++ b/test/wrapper/testdata/cabal-cur-ver/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/test/wrapper/testdata/stack-8.10.1/Lib.hs b/test/wrapper/testdata/stack-8.10.1/Lib.hs new file mode 100644 index 0000000000..30bf1ec6b8 --- /dev/null +++ b/test/wrapper/testdata/stack-8.10.1/Lib.hs @@ -0,0 +1,2 @@ +module Lib where +foo = 42 diff --git a/test/wrapper/testdata/stack-8.10.1/foo.cabal b/test/wrapper/testdata/stack-8.10.1/foo.cabal new file mode 100644 index 0000000000..affc654cad --- /dev/null +++ b/test/wrapper/testdata/stack-8.10.1/foo.cabal @@ -0,0 +1,7 @@ +cabal-version: 2.4 +name: foo +version: 0.1.0.0 +library + exposed-modules: Lib + build-depends: base + default-language: Haskell2010 diff --git a/test/wrapper/testdata/stack-8.10.1/stack.yaml b/test/wrapper/testdata/stack-8.10.1/stack.yaml new file mode 100644 index 0000000000..409e7fe489 --- /dev/null +++ b/test/wrapper/testdata/stack-8.10.1/stack.yaml @@ -0,0 +1 @@ +resolver: ghc-8.10.1 diff --git a/test/wrapper/testdata/stack-8.8.3/Lib.hs b/test/wrapper/testdata/stack-8.8.3/Lib.hs new file mode 100644 index 0000000000..30bf1ec6b8 --- /dev/null +++ b/test/wrapper/testdata/stack-8.8.3/Lib.hs @@ -0,0 +1,2 @@ +module Lib where +foo = 42 diff --git a/test/wrapper/testdata/stack-8.8.3/foo.cabal b/test/wrapper/testdata/stack-8.8.3/foo.cabal new file mode 100644 index 0000000000..affc654cad --- /dev/null +++ b/test/wrapper/testdata/stack-8.8.3/foo.cabal @@ -0,0 +1,7 @@ +cabal-version: 2.4 +name: foo +version: 0.1.0.0 +library + exposed-modules: Lib + build-depends: base + default-language: Haskell2010 diff --git a/test/wrapper/testdata/stack-8.8.3/stack.yaml b/test/wrapper/testdata/stack-8.8.3/stack.yaml new file mode 100644 index 0000000000..fc8cd8cd8f --- /dev/null +++ b/test/wrapper/testdata/stack-8.8.3/stack.yaml @@ -0,0 +1 @@ +resolver: ghc-8.8.3