diff --git a/.circleci/config.yml b/.circleci/config.yml index 0858f26e8..ce13f428c 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -26,9 +26,9 @@ defaults: &defaults - stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "stack-build.txt" }} - stack-cache-{{ .Environment.HIE_CACHE }}-{{ arch }}-{{ .Environment.CIRCLE_JOB }}-{{ checksum "resolver.txt" }} - # - run: - # name: Stack upgrade - # command: stack upgrade + - run: + name: Stack upgrade + command: stack upgrade - run: name: Stack setup diff --git a/.gitmodules b/.gitmodules index c96b580fc..86958d620 100644 --- a/.gitmodules +++ b/.gitmodules @@ -12,22 +12,16 @@ [submodule "submodules/HaRe"] path = submodules/HaRe - # url = https://github.com/bubba/HaRe.git url = https://github.com/wz1000/HaRe.git [submodule "submodules/cabal-helper"] path = submodules/cabal-helper - # url = https://github.com/arbor/cabal-helper.git - url = https://github.com/alanz/cabal-helper.git - # url = https://github.com/DanielG/cabal-helper.git + url = https://github.com/DanielG/cabal-helper.git [submodule "submodules/ghc-mod"] path = submodules/ghc-mod - # url = https://github.com/arbor/ghc-mod.git - url = https://github.com/alanz/ghc-mod.git - #url = https://github.com/mpickering/ghc-mod.git + url = https://github.com/fendor/ghc-mod.git [submodule "hie-bios"] path = hie-bios url = https://github.com/mpickering/hie-bios.git - branch = multi-cradle diff --git a/app/MainHie.hs b/app/MainHie.hs index a9c2c84af..9375f92eb 100644 --- a/app/MainHie.hs +++ b/app/MainHie.hs @@ -28,7 +28,6 @@ import System.IO import Haskell.Ide.Engine.Plugin.ApplyRefact import Haskell.Ide.Engine.Plugin.Base import Haskell.Ide.Engine.Plugin.Brittany -import Haskell.Ide.Engine.Plugin.Build import Haskell.Ide.Engine.Plugin.Example2 import Haskell.Ide.Engine.Plugin.Bios import Haskell.Ide.Engine.Plugin.HaRe @@ -55,7 +54,6 @@ plugins includeExamples = pluginDescToIdePlugins allPlugins [ applyRefactDescriptor "applyrefact" , baseDescriptor "base" , brittanyDescriptor "brittany" - , buildPluginDescriptor "build" , haddockDescriptor "haddock" , hareDescriptor "hare" , hoogleDescriptor "hoogle" diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 162f4913e..1dd3ea349 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -27,7 +27,6 @@ library Haskell.Ide.Engine.Options Haskell.Ide.Engine.Plugin.ApplyRefact Haskell.Ide.Engine.Plugin.Brittany - Haskell.Ide.Engine.Plugin.Build Haskell.Ide.Engine.Plugin.Example2 Haskell.Ide.Engine.Plugin.Floskell Haskell.Ide.Engine.Plugin.Bios @@ -58,7 +57,7 @@ library , brittany , bytestring , Cabal - , cabal-helper >= 0.8.0.4 + , cabal-helper >= 1.0 && < 1.1 , containers , data-default , directory diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 09406ed2e..8b693c725 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -1,6 +1,32 @@ -module Haskell.Ide.Engine.Cradle (findLocalCradle) where +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} -import HIE.Bios as BIOS +module Haskell.Ide.Engine.Cradle where + +import HIE.Bios as BIOS +import HIE.Bios.Types as BIOS +import Haskell.Ide.Engine.MonadFunctions +import Distribution.Helper (Package, projectPackages, pUnits, + pSourceDir, ChComponentInfo(..), + unChModuleName, Ex(..), ProjLoc(..), + QueryEnv, mkQueryEnv, runQuery, + Unit, unitInfo, uiComponents, + ChEntrypoint(..)) +import Distribution.Helper.Discover (findProjects, getDefaultDistDir) +import Data.Function ((&)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty) +import qualified Data.Map as M +import Data.List (sortOn, find) +import Data.Maybe (listToMaybe, mapMaybe, isJust) +import Data.Ord (Down(..)) +import Data.Foldable (toList) +import Control.Exception (IOException, try) +import System.FilePath +import System.Directory (getCurrentDirectory, canonicalizePath) +import System.Exit -- | Find the cradle that the given File belongs to. -- @@ -14,8 +40,600 @@ import HIE.Bios as BIOS -- of the project that may or may not be accurate. findLocalCradle :: FilePath -> IO Cradle findLocalCradle fp = do - -- Get the cabal directory from the cradle cradleConf <- BIOS.findCradle fp case cradleConf of - Just yaml -> BIOS.loadCradle yaml - Nothing -> BIOS.loadImplicitCradle fp \ No newline at end of file + Just yaml -> fixCradle <$> BIOS.loadCradle yaml + Nothing -> cabalHelperCradle fp + +-- | 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 -> Bool +isStackCradle = (`elem` ["stack", "Cabal-Helper-Stack", "Cabal-Helper-Stack-None"]) + . BIOS.actionName + . BIOS.cradleOptsProg + +{- | 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. +-} +findCabalHelperEntryPoint :: FilePath -> IO (Maybe (Ex ProjLoc)) +findCabalHelperEntryPoint fp = do + projs <- concat <$> mapM findProjects (ancestors (takeDirectory fp)) + case filter (\p -> isCabalNewProject p || isStackProject p) projs of + (x:_) -> return $ Just x + [] -> case filter isCabalOldProject projs of + (x:_) -> return $ Just x + [] -> return Nothing + where + isStackProject (Ex ProjLocStackYaml {}) = True + isStackProject _ = False + + isCabalNewProject (Ex ProjLocV2Dir {}) = True + isCabalNewProject (Ex ProjLocV2File {}) = True + isCabalNewProject _ = False + + isCabalOldProject (Ex ProjLocV1Dir {}) = True + isCabalOldProject (Ex ProjLocV1CabalFile {}) = True + isCabalOldProject _ = 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/B/", 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 +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 = "Cabal-Helper-None" + , runCradle = \_ -> return CradleNone + } + } + Just (Ex proj) -> do + -- 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 = projectSuffix proj + logm $ "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 = "Cabal-Helper-" + ++ actionNameSuffix + ++ "-None" + , runCradle = \_ -> return 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 = + "Cabal-Helper-" ++ actionNameSuffix + , runCradle = cabalHelperAction + env + realPackage + normalisedPackageLocation + } + } + where + -- | 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 :: 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 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 env (toList units) relativeFp + >>= \case + Just comp -> do + let fs = getFlags comp + 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 + , componentDependencies = [] + } + Nothing -> return + $ CradleFail + $ CradleError + (ExitFailure 2) + ("Could not obtain flags for " ++ fp) + +-- | 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 + :: QueryEnv pt -> [Unit pt] -> FilePath -> IO (Maybe ChComponentInfo) +getComponent _env [] _fp = return Nothing +getComponent env (unit : units) fp = + 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 env units fp + Right ui -> do + let components = M.elems (uiComponents ui) + debugm $ "Unit Info: " ++ show ui + case find (fp `partOfComponent`) components of + Nothing -> getComponent env units fp + comp -> return comp + +-- | 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') + = True + | otherwise + = False + where + inTargets :: [FilePath] -> FilePath -> [String] -> Bool + inTargets sourceDirs fp targets + | Just relative <- relativeTo fp sourceDirs + = any (`elem` targets) [getModuleName relative, fp] + | otherwise + = False + + 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 + +projectSuffix :: ProjLoc qt -> FilePath +projectSuffix ProjLocV1CabalFile {} = "Cabal-V1" +projectSuffix ProjLocV1Dir {} = "Cabal-V1-Dir" +projectSuffix ProjLocV2File {} = "Cabal-V2" +projectSuffix ProjLocV2Dir {} = "Cabal-V2-Dir" +projectSuffix ProjLocStackYaml {} = "Stack" + +-- | The hie-bios stack cradle doesn't return the target as well, so add the +-- FilePath onto the end of the options to make sure at least one target +-- is returned. +fixCradle :: BIOS.Cradle -> BIOS.Cradle +fixCradle cradle = + -- Normally this would also succeed for the 'Cabal-Helper-Stack' cradle. + -- Make sure that the cradle is definitely the one created by "HIE.Bios.Cradle.loadCradle" + if isStackCradle cradle + then + -- We need a lens + cradle { BIOS.cradleOptsProg = + (BIOS.cradleOptsProg + cradle) { BIOS.runCradle = \fp' -> fmap (addOption fp') + <$> BIOS.runCradle + (BIOS.cradleOptsProg cradle) + fp' + } + } + else cradle + where + addOption fp (BIOS.ComponentOptions os ds) = + BIOS.ComponentOptions (os ++ [fp]) ds + +-- ---------------------------------------------------------------------------- +-- +-- 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 either 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, return the first match in the list. +-- Returns Nothing, if not a single +-- given directory is a prefix of the FilePath. +-- +-- >>> relativeTo "src/Lib/Lib.hs" ["src"] +-- Just "Lib/Lib.hs" +-- +-- >>> relativeTo "src/Lib/Lib.hs" ["app"] +-- Nothing +-- +-- >>> relativeTo "src/Lib/Lib.hs" ["src", "src/Lib"] +-- Just "Lib/Lib.hs" +relativeTo :: FilePath -> [FilePath] -> Maybe FilePath +relativeTo file sourceDirs = listToMaybe + $ mapMaybe (`stripFilePath` file) sourceDirs diff --git a/hie-plugin-api/Haskell/Ide/Engine/GhcModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/GhcModuleCache.hs index 70b484166..d10453038 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/GhcModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/GhcModuleCache.hs @@ -102,7 +102,7 @@ lookupCradle :: FilePath -> GhcModuleCache -> LookupCradleResult lookupCradle fp gmc = case currentCradle gmc of Just (dirs, _c) | (any (\d -> d `isPrefixOf` fp) dirs) -> ReuseCradle - _ -> case T.match (cradleCache gmc) (B.pack fp) of + _ -> case T.match (cradleCache gmc) (B.pack fp) of Just (_k, c, _suf) -> LoadCradle c Nothing -> NewCradle fp diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index 5b99802ee..eaa5fa55e 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs @@ -111,7 +111,7 @@ loadCradle _ ReuseCradle = do loadCradle _iniDynFlags (LoadCradle (CachedCradle crd env)) = do -- Reloading a cradle happens on component switch - logm $ "Reload Cradle: " ++ show crd + logm $ "Switch to cradle: " ++ show crd -- Cache the existing cradle maybe (return ()) cacheCradle =<< (currentCradle <$> getModuleCache) GHC.setSession env @@ -132,15 +132,12 @@ loadCradle iniDynFlags (NewCradle fp) = do withProgress "Initialising Cradle" NotCancellable (initialiseCradle cradle) where - isStackCradle :: BIOS.Cradle -> Bool - isStackCradle c = BIOS.actionName (BIOS.cradleOptsProg c) == "stack" - -- | Initialise the given cradle. This might fail and return an error via `IdeResultFail`. -- Reports its progress to the client. initialiseCradle :: (MonadIde m, HasGhcModuleCache m, GHC.GhcMonad m, MonadBaseControl IO m) => BIOS.Cradle -> (Progress -> IO ()) -> m (IdeResult ()) initialiseCradle cradle f = do - res <- BIOS.initializeFlagsWithCradleWithMessage (Just (toMessager f)) fp (fixCradle cradle) + res <- BIOS.initializeFlagsWithCradleWithMessage (Just (toMessager f)) fp cradle case res of BIOS.CradleNone -> return (IdeResultOk ()) BIOS.CradleFail err -> do @@ -173,19 +170,6 @@ loadCradle iniDynFlags (NewCradle fp) = do Right () -> IdeResultOk <$> setCurrentCradle cradle - -- The stack cradle doesn't return the target as well, so add the - -- FilePath onto the end of the options to make sure at least one target - -- is returned. - fixCradle :: BIOS.Cradle -> BIOS.Cradle - fixCradle cradle = do - if isStackCradle cradle - -- We need a lens - then cradle { BIOS.cradleOptsProg = (BIOS.cradleOptsProg cradle) - { BIOS.runCradle = \fp' -> fmap addOption <$> BIOS.runCradle (BIOS.cradleOptsProg cradle) fp' } } - else cradle - where - addOption (BIOS.ComponentOptions os ds) = BIOS.ComponentOptions (os ++ [fp]) ds - -- | Sets the current cradle for caching. -- Retrieves the current GHC Module Graph, to find all modules -- that belong to this cradle. diff --git a/hie-plugin-api/hie-plugin-api.cabal b/hie-plugin-api/hie-plugin-api.cabal index cb3e0ae3a..adbe689e9 100644 --- a/hie-plugin-api/hie-plugin-api.cabal +++ b/hie-plugin-api/hie-plugin-api.cabal @@ -51,6 +51,7 @@ library , ghc , hie-bios , ghc-project-types >= 5.9.0.0 + , cabal-helper , haskell-lsp == 0.17.* , hslogger , unliftio diff --git a/src/Haskell/Ide/Engine/Plugin/Base.hs b/src/Haskell/Ide/Engine/Plugin/Base.hs index 607d20dcc..3a0053ecc 100644 --- a/src/Haskell/Ide/Engine/Plugin/Base.hs +++ b/src/Haskell/Ide/Engine/Plugin/Base.hs @@ -20,6 +20,7 @@ import Development.GitRev (gitCommitCount) import Distribution.System (buildArch) import Distribution.Text (display) import Haskell.Ide.Engine.MonadTypes +import Haskell.Ide.Engine.Cradle (isStackCradle) import qualified HIE.Bios.Types as BIOS import Options.Applicative.Simple (simpleVersion) import qualified Paths_haskell_ide_engine as Meta @@ -108,9 +109,8 @@ hieGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc getProjectGhcVersion :: BIOS.Cradle -> IO String getProjectGhcVersion crdl = do - isStackProject <- doesFileExist "stack.yaml" isStackInstalled <- isJust <$> findExecutable "stack" - if BIOS.actionName (BIOS.cradleOptsProg crdl) == "stack" && isStackProject && isStackInstalled + if isStackCradle crdl && isStackInstalled then do L.infoM "hie" "Using stack GHC version" catch (tryCommand "stack ghc -- --numeric-version") $ \e -> do diff --git a/src/Haskell/Ide/Engine/Plugin/Build.hs b/src/Haskell/Ide/Engine/Plugin/Build.hs index 724bc7738..e69de29bb 100644 --- a/src/Haskell/Ide/Engine/Plugin/Build.hs +++ b/src/Haskell/Ide/Engine/Plugin/Build.hs @@ -1,538 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} -module Haskell.Ide.Engine.Plugin.Build where - -#ifdef MIN_VERSION_Cabal -#undef CH_MIN_VERSION_Cabal -#define CH_MIN_VERSION_Cabal MIN_VERSION_Cabal -#endif - -import qualified Data.Aeson as J -#if __GLASGOW_HASKELL__ < 802 -import qualified Data.Aeson.Types as J -#endif -import Data.Maybe (fromMaybe) -#if __GLASGOW_HASKELL__ < 804 -import Data.Monoid -#endif -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import qualified Data.ByteString as B -import qualified Data.Text as T -import GHC.Generics (Generic) -import Haskell.Ide.Engine.MonadTypes -import Haskell.Ide.Engine.PluginUtils -import System.Directory (doesFileExist, - getCurrentDirectory, - getDirectoryContents, - makeAbsolute) -import System.FilePath (makeRelative, - normalise, - takeExtension, - takeFileName, ()) -import System.IO (IOMode (..), withFile) -import System.Process (readProcess) - -import Distribution.Helper as CH - -import Distribution.Package (pkgName, unPackageName) -import Distribution.PackageDescription -import Distribution.Simple.Configure (localBuildInfoFile) -import Distribution.Simple.Setup (defaultDistPref) -#if CH_MIN_VERSION_Cabal(2,2,0) -import Distribution.PackageDescription.Parsec (readGenericPackageDescription) -#elif CH_MIN_VERSION_Cabal(2,0,0) -import Distribution.PackageDescription.Parse (readGenericPackageDescription) -#else -import Distribution.PackageDescription.Parse (readPackageDescription) -#endif -import qualified Distribution.Verbosity as Verb - -import Data.Yaml - --- --------------------------------------------------------------------- -{- -buildModeArg = SParamDesc (Proxy :: Proxy "mode") (Proxy :: Proxy "Operation mode: \"stack\" or \"cabal\"") SPtText SRequired -distDirArg = SParamDesc (Proxy :: Proxy "distDir") (Proxy :: Proxy "Directory to search for setup-config file") SPtFile SOptional -toolArgs = SParamDesc (Proxy :: Proxy "cabalExe") (Proxy :: Proxy "Cabal executable") SPtText SOptional - :& SParamDesc (Proxy :: Proxy "stackExe") (Proxy :: Proxy "Stack executable") SPtText SOptional - :& RNil - -pluginCommonArgs = buildModeArg :& distDirArg :& toolArgs - - -buildPluginDescriptor :: TaggedPluginDescriptor _ -buildPluginDescriptor = PluginDescriptor - { - pdUIShortName = "Build plugin" - , pdUIOverview = "A HIE plugin for building cabal/stack packages" - , pdCommands = - buildCommand prepareHelper (Proxy :: Proxy "prepare") - "Prepares helper executable. The project must be configured first" - [] (SCtxNone :& RNil) - ( pluginCommonArgs - <+> RNil) SaveNone --- :& buildCommand isHelperPrepared (Proxy :: Proxy "isPrepared") --- "Checks whether cabal-helper is prepared to work with this project. The project must be configured first" --- [] (SCtxNone :& RNil) --- ( pluginCommonArgs --- <+> RNil) SaveNone - :& buildCommand isConfigured (Proxy :: Proxy "isConfigured") - "Checks if project is configured" - [] (SCtxNone :& RNil) - ( buildModeArg - :& distDirArg - :& RNil) SaveNone - :& buildCommand configure (Proxy :: Proxy "configure") - "Configures the project. For stack project with multiple local packages - build it" - [] (SCtxNone :& RNil) - ( pluginCommonArgs - <+> RNil) SaveNone - :& buildCommand listTargets (Proxy :: Proxy "listTargets") - "Given a directory with stack/cabal project lists all its targets" - [] (SCtxNone :& RNil) - ( pluginCommonArgs - <+> RNil) SaveNone - :& buildCommand listFlags (Proxy :: Proxy "listFlags") - "Lists all flags that can be set when configuring a package" - [] (SCtxNone :& RNil) - ( buildModeArg - :& RNil) SaveNone - :& buildCommand buildDirectory (Proxy :: Proxy "buildDirectory") - "Builds all targets that correspond to the specified directory" - [] (SCtxNone :& RNil) - ( pluginCommonArgs - <+> (SParamDesc (Proxy :: Proxy "directory") (Proxy :: Proxy "Directory to build targets from") SPtFile SOptional :& RNil) - <+> RNil) SaveNone - :& buildCommand buildTarget (Proxy :: Proxy "buildTarget") - "Builds specified cabal or stack component" - [] (SCtxNone :& RNil) - ( pluginCommonArgs - <+> (SParamDesc (Proxy :: Proxy "target") (Proxy :: Proxy "Component to build") SPtText SOptional :& RNil) - <+> (SParamDesc (Proxy :: Proxy "package") (Proxy :: Proxy "Package to search the component in. Only applicable for Stack mode") SPtText SOptional :& RNil) - <+> (SParamDesc (Proxy :: Proxy "type") (Proxy :: Proxy "Type of the component. Only applicable for Stack mode") SPtText SOptional :& RNil) - <+> RNil) SaveNone - :& RNil - , pdExposedServices = [] - , pdUsedServices = [] - } --} - -buildPluginDescriptor :: PluginId -> PluginDescriptor -buildPluginDescriptor plId = PluginDescriptor - { pluginId = plId - , pluginName = "Build plugin" - , pluginDesc = "A HIE plugin for building cabal/stack packages" - , pluginCommands = - [ PluginCommand "prepare" - "Prepares helper executable. The project must be configured first" - prepareHelper - -- , PluginCommand "isPrepared" - -- ("Checks whether cabal-helper is prepared to work with this project. " - -- <> "The project must be configured first") - -- isHelperPrepared - , PluginCommand "isConfigured" - "Checks if project is configured" - isConfigured - , PluginCommand "configure" - ("Configures the project. " - <> "For stack project with multiple local packages - build it") - configure - , PluginCommand "listTargets" - "Given a directory with stack/cabal project lists all its targets" - listTargets - , PluginCommand "listFlags" - "Lists all flags that can be set when configuring a package" - listFlags - , PluginCommand "buildDirectory" - "Builds all targets that correspond to the specified directory" - buildDirectory - , PluginCommand "buildTarget" - "Builds specified cabal or stack component" - buildTarget - ] - , pluginCodeActionProvider = Nothing - , pluginDiagnosticProvider = Nothing - , pluginHoverProvider = Nothing - , pluginSymbolProvider = Nothing - , pluginFormattingProvider = Nothing - } - -data OperationMode = StackMode | CabalMode - -readMode :: T.Text -> Maybe OperationMode -readMode "stack" = Just StackMode -readMode "cabal" = Just CabalMode -readMode _ = Nothing - --- | Used internally by commands, all fields always populated, possibly with --- default values -data CommonArgs = CommonArgs { - caMode :: OperationMode - ,caDistDir :: String - ,caCabal :: String - ,caStack :: String - } - --- | Used to interface with the transport, where the mode is required but rest --- are optional -data CommonParams = CommonParams { - cpMode :: T.Text - ,cpDistDir :: Maybe String - ,cpCabal :: Maybe String - ,cpStack :: Maybe String - ,cpFile :: Uri - } deriving Generic - -instance FromJSON CommonParams where - parseJSON = J.genericParseJSON $ customOptions 2 -instance ToJSON CommonParams where - toJSON = J.genericToJSON $ customOptions 2 - -incorrectParameter :: String -> [String] -> a -> b -incorrectParameter = undefined - -withCommonArgs :: MonadIO m => CommonParams -> ReaderT CommonArgs m a -> m a -withCommonArgs (CommonParams mode0 mDistDir mCabalExe mStackExe _fileUri) a = - case readMode mode0 of - Nothing -> return $ incorrectParameter "mode" ["stack","cabal"] mode0 - Just mode -> do - let cabalExe = fromMaybe "cabal" mCabalExe - stackExe = fromMaybe "stack" mStackExe - distDir' <- maybe (liftIO $ getDistDir mode stackExe) return - mDistDir -- >>= uriToFilePath -- fileUri - runReaderT a $ CommonArgs { - caMode = mode, - caDistDir = distDir', - caCabal = cabalExe, - caStack = stackExe - } -{- -withCommonArgs req a = do - case getParams (IdText "mode" :& RNil) req of - Left err -> return err - Right (ParamText mode0 :& RNil) -> do - case readMode mode0 of - Nothing -> return $ incorrectParameter "mode" ["stack","cabal"] mode0 - Just mode -> do - let cabalExe = maybe "cabal" id $ - Map.lookup "cabalExe" (ideParams req) >>= (\(ParamTextP v) -> return $ T.unpack v) - stackExe = maybe "stack" id $ - Map.lookup "stackExe" (ideParams req) >>= (\(ParamTextP v) -> return $ T.unpack v) - distDir' <- maybe (liftIO $ getDistDir mode stackExe) return $ - Map.lookup "distDir" (ideParams req) >>= - uriToFilePath . (\(ParamFileP v) -> v) - runReaderT a $ CommonArgs { - caMode = mode, - caDistDir = distDir', - caCabal = cabalExe, - caStack = stackExe - } --} - ------------------------------------------------ - --- isHelperPrepared :: CommandFunc Bool --- isHelperPrepared = CmdSync $ \ctx req -> withCommonArgs ctx req $ do --- distDir' <- asks caDistDir --- ret <- liftIO $ isPrepared (defaultQueryEnv "." distDir') --- return $ IdeResultOk ret - ------------------------------------------------ - -prepareHelper :: CommandFunc CommonParams () -prepareHelper = CmdSync $ \req -> withCommonArgs req $ do - ca <- ask - liftIO $ case caMode ca of - StackMode -> do - slp <- getStackLocalPackages "stack.yaml" - mapM_ (prepareHelper' (caDistDir ca) (caCabal ca)) slp - CabalMode -> prepareHelper' (caDistDir ca) (caCabal ca) "." - return $ IdeResultOk () - -prepareHelper' :: MonadIO m => FilePath -> FilePath -> FilePath -> m () -prepareHelper' distDir' cabalExe dir = - prepare $ (mkQueryEnv dir distDir') {qePrograms = defaultPrograms {cabalProgram = cabalExe}} - ------------------------------------------------ - -isConfigured :: CommandFunc CommonParams Bool -isConfigured = CmdSync $ \req -> withCommonArgs req $ do - distDir' <- asks caDistDir - ret <- liftIO $ doesFileExist $ localBuildInfoFile distDir' - return $ IdeResultOk ret - ------------------------------------------------ - -configure :: CommandFunc CommonParams () -configure = CmdSync $ \req -> withCommonArgs req $ do - ca <- ask - _ <- liftIO $ case caMode ca of - StackMode -> configureStack (caStack ca) - CabalMode -> configureCabal (caCabal ca) - return $ IdeResultOk () - -configureStack :: FilePath -> IO String -configureStack stackExe = do - slp <- getStackLocalPackages "stack.yaml" - -- stack can configure only single local package - case slp of - [_singlePackage] -> readProcess stackExe ["build", "--only-configure"] "" - _manyPackages -> readProcess stackExe ["build"] "" - -configureCabal :: FilePath -> IO String -configureCabal cabalExe = readProcess cabalExe ["new-configure"] "" - ------------------------------------------------ - -newtype ListFlagsParams = LF { lfMode :: T.Text } deriving Generic - -instance FromJSON ListFlagsParams where - parseJSON = J.genericParseJSON $ customOptions 2 -instance ToJSON ListFlagsParams where - toJSON = J.genericToJSON $ customOptions 2 - -listFlags :: CommandFunc ListFlagsParams Object -listFlags = CmdSync $ \(LF mode) -> do - cwd <- liftIO getCurrentDirectory - flags0 <- liftIO $ case mode of - "stack" -> listFlagsStack cwd - "cabal" -> fmap (:[]) (listFlagsCabal cwd) - _oops -> return [] - let flags' = flip map flags0 $ \(n,f) -> - object ["packageName" .= n, "flags" .= map flagToJSON f] - (Object ret) = object ["res" .= toJSON flags'] - return $ IdeResultOk ret - -listFlagsStack :: FilePath -> IO [(String,[Flag])] -listFlagsStack d = do - stackPackageDirs <- getStackLocalPackages (d "stack.yaml") - mapM (listFlagsCabal . (d )) stackPackageDirs - -listFlagsCabal :: FilePath -> IO (String,[Flag]) -listFlagsCabal d = do - [cabalFile] <- filter isCabalFile <$> getDirectoryContents d -#if MIN_VERSION_Cabal(2,0,0) - gpd <- readGenericPackageDescription Verb.silent (d cabalFile) -#else - gpd <- readPackageDescription Verb.silent (d cabalFile) -#endif - let name = unPackageName $ pkgName $ package $ packageDescription gpd - flags' = genPackageFlags gpd - return (name, flags') - -flagToJSON :: Flag -> Value -flagToJSON f = object - -- Cabal 2.0 changelog - -- * Backwards incompatible change to 'FlagName' (#4062): - -- 'FlagName' is now opaque; conversion to/from 'String' now works - -- via 'unFlagName' and 'mkFlagName' functions. - - [ "name" .= unFlagName (flagName f) - , "description" .= flagDescription f - , "default" .= flagDefault f] - -#if MIN_VERSION_Cabal(2,0,0) -#else -unFlagName :: FlagName -> String -unFlagName (FlagName s) = s -#endif - ------------------------------------------------ - -data BuildParams = BP { - -- common params. horrible - bpMode :: T.Text - ,bpDistDir :: Maybe String - ,bpCabal :: Maybe String - ,bpStack :: Maybe String - ,bpFile :: Uri - -- specific params - ,bpDirectory :: Maybe Uri - } deriving Generic - -instance FromJSON BuildParams where - parseJSON = J.genericParseJSON $ customOptions 2 -instance ToJSON BuildParams where - toJSON = J.genericToJSON $ customOptions 2 - -buildDirectory :: CommandFunc BuildParams () -buildDirectory = CmdSync $ \(BP m dd c s f mbDir) -> withCommonArgs (CommonParams m dd c s f) $ do - ca <- ask - liftIO $ case caMode ca of - CabalMode -> do - -- for cabal specifying directory have no sense - _ <- readProcess (caCabal ca) ["new-build"] "" - return $ IdeResultOk () - StackMode -> - case mbDir of - Nothing -> do - _ <- readProcess (caStack ca) ["build"] "" - return $ IdeResultOk () - Just dir0 -> pluginGetFile "buildDirectory" dir0 $ \dir -> do - cwd <- getCurrentDirectory - let relDir = makeRelative cwd $ normalise dir - _ <- readProcess (caStack ca) ["build", relDir] "" - return $ IdeResultOk () - ------------------------------------------------ - -data BuildTargetParams = BT { - -- common params. horrible - btMode :: T.Text - ,btDistDir :: Maybe String - ,btCabal :: Maybe String - ,btStack :: Maybe String - ,btFile :: Uri - -- specific params - ,btTarget :: Maybe T.Text - ,btPackage :: Maybe T.Text - ,btType :: T.Text - } deriving Generic - -instance FromJSON BuildTargetParams where - parseJSON = J.genericParseJSON $ customOptions 2 -instance ToJSON BuildTargetParams where - toJSON = J.genericToJSON $ customOptions 2 - -buildTarget :: CommandFunc BuildTargetParams () -buildTarget = CmdSync $ \(BT m dd c s f component package' compType) -> withCommonArgs (CommonParams m dd c s f) $ do - ca <- ask - liftIO $ case caMode ca of - CabalMode -> do - _ <- readProcess (caCabal ca) ["new-build", T.unpack $ fromMaybe "" component] "" - return $ IdeResultOk () - StackMode -> - case (package', component) of - (Just p, Nothing) -> do - _ <- readProcess (caStack ca) ["build", T.unpack $ p `T.append` compType] "" - return $ IdeResultOk () - (Just p, Just c') -> do - _ <- readProcess (caStack ca) ["build", T.unpack $ p `T.append` compType `T.append` (':' `T.cons` c')] "" - return $ IdeResultOk () - (Nothing, Just c') -> do - _ <- readProcess (caStack ca) ["build", T.unpack $ ':' `T.cons` c'] "" - return $ IdeResultOk () - _ -> do - _ <- readProcess (caStack ca) ["build"] "" - return $ IdeResultOk () - ------------------------------------------------ - -data Package = Package { - tPackageName :: String - ,tDirectory :: String - ,tTargets :: [ChComponentName] - } - -listTargets :: CommandFunc CommonParams [Value] -listTargets = CmdSync $ \req -> withCommonArgs req $ do - ca <- ask - targets <- liftIO $ case caMode ca of - CabalMode -> (:[]) <$> listCabalTargets (caDistDir ca) "." - StackMode -> listStackTargets (caDistDir ca) - let ret = flip map targets $ \t -> object - ["name" .= tPackageName t, - "directory" .= tDirectory t, - "targets" .= map compToJSON (tTargets t)] - return $ IdeResultOk ret - -listStackTargets :: FilePath -> IO [Package] -listStackTargets distDir' = do - stackPackageDirs <- getStackLocalPackages "stack.yaml" - mapM (listCabalTargets distDir') stackPackageDirs - -listCabalTargets :: MonadIO m => FilePath -> FilePath -> m Package -listCabalTargets distDir' dir = - runQuery (mkQueryEnv dir distDir') $ do - pkgName' <- fst <$> packageId - cc <- components $ (,) CH.<$> entrypoints - let comps = map (fixupLibraryEntrypoint pkgName' .snd) cc - absDir <- liftIO $ makeAbsolute dir - return $ Package pkgName' absDir comps - where --- # if MIN_VERSION_Cabal(2,0,0) -#if MIN_VERSION_Cabal(1,24,0) - fixupLibraryEntrypoint _n ChLibName = ChLibName -#else - fixupLibraryEntrypoint n (ChLibName "") = ChLibName n -#endif - fixupLibraryEntrypoint _ e = e - --- Example of new way to use cabal helper 'entrypoints' is a ComponentQuery, --- components applies it to all components in the project, the semigroupoids --- apply batches the result per component, and returns the component as the last --- item. -getComponents :: QueryEnv -> IO [(ChEntrypoint,ChComponentName)] -getComponents env = runQuery env $ components $ (,) CH.<$> entrypoints - ------------------------------------------------ - -newtype StackYaml = StackYaml [StackPackage] -data StackPackage = LocalOrHTTPPackage { stackPackageName :: String } - | Repository - -instance FromJSON StackYaml where - parseJSON (Object o) = StackYaml <$> - o .: "packages" - parseJSON _ = mempty - -instance FromJSON StackPackage where - parseJSON (Object _) = pure Repository - parseJSON (String s) = pure $ LocalOrHTTPPackage (T.unpack s) - parseJSON _ = mempty - -isLocal :: StackPackage -> Bool -isLocal (LocalOrHTTPPackage _) = True -isLocal _ = False - -getStackLocalPackages :: FilePath -> IO [String] -getStackLocalPackages stackYamlFile = withBinaryFileContents stackYamlFile $ \contents -> do - let (Just (StackYaml stackYaml)) = decodeThrow contents - stackLocalPackages = map stackPackageName $ filter isLocal stackYaml - return stackLocalPackages - -compToJSON :: ChComponentName -> Value -compToJSON ChSetupHsName = object ["type" .= ("setupHs" :: T.Text)] -#if MIN_VERSION_Cabal(1,24,0) -compToJSON ChLibName = object ["type" .= ("library" :: T.Text)] -compToJSON (ChSubLibName n) = object ["type" .= ("library" :: T.Text), "name" .= n] -compToJSON (ChFLibName n) = object ["type" .= ("library" :: T.Text), "name" .= n] -#else -compToJSON (ChLibName n) = object ["type" .= ("library" :: T.Text), "name" .= n] -#endif -compToJSON (ChExeName n) = object ["type" .= ("executable" :: T.Text), "name" .= n] -compToJSON (ChTestName n) = object ["type" .= ("test" :: T.Text), "name" .= n] -compToJSON (ChBenchName n) = object ["type" .= ("benchmark" :: T.Text), "name" .= n] - ------------------------------------------------ - -getDistDir :: OperationMode -> FilePath -> IO FilePath -getDistDir CabalMode _ = do - cwd <- getCurrentDirectory - return $ cwd defaultDistPref -getDistDir StackMode stackExe = do - cwd <- getCurrentDirectory - dist <- init <$> readProcess stackExe ["path", "--dist-dir"] "" - return $ cwd dist - -isCabalFile :: FilePath -> Bool -isCabalFile f = takeExtension' f == ".cabal" - -takeExtension' :: FilePath -> String -takeExtension' p = - if takeFileName p == takeExtension p - then "" -- just ".cabal" is not a valid cabal file - else takeExtension p - -withBinaryFileContents :: FilePath -> (B.ByteString -> IO c) -> IO c -withBinaryFileContents name act = withFile name ReadMode $ B.hGetContents >=> act - -customOptions :: Int -> J.Options -customOptions n = J.defaultOptions { J.fieldLabelModifier = J.camelTo2 '_' . drop n} diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml index b35b6b43e..3ecd8bbed 100644 --- a/stack-8.2.2.yaml +++ b/stack-8.2.2.yaml @@ -14,7 +14,7 @@ extra-deps: - brittany-0.12.0.0 - butcher-1.3.1.1 - bytestring-trie-0.2.5.0 -- cabal-plan-0.3.0.0 +- cabal-plan-0.5.0.0 - conduit-parse-0.2.1.0 - constrained-dynamic-0.1.0.0 - czipwith-1.0.1.0 @@ -52,6 +52,9 @@ extra-deps: - process-1.6.1.0 - binary-0.8.5.1 - unix-2.7.2.2 +# - Win32-2.6.2. +- time-1.8.0.2 + flags: haskell-ide-engine: diff --git a/stack-8.4.2.yaml b/stack-8.4.2.yaml index ed35a76ac..3fc221f59 100644 --- a/stack-8.4.2.yaml +++ b/stack-8.4.2.yaml @@ -7,14 +7,12 @@ extra-deps: - ./hie-bios - ./submodules/HaRe - ./submodules/cabal-helper -- ./submodules/ghc-mod -- ./submodules/ghc-mod/core - ./submodules/ghc-mod/ghc-project-types - brittany-0.12.1.0 - base-compat-0.9.3 - bytestring-trie-0.2.5.0 -- cabal-plan-0.3.0.0 +- cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 - floskell-0.10.1 - ghc-exactprint-0.5.8.2 diff --git a/stack-8.4.3.yaml b/stack-8.4.3.yaml index de3bf3097..27c45dd9c 100644 --- a/stack-8.4.3.yaml +++ b/stack-8.4.3.yaml @@ -7,14 +7,12 @@ extra-deps: - ./hie-bios - ./submodules/HaRe - ./submodules/cabal-helper -- ./submodules/ghc-mod -- ./submodules/ghc-mod/core - ./submodules/ghc-mod/ghc-project-types - base-compat-0.9.3 - brittany-0.12.1.0 - bytestring-trie-0.2.5.0 -- cabal-plan-0.3.0.0 +- cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 - floskell-0.10.1 - ghc-exactprint-0.5.8.2 @@ -36,7 +34,6 @@ extra-deps: # To make build work in windows 7 - unix-time-0.4.7 - temporary-1.2.1.1 -# - hie-bios-0.2.1@sha256:5f98a3516ce65e0a3ffd88bf6fb416b04cc084371d0fbf0e1762780de1d652ce,3219 - extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af - unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb diff --git a/stack-8.4.4.yaml b/stack-8.4.4.yaml index 82be4453a..4d9e426cb 100644 --- a/stack-8.4.4.yaml +++ b/stack-8.4.4.yaml @@ -7,13 +7,11 @@ extra-deps: - ./hie-bios - ./submodules/HaRe - ./submodules/cabal-helper -- ./submodules/ghc-mod -- ./submodules/ghc-mod/core - ./submodules/ghc-mod/ghc-project-types - brittany-0.12.1.0 - bytestring-trie-0.2.5.0 -- cabal-plan-0.4.0.0 +- cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 - floskell-0.10.1 - ghc-exactprint-0.5.8.2 @@ -36,7 +34,6 @@ extra-deps: # To make build work in windows 7 - unix-time-0.4.7 - temporary-1.2.1.1 -#- hie-bios-0.2.1@sha256:5f98a3516ce65e0a3ffd88bf6fb416b04cc084371d0fbf0e1762780de1d652ce,3219 - extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af - unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb diff --git a/stack-8.6.1.yaml b/stack-8.6.1.yaml index 539a725d0..f44c5243c 100644 --- a/stack-8.6.1.yaml +++ b/stack-8.6.1.yaml @@ -7,8 +7,6 @@ extra-deps: - ./hie-bios - ./submodules/HaRe - ./submodules/cabal-helper -- ./submodules/ghc-mod -- ./submodules/ghc-mod/core - ./submodules/ghc-mod/ghc-project-types - apply-refact-0.6.0.0 @@ -16,7 +14,7 @@ extra-deps: - butcher-1.3.2.3 - bytestring-trie-0.2.5.0 - cabal-install-2.4.0.0 -- cabal-plan-0.4.0.0 +- cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 - czipwith-1.0.1.1 - data-tree-print-0.1.0.2 @@ -44,7 +42,6 @@ extra-deps: - temporary-1.2.1.1 # To make build work in windows 7 - unix-time-0.4.7 -# - hie-bios-0.2.1@sha256:5f98a3516ce65e0a3ffd88bf6fb416b04cc084371d0fbf0e1762780de1d652ce,3219 - extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af - unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb diff --git a/stack-8.6.2.yaml b/stack-8.6.2.yaml index 6fecea2b2..58fbb0145 100644 --- a/stack-8.6.2.yaml +++ b/stack-8.6.2.yaml @@ -7,14 +7,12 @@ extra-deps: - ./hie-bios - ./submodules/HaRe - ./submodules/cabal-helper -- ./submodules/ghc-mod -- ./submodules/ghc-mod/core - ./submodules/ghc-mod/ghc-project-types - brittany-0.12.1.0 - butcher-1.3.2.3 - bytestring-trie-0.2.5.0 -- cabal-plan-0.4.0.0 +- cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 - deque-0.4.3 - floskell-0.10.1 diff --git a/stack-8.6.3.yaml b/stack-8.6.3.yaml index 641c2b305..1a4ea69e5 100644 --- a/stack-8.6.3.yaml +++ b/stack-8.6.3.yaml @@ -7,14 +7,12 @@ extra-deps: - ./hie-bios - ./submodules/HaRe - ./submodules/cabal-helper -- ./submodules/ghc-mod -- ./submodules/ghc-mod/core - ./submodules/ghc-mod/ghc-project-types - brittany-0.12.1.0 - bytestring-trie-0.2.5.0 - butcher-1.3.2.1 -- cabal-plan-0.4.0.0 +- cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 - floskell-0.10.1 - ghc-lib-parser-8.8.1 @@ -36,7 +34,6 @@ extra-deps: - temporary-1.2.1.1 # To make build work in windows 7 - unix-time-0.4.7 -# - hie-bios-0.2.1@sha256:5f98a3516ce65e0a3ffd88bf6fb416b04cc084371d0fbf0e1762780de1d652ce,3219 - extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af - unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 137279c2d..cac2b21bd 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -7,14 +7,12 @@ extra-deps: - ./hie-bios - ./submodules/HaRe - ./submodules/cabal-helper -- ./submodules/ghc-mod -- ./submodules/ghc-mod/core - ./submodules/ghc-mod/ghc-project-types - brittany-0.12.1.0 - butcher-1.3.2.1 - bytestring-trie-0.2.5.0 -- cabal-plan-0.4.0.0 +- cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 - floskell-0.10.1 - ghc-lib-parser-8.8.1 @@ -41,6 +39,7 @@ extra-deps: - yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76 - unordered-containers-0.2.10.0@sha256:5e9b095a9283d9e2f064fec73a81a6b6ea0b7fda3f219a8175785d2d2a3de204 + flags: haskell-ide-engine: pedantic: true diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 39ae2c306..5a631f631 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -7,15 +7,13 @@ extra-deps: - ./hie-bios - ./submodules/HaRe - ./submodules/cabal-helper -- ./submodules/ghc-mod -- ./submodules/ghc-mod/core - ./submodules/ghc-mod/ghc-project-types - ansi-terminal-0.8.2 - ansi-wl-pprint-0.6.8.2 - brittany-0.12.1.0 - bytestring-trie-0.2.5.0 -- cabal-plan-0.4.0.0 +- cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 - floskell-0.10.1 - ghc-lib-parser-8.8.1 @@ -29,6 +27,7 @@ extra-deps: - monad-dijkstra-0.1.1.2@rev:1 - syz-0.2.0.0 - temporary-1.2.1.1 +- clock-0.7.2 # - hie-bios-0.2.1@sha256:5f98a3516ce65e0a3ffd88bf6fb416b04cc084371d0fbf0e1762780de1d652ce,3219 flags: diff --git a/stack.yaml b/stack.yaml index cebad6691..2f4a9bafb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -14,7 +14,7 @@ extra-deps: - bytestring-trie-0.2.5.0 - ansi-wl-pprint-0.6.8.2 - brittany-0.12.1.0 -- cabal-plan-0.4.0.0 +- cabal-plan-0.5.0.0 - constrained-dynamic-0.1.0.0 - floskell-0.10.1 - ghc-lib-parser-8.8.1 @@ -27,8 +27,11 @@ extra-deps: - monad-dijkstra-0.1.1.2@rev:1 - syz-0.2.0.0 - temporary-1.2.1.1 - +- clock-0.7.2 # - hie-bios-0.2.1@sha256:5f98a3516ce65e0a3ffd88bf6fb416b04cc084371d0fbf0e1762780de1d652ce,3219 +- extra-1.6.18@sha256:5f1fff126f0ae47b701fff5aa8462dc63cb44465d5a724b0afd20a3d731903af +- unix-compat-0.5.2@sha256:16763f1fae4a25abf61ac6195eb530ce838474bd04d86c7d353340aee8716bbb +- yaml-0.11.1.2@sha256:cbc4ddb233c564967aad27ee47c1cd8fd6a06b9183353e76fe66c9be7c9dfd76 flags: haskell-ide-engine: diff --git a/submodules/cabal-helper b/submodules/cabal-helper index eafed5e8c..a1c4a3746 160000 --- a/submodules/cabal-helper +++ b/submodules/cabal-helper @@ -1 +1 @@ -Subproject commit eafed5e8c1d82b8daa35775b52361132f2e70261 +Subproject commit a1c4a3746311055c2100471aeb98606345496eb3 diff --git a/submodules/ghc-mod b/submodules/ghc-mod index 910887b2c..7757a149a 160000 --- a/submodules/ghc-mod +++ b/submodules/ghc-mod @@ -1 +1 @@ -Subproject commit 910887b2c33237b703417ec07f35ca8bbf35d729 +Subproject commit 7757a149a6ddb243679840ebff8949ff305c3424 diff --git a/test/testdata/gototest/src/Lib.hs b/test/testdata/gototest/src/Lib.hs index 4575b32d8..2603a7474 100644 --- a/test/testdata/gototest/src/Lib.hs +++ b/test/testdata/gototest/src/Lib.hs @@ -1,5 +1,5 @@ module Lib - + where someFunc :: IO ()