From 2279cf21e28861596f57da2d2a7d675f0d02eaed Mon Sep 17 00:00:00 2001 From: fendor Date: Wed, 16 Oct 2019 13:16:45 +0200 Subject: [PATCH] Refactor functions and add Documentation --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 83 ++++++++++++++----- .../Haskell/Ide/Engine/ModuleCache.hs | 18 +--- src/Haskell/Ide/Engine/Plugin/Base.hs | 4 +- 3 files changed, 63 insertions(+), 42 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 436dda72d..0e17e0521 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -2,10 +2,10 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-} -module Haskell.Ide.Engine.Cradle (findLocalCradle) where +module Haskell.Ide.Engine.Cradle (findLocalCradle, isStackCradle) where import HIE.Bios as BIOS -import HIE.Bios.Types +import HIE.Bios.Types as BIOS import Haskell.Ide.Engine.MonadFunctions import Distribution.Helper import Distribution.Helper.Discover @@ -35,9 +35,17 @@ findLocalCradle fp = do -- Get the cabal directory from the cradle cradleConf <- BIOS.findCradle fp case cradleConf of - Just yaml -> BIOS.loadCradle yaml + 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 --compile-exe` +-- otherwise we may ask `ghc` directly what version it is. +isStackCradle :: Cradle -> Bool +isStackCradle = (`elem` ["stack", "Cabal-Helper-Stack"]) . 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. @@ -74,12 +82,16 @@ findCabalHelperEntryPoint fp = do isCabalOldProject (Ex ProjLocV1CabalFile {}) = True isCabalOldProject _ = False +-- | Given a FilePath, find the Cradle the FilePath belongs to. +-- +-- TODO: document how and why this works. cabalHelperCradle :: FilePath -> IO Cradle -cabalHelperCradle file' = do - file <- canonicalizePath file' -- This is probably unneeded. - projM <- findCabalHelperEntryPoint file' +cabalHelperCradle file = do + projM <- findCabalHelperEntryPoint file case projM of - Nothing -> error $ "Could not find a Project for file: " ++ file' + Nothing -> do + errorm $ "Could not find a Project for file: " ++ file + error $ "Could not find a Project for file: " ++ file Just (Ex proj) -> do -- Find the root of the project based on project type. let root = projectRootDir proj @@ -113,9 +125,9 @@ cabalHelperCradle file' = do Just realPackage -> do -- Field `pSourceDir` often has the form `/./plugin` -- but we only want `/plugin` - debugm $ "Package: " ++ show realPackage + debugm $ "Cabal-Helper cradle package: " ++ show realPackage let normalisedPackageLocation = normalise $ pSourceDir realPackage - debugm $ "normalisedPackageLocation: " ++ normalisedPackageLocation + debugm $ "Cabal-Helper normalisedPackageLocation: " ++ normalisedPackageLocation return Cradle { cradleRootDir = normalisedPackageLocation , cradleOptsProg = @@ -128,20 +140,24 @@ cabalHelperCradle file' = do } } where - cabalHelperAction :: QueryEnv v - -> Package v - -> FilePath - -> FilePath + -- | 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 -- ^ Absolute directory of the package. + -> FilePath -- ^ FilePath to load. -> IO (CradleLoadResult ComponentOptions) - cabalHelperAction env package relativeDir fp = do + cabalHelperAction env package root fp = do let units = pUnits package -- Get all unit infos the given FilePath may belong to -- TODO: lazily initialise units as needed unitInfos_ <- mapM (\unit -> runQuery (unitInfo unit) env) units - let fpRelativeDir = takeDirectory $ makeRelative relativeDir fp - debugm $ "relativeDir: " ++ relativeDir - debugm $ "fpRelativeDir: " ++ fpRelativeDir - case getComponent fpRelativeDir unitInfos_ of + let fpRelativeDir = takeDirectory $ makeRelative root fp + debugm $ "Module FilePath relative to the package root: " ++ fpRelativeDir + case getComponent unitInfos_ fpRelativeDir of Just comp -> do let fs = getFlags comp let targets = getTargets comp fpRelativeDir @@ -157,8 +173,8 @@ cabalHelperCradle file' = do $ CradleError (ExitFailure 2) ("Could not obtain flags for " ++ fp) -- TODO: This can be a complete match -getComponent :: FilePath -> NonEmpty UnitInfo -> Maybe ChComponentInfo -getComponent dir ui = listToMaybe +getComponent :: NonEmpty UnitInfo -> FilePath -> Maybe ChComponentInfo +getComponent ui dir = listToMaybe $ map snd $ filter (hasParent dir . fst) $ sortOn (Down . length . fst) @@ -171,10 +187,11 @@ 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 the 'ciSourceDirs'. --- We monkey patch this by supplying the FilePath we want to load, +-- 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 Documenation of 'ciCourceDir' to why this contains multiple entries. +-- See the Documentation of 'ciCourceDir' to why this contains multiple entries. getTargets :: ChComponentInfo -> FilePath -> [String] getTargets comp fp = case ciEntrypoints comp of ChSetupEntrypoint {} -> [] @@ -190,6 +207,9 @@ hasParent :: FilePath -> FilePath -> Bool hasParent child parent = any (equalFilePath parent) (map joinPath $ inits $ splitPath child) + +-- | 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 @@ -197,6 +217,8 @@ findPackageFor packages fp = packages & filter (\p -> pSourceDir p `isFilePathPrefixOf` fp) & listToMaybe +-- | Helper function to make sure that both FilePaths are normalised. +-- isFilePathPrefixOf :: FilePath -> FilePath -> Bool isFilePathPrefixOf dir fp = normalise dir `isPrefixOf` normalise fp @@ -213,3 +235,18 @@ 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 + -- We need a lens + then 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 diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index 86086e760..eaa5fa55e 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs @@ -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/src/Haskell/Ide/Engine/Plugin/Base.hs b/src/Haskell/Ide/Engine/Plugin/Base.hs index 607d20dcc..11d219c05 100644 --- a/src/Haskell/Ide/Engine/Plugin/Base.hs +++ b/src/Haskell/Ide/Engine/Plugin/Base.hs @@ -20,7 +20,7 @@ import Development.GitRev (gitCommitCount) import Distribution.System (buildArch) import Distribution.Text (display) import Haskell.Ide.Engine.MonadTypes -import qualified HIE.Bios.Types as BIOS +import qualified Haskell.Ide.Engine.Cradle (isStackCradle) import Options.Applicative.Simple (simpleVersion) import qualified Paths_haskell_ide_engine as Meta @@ -110,7 +110,7 @@ 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 && isStackProject && isStackInstalled then do L.infoM "hie" "Using stack GHC version" catch (tryCommand "stack ghc -- --numeric-version") $ \e -> do