From 52940fbdf7fce2a1dc39bacc3e05f77a8ea442d3 Mon Sep 17 00:00:00 2001 From: fendor Date: Thu, 3 Oct 2019 18:15:39 +0200 Subject: [PATCH 01/33] Use cabal-helper 1.0 --- .gitmodules | 9 +- app/MainHie.hs | 2 - haskell-ide-engine.cabal | 3 +- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 70 ++- hie-plugin-api/hie-plugin-api.cabal | 1 + src/Haskell/Ide/Engine/Plugin/Build.hs | 538 -------------------- stack-8.2.2.yaml | 5 +- stack-8.4.2.yaml | 2 +- stack-8.4.3.yaml | 3 +- stack-8.4.4.yaml | 3 +- stack-8.6.1.yaml | 3 +- stack-8.6.2.yaml | 2 +- stack-8.6.3.yaml | 3 +- stack-8.6.4.yaml | 3 +- stack.yaml | 4 +- submodules/HaRe | 2 +- submodules/cabal-helper | 2 +- submodules/ghc-mod | 2 +- 18 files changed, 92 insertions(+), 565 deletions(-) diff --git a/.gitmodules b/.gitmodules index c96b580fc..07e4fc692 100644 --- a/.gitmodules +++ b/.gitmodules @@ -12,19 +12,20 @@ [submodule "submodules/HaRe"] path = submodules/HaRe - # url = https://github.com/bubba/HaRe.git - url = https://github.com/wz1000/HaRe.git + 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/alanz/cabal-helper.git # url = https://github.com/DanielG/cabal-helper.git + url = https://github.com/wz1000/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/bubba/ghc-mod.git #url = https://github.com/mpickering/ghc-mod.git [submodule "hie-bios"] 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..92917d89b 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -1,6 +1,23 @@ +{-# LANGUAGE TupleSections #-} module Haskell.Ide.Engine.Cradle (findLocalCradle) where import HIE.Bios as BIOS +import HIE.Bios.Types + +import Haskell.Ide.Engine.MonadFunctions + +import Distribution.Helper +import Distribution.Helper.Discover + +import System.FilePath +import System.Directory + +import qualified Data.Map as M +import Data.Foldable (toList) +import Data.List (inits, sortOn) +import Data.Maybe (listToMaybe) +import Data.Ord +import System.Exit -- | Find the cradle that the given File belongs to. -- @@ -18,4 +35,55 @@ findLocalCradle fp = do cradleConf <- BIOS.findCradle fp case cradleConf of Just yaml -> BIOS.loadCradle yaml - Nothing -> BIOS.loadImplicitCradle fp \ No newline at end of file + Nothing -> cabalHelperCradle fp + +cabalHelperCradle :: FilePath -> IO Cradle +cabalHelperCradle file' = do + -- TODO find cradle + root' <- getCurrentDirectory + root <- canonicalizePath root' + return Cradle + { cradleRootDir = root + , cradleOptsProg = CradleAction + { actionName = "Cabal-Helper" + , runCradle = cabalHelperAction root + } + } + + where + cabalHelperAction :: FilePath -> FilePath -> IO (CradleLoadResult ComponentOptions) + cabalHelperAction root fp = do + file <- canonicalizePath fp + let file_dir = makeRelative root $ takeDirectory file + debugm $ "Cabal Helper dirs: " ++ show [root, file, file_dir] + projs <- findProjects root + case projs of + (Ex proj:_) -> do + let [dist_dir] = findDistDirs proj + env <- mkQueryEnv proj dist_dir + units <- runQuery (allUnits id) env + + case getFlags file_dir $ toList units of + Just fs -> do + debugm $ "Flags for \"" ++ fp ++ "\": " ++ show fs + return $ CradleSuccess + ComponentOptions + { componentOptions = fs ++ [file] + , componentDependencies = [] + } + + Nothing -> return $ CradleFail $ CradleError (ExitFailure 2) ("Could not obtain flags for " ++ fp) + _ -> return $ CradleFail $ CradleError (ExitFailure 1) ("Could not find project from: " ++ fp) + +getFlags :: FilePath -> [UnitInfo] -> Maybe [String] +getFlags dir uis + = listToMaybe + $ map (ciGhcOptions . snd) + $ filter (hasParent dir . fst) + $ sortOn (Down . length . fst) + $ concatMap (\ci -> map (,ci) (ciSourceDirs ci)) + $ concat + $ M.elems . uiComponents <$> uis + +hasParent :: FilePath -> FilePath -> Bool +hasParent child parent = any (equalFilePath parent) (map joinPath $ inits $ splitPath child) \ No newline at end of file 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/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..0a5a6f325 100644 --- a/stack-8.4.2.yaml +++ b/stack-8.4.2.yaml @@ -14,7 +14,7 @@ extra-deps: - 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..92f03ddab 100644 --- a/stack-8.4.3.yaml +++ b/stack-8.4.3.yaml @@ -14,7 +14,7 @@ extra-deps: - 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 +36,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..8355e44fa 100644 --- a/stack-8.4.4.yaml +++ b/stack-8.4.4.yaml @@ -13,7 +13,7 @@ extra-deps: - 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 +36,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..f116e0e01 100644 --- a/stack-8.6.1.yaml +++ b/stack-8.6.1.yaml @@ -16,7 +16,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 +44,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..d0f2597b8 100644 --- a/stack-8.6.2.yaml +++ b/stack-8.6.2.yaml @@ -14,7 +14,7 @@ extra-deps: - 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..cb83da82f 100644 --- a/stack-8.6.3.yaml +++ b/stack-8.6.3.yaml @@ -14,7 +14,7 @@ extra-deps: - 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 +36,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..b968293ec 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -14,7 +14,7 @@ extra-deps: - 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 +41,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.yaml b/stack.yaml index cebad6691..d39ab99f0 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 @@ -28,8 +28,6 @@ extra-deps: - syz-0.2.0.0 - temporary-1.2.1.1 -# - hie-bios-0.2.1@sha256:5f98a3516ce65e0a3ffd88bf6fb416b04cc084371d0fbf0e1762780de1d652ce,3219 - flags: haskell-ide-engine: pedantic: true diff --git a/submodules/HaRe b/submodules/HaRe index 03de75229..5e870b5b1 160000 --- a/submodules/HaRe +++ b/submodules/HaRe @@ -1 +1 @@ -Subproject commit 03de7522995a3b192c3a2b010539d02e753e3d3d +Subproject commit 5e870b5b13e8fdead0ffd9a47e60528c7490ffd8 diff --git a/submodules/cabal-helper b/submodules/cabal-helper index eafed5e8c..6c4880f7f 160000 --- a/submodules/cabal-helper +++ b/submodules/cabal-helper @@ -1 +1 @@ -Subproject commit eafed5e8c1d82b8daa35775b52361132f2e70261 +Subproject commit 6c4880f7fa6e23a7f9d073bae3721f31b8d89e80 diff --git a/submodules/ghc-mod b/submodules/ghc-mod index 910887b2c..9c56ab080 160000 --- a/submodules/ghc-mod +++ b/submodules/ghc-mod @@ -1 +1 @@ -Subproject commit 910887b2c33237b703417ec07f35ca8bbf35d729 +Subproject commit 9c56ab08087fca74034423dcb6a4560230ca1f76 From 26d0ddd896bb13da805075ad894069a3bb090823 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 11 Oct 2019 17:37:09 +0200 Subject: [PATCH 02/33] Update .gitmodules to use DanielG's cabal-helper --- .gitmodules | 2 +- submodules/cabal-helper | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 07e4fc692..2df5c741c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -20,7 +20,7 @@ # 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/wz1000/cabal-helper.git + url = https://github.com/DanielG/cabal-helper.git [submodule "submodules/ghc-mod"] path = submodules/ghc-mod diff --git a/submodules/cabal-helper b/submodules/cabal-helper index 6c4880f7f..447814db7 160000 --- a/submodules/cabal-helper +++ b/submodules/cabal-helper @@ -1 +1 @@ -Subproject commit 6c4880f7fa6e23a7f9d073bae3721f31b8d89e80 +Subproject commit 447814db7ecda25afa13a7a699a72c5223649d98 From a1bac0741add823310c41c56e3c99bcfcb6fdd1a Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 13 Oct 2019 15:05:20 +0200 Subject: [PATCH 03/33] Re-implement cabal-helper cradle Update ghc-project-types to include latest c-h changes. --- .gitmodules | 5 +- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 160 +++++++++++------- .../Haskell/Ide/Engine/GhcModuleCache.hs | 2 +- .../Haskell/Ide/Engine/ModuleCache.hs | 2 +- submodules/ghc-mod | 2 +- 5 files changed, 108 insertions(+), 63 deletions(-) diff --git a/.gitmodules b/.gitmodules index 2df5c741c..fb73805e5 100644 --- a/.gitmodules +++ b/.gitmodules @@ -19,13 +19,14 @@ 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 + # url = https://github.com/bubba/cabal-helper.git [submodule "submodules/ghc-mod"] path = submodules/ghc-mod # url = https://github.com/arbor/ghc-mod.git - url = https://github.com/bubba/ghc-mod.git + # url = https://github.com/bubba/ghc-mod.git + url = https://github.com/fendor/ghc-mod.git #url = https://github.com/mpickering/ghc-mod.git [submodule "hie-bios"] diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 92917d89b..e2088fb9a 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -1,23 +1,24 @@ {-# LANGUAGE TupleSections #-} -module Haskell.Ide.Engine.Cradle (findLocalCradle) where - -import HIE.Bios as BIOS -import HIE.Bios.Types - -import Haskell.Ide.Engine.MonadFunctions +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE GADTs #-} -import Distribution.Helper -import Distribution.Helper.Discover - -import System.FilePath -import System.Directory +module Haskell.Ide.Engine.Cradle (findLocalCradle) where +import HIE.Bios as BIOS +import HIE.Bios.Types +import Haskell.Ide.Engine.MonadFunctions +import Distribution.Helper +import Distribution.Helper.Discover +import Data.Function ((&)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty) +import System.FilePath +import System.Directory import qualified Data.Map as M -import Data.Foldable (toList) -import Data.List (inits, sortOn) -import Data.Maybe (listToMaybe) -import Data.Ord -import System.Exit +import Data.List (inits, sortOn, isPrefixOf) +import Data.Maybe (listToMaybe) +import Data.Ord +import System.Exit -- | Find the cradle that the given File belongs to. -- @@ -35,55 +36,98 @@ findLocalCradle fp = do cradleConf <- BIOS.findCradle fp case cradleConf of Just yaml -> BIOS.loadCradle yaml - Nothing -> cabalHelperCradle fp + Nothing -> cabalHelperCradle fp cabalHelperCradle :: FilePath -> IO Cradle cabalHelperCradle file' = do - -- TODO find cradle - root' <- getCurrentDirectory - root <- canonicalizePath root' - return Cradle - { cradleRootDir = root - , cradleOptsProg = CradleAction - { actionName = "Cabal-Helper" - , runCradle = cabalHelperAction root - } - } - + -- TODO: recursive search + root <- getCurrentDirectory + file <- canonicalizePath file' + logm $ "Cabal Helper dirs: " ++ show [root, file] + projs <- findProjects root + case projs of + (Ex proj:_) -> do + let actionNameSuffix = case proj of + ProjLocV1CabalFile {} -> "Cabal-V1" + ProjLocV1Dir {} -> "Cabal-V1-Dir" + ProjLocV2File {} -> "Cabal-V2" + ProjLocV2Dir {} -> "Cabal-V2-Dir" + ProjLocStackYaml {} -> "Stack" + let dist_dir = getDefaultDistDir proj + env <- mkQueryEnv proj dist_dir + packages <- runQuery projectPackages env + -- Find the package the given file may belong to + let realPackage = packages `findPackageFor` file + -- Field `pSourceDir` often has the form `/./plugin` + -- but we only want `/plugin` + let normalisedPackageLocation = normalise $ pSourceDir realPackage + -- Given the current directory: /projectRoot and the package is in + -- /projectRoot/plugin, we only want ./plugin + let relativePackageLocation = makeRelative root normalisedPackageLocation + return + Cradle { cradleRootDir = normalise (root relativePackageLocation) + , cradleOptsProg = CradleAction { actionName = "Cabal-Helper-" + ++ actionNameSuffix + , runCradle = cabalHelperAction + env + realPackage + normalisedPackageLocation + } + } + -- TODO: fix this undefined, probably an errorIO + _ -> undefined where - cabalHelperAction :: FilePath -> FilePath -> IO (CradleLoadResult ComponentOptions) - cabalHelperAction root fp = do - file <- canonicalizePath fp - let file_dir = makeRelative root $ takeDirectory file - debugm $ "Cabal Helper dirs: " ++ show [root, file, file_dir] - projs <- findProjects root - case projs of - (Ex proj:_) -> do - let [dist_dir] = findDistDirs proj - env <- mkQueryEnv proj dist_dir - units <- runQuery (allUnits id) env + cabalHelperAction :: QueryEnv v + -> Package v + -> FilePath + -> FilePath + -> IO (CradleLoadResult ComponentOptions) + cabalHelperAction env package relativeDir fp = do + let units = pUnits package + -- Get all unit infos the given FilePath may belong to + unitInfos_ <- mapM (\unit -> runQuery (unitInfo unit) env) units + let fpRelativeDir = takeDirectory $ makeRelative relativeDir fp + case getComponent fpRelativeDir unitInfos_ of + Just comp -> do + let fs = getFlags comp + let targets = getTargets comp + let ghcOptions = fs ++ targets + debugm $ "Flags for \"" ++ fp ++ "\": " ++ show ghcOptions + return + $ CradleSuccess + ComponentOptions { componentOptions = ghcOptions + , componentDependencies = [] + } + Nothing -> return + $ CradleFail + $ CradleError (ExitFailure 2) ("Could not obtain flags for " ++ fp) - case getFlags file_dir $ toList units of - Just fs -> do - debugm $ "Flags for \"" ++ fp ++ "\": " ++ show fs - return $ CradleSuccess - ComponentOptions - { componentOptions = fs ++ [file] - , componentDependencies = [] - } - - Nothing -> return $ CradleFail $ CradleError (ExitFailure 2) ("Could not obtain flags for " ++ fp) - _ -> return $ CradleFail $ CradleError (ExitFailure 1) ("Could not find project from: " ++ fp) - -getFlags :: FilePath -> [UnitInfo] -> Maybe [String] -getFlags dir uis - = listToMaybe - $ map (ciGhcOptions . snd) +getComponent :: FilePath -> NonEmpty UnitInfo -> Maybe ChComponentInfo +getComponent dir ui = listToMaybe + $ map snd $ filter (hasParent dir . fst) $ sortOn (Down . length . fst) - $ concatMap (\ci -> map (,ci) (ciSourceDirs ci)) + $ concatMap (\ci -> map (, ci) (ciSourceDirs ci)) $ concat - $ M.elems . uiComponents <$> uis + $ M.elems . uiComponents <$> ui + +getFlags :: ChComponentInfo -> [String] +getFlags = ciGhcOptions + +getTargets :: ChComponentInfo -> [String] +getTargets comp = case ciEntrypoints comp of + ChSetupEntrypoint {} -> [] + ChLibEntrypoint { chExposedModules, chOtherModules } + -> map unChModuleName (chExposedModules ++ chOtherModules) + ChExeEntrypoint { chMainIs, chOtherModules } + -> chMainIs:map unChModuleName chOtherModules hasParent :: FilePath -> FilePath -> Bool -hasParent child parent = any (equalFilePath parent) (map joinPath $ inits $ splitPath child) \ No newline at end of file +hasParent child parent = + any (equalFilePath parent) (map joinPath $ inits $ splitPath child) + +findPackageFor :: NonEmpty (Package pt) -> FilePath -> Package pt +findPackageFor packages fp = packages + & NonEmpty.filter (\p -> normalise (pSourceDir p) `isPrefixOf` fp) + & sortOn (Down . length . pSourceDir) + & head -- this head is unreasonable \ No newline at end of file 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..86086e760 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 diff --git a/submodules/ghc-mod b/submodules/ghc-mod index 9c56ab080..7757a149a 160000 --- a/submodules/ghc-mod +++ b/submodules/ghc-mod @@ -1 +1 @@ -Subproject commit 9c56ab08087fca74034423dcb6a4560230ca1f76 +Subproject commit 7757a149a6ddb243679840ebff8949ff305c3424 From 294c40127c905530e8cf5409c60eb7de77706b30 Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 13 Oct 2019 15:25:07 +0200 Subject: [PATCH 04/33] Update hie-bios --- hie-bios | 1 - submodules/HaRe | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) delete mode 160000 hie-bios diff --git a/hie-bios b/hie-bios deleted file mode 160000 index c396c5557..000000000 --- a/hie-bios +++ /dev/null @@ -1 +0,0 @@ -Subproject commit c396c5557b111369a66e15e21c17d36a10bbb4a5 diff --git a/submodules/HaRe b/submodules/HaRe index 5e870b5b1..03de75229 160000 --- a/submodules/HaRe +++ b/submodules/HaRe @@ -1 +1 @@ -Subproject commit 5e870b5b13e8fdead0ffd9a47e60528c7490ffd8 +Subproject commit 03de7522995a3b192c3a2b010539d02e753e3d3d From 52b60baa7b2e8aa6c862cc6914ad31c16f566761 Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 13 Oct 2019 15:25:37 +0200 Subject: [PATCH 05/33] Fix builds for stack --- stack-8.4.2.yaml | 2 -- stack-8.4.3.yaml | 2 -- stack-8.4.4.yaml | 2 -- stack-8.6.1.yaml | 2 -- stack-8.6.2.yaml | 2 -- stack-8.6.3.yaml | 2 -- stack-8.6.4.yaml | 2 -- stack-8.6.5.yaml | 2 -- stack.yaml | 5 +++++ 9 files changed, 5 insertions(+), 16 deletions(-) diff --git a/stack-8.4.2.yaml b/stack-8.4.2.yaml index 0a5a6f325..3fc221f59 100644 --- a/stack-8.4.2.yaml +++ b/stack-8.4.2.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 - brittany-0.12.1.0 diff --git a/stack-8.4.3.yaml b/stack-8.4.3.yaml index 92f03ddab..27c45dd9c 100644 --- a/stack-8.4.3.yaml +++ b/stack-8.4.3.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 - base-compat-0.9.3 diff --git a/stack-8.4.4.yaml b/stack-8.4.4.yaml index 8355e44fa..4d9e426cb 100644 --- a/stack-8.4.4.yaml +++ b/stack-8.4.4.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 - brittany-0.12.1.0 diff --git a/stack-8.6.1.yaml b/stack-8.6.1.yaml index f116e0e01..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 diff --git a/stack-8.6.2.yaml b/stack-8.6.2.yaml index d0f2597b8..58fbb0145 100644 --- a/stack-8.6.2.yaml +++ b/stack-8.6.2.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 - brittany-0.12.1.0 diff --git a/stack-8.6.3.yaml b/stack-8.6.3.yaml index cb83da82f..1a4ea69e5 100644 --- a/stack-8.6.3.yaml +++ b/stack-8.6.3.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 - brittany-0.12.1.0 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index b968293ec..cac2b21bd 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.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 - brittany-0.12.1.0 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 39ae2c306..72052c8be 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.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 - ansi-terminal-0.8.2 diff --git a/stack.yaml b/stack.yaml index d39ab99f0..2f4a9bafb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -27,6 +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: From ae844a03ba13d84dae8932052c78ae270afaf852 Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 14 Oct 2019 16:32:25 +0200 Subject: [PATCH 06/33] Change HaRe submodule to use different remote --- .gitmodules | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index fb73805e5..34e39fb4a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -12,8 +12,8 @@ [submodule "submodules/HaRe"] path = submodules/HaRe - url = https://github.com/bubba/HaRe.git - # url = https://github.com/wz1000/HaRe.git + # url = https://github.com/bubba/HaRe.git + url = https://github.com/wz1000/HaRe.git [submodule "submodules/cabal-helper"] path = submodules/cabal-helper From 7def5140bea60ab5f4974759b8348447ed3b008a Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 14 Oct 2019 18:24:45 +0200 Subject: [PATCH 07/33] Update .gitmodules --- .gitmodules | 3 +-- hie-bios | 1 + 2 files changed, 2 insertions(+), 2 deletions(-) create mode 160000 hie-bios diff --git a/.gitmodules b/.gitmodules index 34e39fb4a..5c797faab 100644 --- a/.gitmodules +++ b/.gitmodules @@ -31,5 +31,4 @@ [submodule "hie-bios"] path = hie-bios - url = https://github.com/mpickering/hie-bios.git - branch = multi-cradle + url = git@github.com:mpickering/hie-bios.git diff --git a/hie-bios b/hie-bios new file mode 160000 index 000000000..c396c5557 --- /dev/null +++ b/hie-bios @@ -0,0 +1 @@ +Subproject commit c396c5557b111369a66e15e21c17d36a10bbb4a5 From 799bfd6ee9ddf6e1564f1efd8edd14868807cedf Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 14 Oct 2019 20:41:05 +0200 Subject: [PATCH 08/33] Fix multi-component support for cabal-helper cradle --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index e2088fb9a..1ccc6d145 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -15,9 +15,9 @@ import Data.List.NonEmpty (NonEmpty) import System.FilePath import System.Directory import qualified Data.Map as M -import Data.List (inits, sortOn, isPrefixOf) +import Data.List (inits, sortOn, isPrefixOf, find) import Data.Maybe (listToMaybe) -import Data.Ord +import Data.Ord (Down(..)) import System.Exit -- | Find the cradle that the given File belongs to. @@ -90,7 +90,7 @@ cabalHelperCradle file' = do case getComponent fpRelativeDir unitInfos_ of Just comp -> do let fs = getFlags comp - let targets = getTargets comp + let targets = getTargets comp fpRelativeDir let ghcOptions = fs ++ targets debugm $ "Flags for \"" ++ fp ++ "\": " ++ show ghcOptions return @@ -114,13 +114,16 @@ getComponent dir ui = listToMaybe getFlags :: ChComponentInfo -> [String] getFlags = ciGhcOptions -getTargets :: ChComponentInfo -> [String] -getTargets comp = case ciEntrypoints comp of +getTargets :: ChComponentInfo -> FilePath -> [String] +getTargets comp fp = case ciEntrypoints comp of ChSetupEntrypoint {} -> [] ChLibEntrypoint { chExposedModules, chOtherModules } -> map unChModuleName (chExposedModules ++ chOtherModules) ChExeEntrypoint { chMainIs, chOtherModules } - -> chMainIs:map unChModuleName chOtherModules + -> [sourceDir chMainIs | Just sourceDir <- [sourceDirs]] + ++ map unChModuleName chOtherModules + where + sourceDirs = find (`isPrefixOf` fp) (ciSourceDirs comp) hasParent :: FilePath -> FilePath -> Bool hasParent child parent = From 408b0b589a64ab4e4a87371bfaa95cdb829b19aa Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 14 Oct 2019 21:01:27 +0200 Subject: [PATCH 09/33] Add real error messages --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 51 ++++++++++++--------- 1 file changed, 30 insertions(+), 21 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 1ccc6d145..399be5729 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -46,7 +46,10 @@ cabalHelperCradle file' = do logm $ "Cabal Helper dirs: " ++ show [root, file] projs <- findProjects root case projs of + [] -> error $ "Could not find a Project for file: " ++ file' (Ex proj:_) -> do + -- Create a suffix for the cradle name. + -- Purpose is mainly for easier debugging. let actionNameSuffix = case proj of ProjLocV1CabalFile {} -> "Cabal-V1" ProjLocV1Dir {} -> "Cabal-V1-Dir" @@ -57,25 +60,31 @@ cabalHelperCradle file' = do env <- mkQueryEnv proj dist_dir packages <- runQuery projectPackages env -- Find the package the given file may belong to - let realPackage = packages `findPackageFor` file - -- Field `pSourceDir` often has the form `/./plugin` - -- but we only want `/plugin` - let normalisedPackageLocation = normalise $ pSourceDir realPackage - -- Given the current directory: /projectRoot and the package is in - -- /projectRoot/plugin, we only want ./plugin - let relativePackageLocation = makeRelative root normalisedPackageLocation - return - Cradle { cradleRootDir = normalise (root relativePackageLocation) - , cradleOptsProg = CradleAction { actionName = "Cabal-Helper-" - ++ actionNameSuffix - , runCradle = cabalHelperAction - env - realPackage - normalisedPackageLocation - } - } - -- TODO: fix this undefined, probably an errorIO - _ -> undefined + case packages `findPackageFor` file of + Nothing -> error + $ "Could not find a Package to which the file \"" + ++ file' + ++ "\" belongs to." + Just realPackage -> do + -- Field `pSourceDir` often has the form `/./plugin` + -- but we only want `/plugin` + let normalisedPackageLocation = normalise $ pSourceDir realPackage + -- Given the current directory: /projectRoot and the package is in + -- /projectRoot/plugin, we only want ./plugin + let relativePackageLocation = + makeRelative root normalisedPackageLocation + return + Cradle { cradleRootDir = normalise + (root relativePackageLocation) + , cradleOptsProg = + CradleAction { actionName = + "Cabal-Helper-" ++ actionNameSuffix + , runCradle = cabalHelperAction + env + realPackage + normalisedPackageLocation + } + } where cabalHelperAction :: QueryEnv v -> Package v @@ -129,8 +138,8 @@ hasParent :: FilePath -> FilePath -> Bool hasParent child parent = any (equalFilePath parent) (map joinPath $ inits $ splitPath child) -findPackageFor :: NonEmpty (Package pt) -> FilePath -> Package pt +findPackageFor :: NonEmpty (Package pt) -> FilePath -> Maybe (Package pt) findPackageFor packages fp = packages & NonEmpty.filter (\p -> normalise (pSourceDir p) `isPrefixOf` fp) & sortOn (Down . length . pSourceDir) - & head -- this head is unreasonable \ No newline at end of file + & listToMaybe \ No newline at end of file From 2fdcb3ad4c99dce74dec8bf54afba2f118b914ce Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 15 Oct 2019 13:34:53 +0200 Subject: [PATCH 10/33] Add none-cradle if file does not belong to any package --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 16 ++++++++++++---- test/testdata/gototest/src/Lib.hs | 2 +- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 399be5729..7d2f8d41b 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -61,10 +61,18 @@ cabalHelperCradle file' = do packages <- runQuery projectPackages env -- Find the package the given file may belong to case packages `findPackageFor` file of - Nothing -> error - $ "Could not find a Package to which the file \"" - ++ file' - ++ "\" belongs to." + 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 + , runCradle = \_ -> return CradleNone + } + } Just realPackage -> do -- Field `pSourceDir` often has the form `/./plugin` -- but we only want `/plugin` 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 () From c41eed00bf5a3b749ab292da44857bb200938a16 Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 15 Oct 2019 19:19:37 +0200 Subject: [PATCH 11/33] Fix cabal-helper multi-packages support --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 110 +++++++++++++++----- 1 file changed, 83 insertions(+), 27 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 7d2f8d41b..deb693524 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -38,28 +38,78 @@ findLocalCradle fp = do Just yaml -> BIOS.loadCradle yaml Nothing -> cabalHelperCradle fp +-- | 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 any-time. +findCabalHelperEntryPoint :: FilePath -> IO (Maybe (Ex ProjLoc)) +findCabalHelperEntryPoint fp = do + projs <- concat <$> mapM findProjects subdirs + 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 + -- | Subdirectories of a given FilePath. + -- Directory closest to the FilePath `fp` is the head, + -- followed by one directory taken away. + subdirs :: [FilePath] + subdirs = reverse . map joinPath . tail . inits $ splitDirectories (takeDirectory fp) + + 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 + +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" + cabalHelperCradle :: FilePath -> IO Cradle cabalHelperCradle file' = do - -- TODO: recursive search - root <- getCurrentDirectory - file <- canonicalizePath file' - logm $ "Cabal Helper dirs: " ++ show [root, file] - projs <- findProjects root - case projs of - [] -> error $ "Could not find a Project for file: " ++ file' - (Ex proj:_) -> do + file <- canonicalizePath file' -- This is probably unneeded. + projM <- findCabalHelperEntryPoint file' + case projM of + Nothing -> 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 -- Create a suffix for the cradle name. -- Purpose is mainly for easier debugging. - let actionNameSuffix = case proj of - ProjLocV1CabalFile {} -> "Cabal-V1" - ProjLocV1Dir {} -> "Cabal-V1-Dir" - ProjLocV2File {} -> "Cabal-V2" - ProjLocV2Dir {} -> "Cabal-V2-Dir" - ProjLocStackYaml {} -> "Stack" + 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 + -- 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 @@ -68,22 +118,20 @@ cabalHelperCradle file' = do return Cradle { cradleRootDir = root , cradleOptsProg = - CradleAction { actionName = - "Cabal-Helper-" ++ actionNameSuffix + CradleAction { actionName = "Cabal-Helper-" + ++ actionNameSuffix + ++ "-None" , runCradle = \_ -> return CradleNone } } Just realPackage -> do -- Field `pSourceDir` often has the form `/./plugin` -- but we only want `/plugin` + debugm $ "Package: " ++ show realPackage let normalisedPackageLocation = normalise $ pSourceDir realPackage - -- Given the current directory: /projectRoot and the package is in - -- /projectRoot/plugin, we only want ./plugin - let relativePackageLocation = - makeRelative root normalisedPackageLocation + debugm $ "normalisedPackageLocation: " ++ normalisedPackageLocation return - Cradle { cradleRootDir = normalise - (root relativePackageLocation) + Cradle { cradleRootDir = normalisedPackageLocation , cradleOptsProg = CradleAction { actionName = "Cabal-Helper-" ++ actionNameSuffix @@ -102,8 +150,11 @@ cabalHelperCradle file' = do cabalHelperAction env package relativeDir 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 Just comp -> do let fs = getFlags comp @@ -119,6 +170,7 @@ cabalHelperCradle file' = do $ CradleFail $ 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 $ map snd @@ -140,7 +192,7 @@ getTargets comp fp = case ciEntrypoints comp of -> [sourceDir chMainIs | Just sourceDir <- [sourceDirs]] ++ map unChModuleName chOtherModules where - sourceDirs = find (`isPrefixOf` fp) (ciSourceDirs comp) + sourceDirs = find (`isFilePathPrefixOf` fp) (ciSourceDirs comp) hasParent :: FilePath -> FilePath -> Bool hasParent child parent = @@ -148,6 +200,10 @@ hasParent child parent = findPackageFor :: NonEmpty (Package pt) -> FilePath -> Maybe (Package pt) findPackageFor packages fp = packages - & NonEmpty.filter (\p -> normalise (pSourceDir p) `isPrefixOf` fp) - & sortOn (Down . length . pSourceDir) - & listToMaybe \ No newline at end of file + & NonEmpty.toList + & sortOn (Down . pSourceDir) + & filter (\p -> pSourceDir p `isFilePathPrefixOf` fp) + & listToMaybe + +isFilePathPrefixOf :: FilePath -> FilePath -> Bool +isFilePathPrefixOf dir fp = normalise dir `isPrefixOf` normalise fp \ No newline at end of file From 2ffb17e54fdfd85f9f33313b0eb139280f8d6ce3 Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 15 Oct 2019 19:26:08 +0200 Subject: [PATCH 12/33] More Documentation --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 36 ++++++++++++--------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index deb693524..436dda72d 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -74,20 +74,6 @@ findCabalHelperEntryPoint fp = do isCabalOldProject (Ex ProjLocV1CabalFile {}) = True isCabalOldProject _ = False -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" - cabalHelperCradle :: FilePath -> IO Cradle cabalHelperCradle file' = do file <- canonicalizePath file' -- This is probably unneeded. @@ -183,6 +169,12 @@ getComponent dir ui = listToMaybe 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 the '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. getTargets :: ChComponentInfo -> FilePath -> [String] getTargets comp fp = case ciEntrypoints comp of ChSetupEntrypoint {} -> [] @@ -206,4 +198,18 @@ findPackageFor packages fp = packages & listToMaybe isFilePathPrefixOf :: FilePath -> FilePath -> Bool -isFilePathPrefixOf dir fp = normalise dir `isPrefixOf` normalise fp \ No newline at end of file +isFilePathPrefixOf dir fp = normalise dir `isPrefixOf` normalise fp + +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" From b72e60690df0ef11747bca8ea4d01344329e636c Mon Sep 17 00:00:00 2001 From: fendor Date: Wed, 16 Oct 2019 13:16:45 +0200 Subject: [PATCH 13/33] Refactor functions and add Documentation --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 87 +++++++++++++------ .../Haskell/Ide/Engine/ModuleCache.hs | 18 +--- src/Haskell/Ide/Engine/Plugin/Base.hs | 3 +- 3 files changed, 65 insertions(+), 43 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 436dda72d..ffbdc41e0 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 @@ -87,7 +99,7 @@ cabalHelperCradle file' = do -- Purpose is mainly for easier debugging. let actionNameSuffix = projectSuffix proj - logm $ "Cabal Helper dirs: " ++ show [root, file] + logm $ "Cabal-Helper dirs: " ++ show [root, file] let dist_dir = getDefaultDistDir proj env <- mkQueryEnv proj dist_dir @@ -111,11 +123,11 @@ cabalHelperCradle file' = do } } Just realPackage -> do + debugm $ "Cabal-Helper cradle package: " ++ show realPackage -- Field `pSourceDir` often has the form `/./plugin` -- but we only want `/plugin` - debugm $ "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 @@ -156,9 +172,9 @@ cabalHelperCradle file' = do $ CradleFail $ 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 +-- TODO: This can be a complete match, it actually should be +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..bc177f70f 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 @@ -110,7 +111,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 From 91a56b01f54ecbe4ae62198ecab16884d57ac3c2 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 25 Oct 2019 15:07:05 +0200 Subject: [PATCH 14/33] Improve comments --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index ffbdc41e0..73c6f1f1d 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -13,7 +13,6 @@ import Data.Function ((&)) import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty) import System.FilePath -import System.Directory import qualified Data.Map as M import Data.List (inits, sortOn, isPrefixOf, find) import Data.Maybe (listToMaybe) @@ -55,7 +54,7 @@ isStackCradle = (`elem` ["stack", "Cabal-Helper-Stack"]) . BIOS.actionName . BIO -- 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 any-time. +-- This guessing has no guarantees and may change at any time. findCabalHelperEntryPoint :: FilePath -> IO (Maybe (Ex ProjLoc)) findCabalHelperEntryPoint fp = do projs <- concat <$> mapM findProjects subdirs From b28e9444a7961b928f18d80eeaf0206020a7390e Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 25 Oct 2019 15:44:11 +0200 Subject: [PATCH 15/33] Upgrade stack version in circleci to 2.1.3 --- .circleci/config.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) 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 From c84b33fcbfd2651bb770e85058a3f73596246235 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 25 Oct 2019 15:51:27 +0200 Subject: [PATCH 16/33] .gitmodules, use https instead of ssh --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 5c797faab..22f0a75fd 100644 --- a/.gitmodules +++ b/.gitmodules @@ -31,4 +31,4 @@ [submodule "hie-bios"] path = hie-bios - url = git@github.com:mpickering/hie-bios.git + url = https://github.com/mpickering/hie-bios.git From ed6d66bf40ae66647c1b0836154b1726c7a3ff38 Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 26 Oct 2019 18:16:28 +0200 Subject: [PATCH 17/33] Fix stack for ghc 8.6.5 --- stack-8.6.5.yaml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 72052c8be..5a631f631 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -13,7 +13,7 @@ extra-deps: - 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 @@ -27,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: From 83c509058d9533bf49c72bf18e67d0842f2d5d4a Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 26 Oct 2019 21:50:33 +0200 Subject: [PATCH 18/33] Bump cabal-helper version to latest master a1c4a37 --- submodules/cabal-helper | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/submodules/cabal-helper b/submodules/cabal-helper index 447814db7..a1c4a3746 160000 --- a/submodules/cabal-helper +++ b/submodules/cabal-helper @@ -1 +1 @@ -Subproject commit 447814db7ecda25afa13a7a699a72c5223649d98 +Subproject commit a1c4a3746311055c2100471aeb98606345496eb3 From cc40b6f016fada772bf685d273f4ede28aab633d Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 28 Oct 2019 16:03:09 +0100 Subject: [PATCH 19/33] Implement perfect match for c-h-h cradle discovery --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 239 +++++++++++++------- 1 file changed, 158 insertions(+), 81 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 73c6f1f1d..71890ed3a 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} module Haskell.Ide.Engine.Cradle (findLocalCradle, isStackCradle) where @@ -14,9 +15,10 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty) import System.FilePath import qualified Data.Map as M -import Data.List (inits, sortOn, isPrefixOf, find) -import Data.Maybe (listToMaybe) +import Data.List (inits, sortOn, isPrefixOf, find, stripPrefix) +import Data.Maybe (listToMaybe, mapMaybe) import Data.Ord (Down(..)) +import Data.Foldable (toList) import System.Exit -- | Find the cradle that the given File belongs to. @@ -31,19 +33,19 @@ import System.Exit -- 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 -> 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` +-- 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"]) . BIOS.actionName . BIOS.cradleOptsProg +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. @@ -63,27 +65,31 @@ findCabalHelperEntryPoint fp = do [] -> case filter isCabalOldProject projs of (x:_) -> return $ Just x [] -> return Nothing - where - -- | Subdirectories of a given FilePath. - -- Directory closest to the FilePath `fp` is the head, - -- followed by one directory taken away. - subdirs :: [FilePath] - subdirs = reverse . map joinPath . tail . inits $ splitDirectories (takeDirectory fp) - isStackProject (Ex ProjLocStackYaml {}) = True - isStackProject _ = False + where + -- | Subdirectories of a given FilePath. + -- Directory closest to the FilePath `fp` is the head, + -- followed by one directory taken away. + subdirs :: [FilePath] + subdirs = reverse . map joinPath . tail . inits + $ splitDirectories (takeDirectory fp) - isCabalNewProject (Ex ProjLocV2Dir {}) = True - isCabalNewProject (Ex ProjLocV2File {}) = True - isCabalNewProject _ = False + isStackProject (Ex ProjLocStackYaml {}) = True + isStackProject _ = False - isCabalOldProject (Ex ProjLocV1Dir {}) = True - isCabalOldProject (Ex ProjLocV1CabalFile {}) = True - isCabalOldProject _ = 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. -- --- TODO: document how and why this works. +-- 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. cabalHelperCradle :: FilePath -> IO Cradle cabalHelperCradle file = do projM <- findCabalHelperEntryPoint file @@ -97,9 +103,7 @@ cabalHelperCradle file = do -- 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 @@ -126,7 +130,9 @@ cabalHelperCradle file = do -- Field `pSourceDir` often has the form `/./plugin` -- but we only want `/plugin` let normalisedPackageLocation = normalise $ pSourceDir realPackage - debugm $ "Cabal-Helper normalisedPackageLocation: " ++ normalisedPackageLocation + debugm + $ "Cabal-Helper normalisedPackageLocation: " + ++ normalisedPackageLocation return Cradle { cradleRootDir = normalisedPackageLocation , cradleOptsProg = @@ -138,49 +144,104 @@ cabalHelperCradle file = do 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 their component. +-- 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 = do + ui <- runQuery (unitInfo unit) env + let components = M.elems (uiComponents ui) + debugm $ "Unit Info: " ++ show ui + case find (fp `partOfComponent`) components of + Nothing -> getComponent env units fp + comp {- Just component -} -> 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 + | Just normFp <- normalisedFp fp (ciSourceDirs comp), normFp `inTargets` getTargets comp fp = True + | otherwise = False 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 -- ^ Absolute directory of the package. - -> FilePath -- ^ FilePath to load. - -> IO (CradleLoadResult ComponentOptions) - 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 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 - let ghcOptions = fs ++ targets - debugm $ "Flags for \"" ++ fp ++ "\": " ++ show ghcOptions - return - $ CradleSuccess - ComponentOptions { componentOptions = ghcOptions - , componentDependencies = [] - } - Nothing -> return - $ CradleFail - $ CradleError (ExitFailure 2) ("Could not obtain flags for " ++ fp) - --- TODO: This can be a complete match, it actually should be -getComponent :: NonEmpty UnitInfo -> FilePath -> Maybe ChComponentInfo -getComponent ui dir = listToMaybe - $ map snd - $ filter (hasParent dir . fst) - $ sortOn (Down . length . fst) - $ concatMap (\ci -> map (, ci) (ciSourceDirs ci)) - $ concat - $ M.elems . uiComponents <$> ui + -- | Assuming a FilePath "src/Lib/Lib.hs" and a ciSourceDirs ["src"] + -- into 'Just "Lib"' + -- >>> normalisedFp "src/Lib/Lib.hs" ["src"] + -- Just "Lib/Lib.hs" + -- + -- >>> normalisedFp "src/Lib/Lib.hs" ["app"] + -- Nothing + normalisedFp file sourceDirs = listToMaybe + $ mapMaybe ((`stripPrefix` file) . addTrailingPathSeparator) sourceDirs + inTargets :: FilePath -> [String] -> Bool + inTargets modFp targets = + -- Change a FilePath of the Form "Haskell/IDE/Engine/Cradle.hs" -> "Haskell.IDE.Engine.Cradle" + let modName = map + (\c -> if isPathSeparator c + then '.' + else c) + (dropExtension modFp) + in any (`elem` targets) [modName, fp] + +-- | Get the flags necessary to compile the given component. getFlags :: ChComponentInfo -> [String] getFlags = ciGhcOptions @@ -190,7 +251,7 @@ getFlags = ciGhcOptions -- 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 'ciCourceDir' to why this contains multiple entries. +-- See the Documentation of 'ciSourceDir' to why this contains multiple entries. getTargets :: ChComponentInfo -> FilePath -> [String] getTargets comp fp = case ciEntrypoints comp of ChSetupEntrypoint {} -> [] @@ -202,11 +263,6 @@ getTargets comp fp = case ciEntrypoints comp of where sourceDirs = find (`isFilePathPrefixOf` fp) (ciSourceDirs comp) -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) @@ -217,7 +273,20 @@ findPackageFor packages fp = packages & listToMaybe -- | 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" +-- True -- This is not really intended. isFilePathPrefixOf :: FilePath -> FilePath -> Bool isFilePathPrefixOf dir fp = normalise dir `isPrefixOf` normalise fp @@ -229,11 +298,11 @@ 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" +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 @@ -243,9 +312,17 @@ 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 - then cradle { BIOS.cradleOptsProg = (BIOS.cradleOptsProg cradle) - { BIOS.runCradle = \fp' -> fmap (addOption fp') <$> BIOS.runCradle (BIOS.cradleOptsProg cradle) fp' } } - else cradle + 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 + addOption fp (BIOS.ComponentOptions os ds) = + BIOS.ComponentOptions (os ++ [fp]) ds From 7e7bd1df95d509ccb4e062fb74a59c128e561b77 Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 28 Oct 2019 16:31:13 +0100 Subject: [PATCH 20/33] Remove unused Language Pragma --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 71890ed3a..fb59bee4d 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} From 92add4e635acc58e2862393a08e00e6c119cbb7f Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 29 Oct 2019 12:59:55 +0100 Subject: [PATCH 21/33] Fix stripFilePath function --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 101 +++++++++++++++----- 1 file changed, 75 insertions(+), 26 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index fb59bee4d..b82ea8df9 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -14,8 +14,8 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty) import System.FilePath import qualified Data.Map as M -import Data.List (inits, sortOn, isPrefixOf, find, stripPrefix) -import Data.Maybe (listToMaybe, mapMaybe) +import Data.List (inits, sortOn, find) +import Data.Maybe (listToMaybe, mapMaybe, isJust) import Data.Ord (Down(..)) import Data.Foldable (toList) import System.Exit @@ -201,7 +201,7 @@ getComponent env (unit:units) fp = do -- 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, +-- * The FilePath, after converted to a module name, -- is a in the Component's Targets, or the FilePath is -- the executable in the component. -- @@ -216,29 +216,36 @@ partOfComponent :: -- | Component to check whether the given FilePath is part of it. ChComponentInfo -> Bool -partOfComponent fp comp - | Just normFp <- normalisedFp fp (ciSourceDirs comp), normFp `inTargets` getTargets comp fp = True - | otherwise = False +partOfComponent fp' comp + | inTargets (ciSourceDirs comp) fp' (getTargets comp fp') + = True + | otherwise + = False where - -- | Assuming a FilePath "src/Lib/Lib.hs" and a ciSourceDirs ["src"] - -- into 'Just "Lib"' - -- >>> normalisedFp "src/Lib/Lib.hs" ["src"] - -- Just "Lib/Lib.hs" - -- - -- >>> normalisedFp "src/Lib/Lib.hs" ["app"] - -- Nothing - normalisedFp file sourceDirs = listToMaybe - $ mapMaybe ((`stripPrefix` file) . addTrailingPathSeparator) sourceDirs + inTargets :: [FilePath] -> FilePath -> [String] -> Bool + inTargets sourceDirs fp targets + | Just relative <- relativeTo fp sourceDirs + = any (`elem` targets) [getModuleName relative, fp] + | otherwise + = False - inTargets :: FilePath -> [String] -> Bool - inTargets modFp targets = - -- Change a FilePath of the Form "Haskell/IDE/Engine/Cradle.hs" -> "Haskell.IDE.Engine.Cradle" - let modName = map - (\c -> if isPathSeparator c - then '.' - else c) - (dropExtension modFp) - in any (`elem` targets) [modName, fp] + getModuleName :: FilePath -> String + getModuleName fp = map + (\c -> if isPathSeparator c + then '.' + else c) + (dropExtension fp) + +-- | Assuming a FilePath "src/Lib/Lib.hs" and a ciSourceDirs ["src"] +-- into 'Just "Lib"' +-- >>> relativeTo "src/Lib/Lib.hs" ["src"] +-- Just "Lib/Lib.hs" +-- +-- >>> relativeTo "src/Lib/Lib.hs" ["app"] +-- Nothing +relativeTo :: FilePath -> [FilePath] -> Maybe FilePath +relativeTo file sourceDirs = listToMaybe + $ mapMaybe (`stripFilePath` file) sourceDirs -- | Get the flags necessary to compile the given component. getFlags :: ChComponentInfo -> [String] @@ -285,9 +292,51 @@ findPackageFor packages fp = packages -- True -- -- >>> isFilePathPrefixOf "./src" "./src-dir/File.hs" --- True -- This is not really intended. +-- False isFilePathPrefixOf :: FilePath -> FilePath -> Bool -isFilePathPrefixOf dir fp = normalise dir `isPrefixOf` normalise fp +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 + projectRootDir :: ProjLoc qt -> FilePath projectRootDir ProjLocV1CabalFile { plProjectDirV1 } = plProjectDirV1 From c45714e30d87537145c3340b61764b8c22789b78 Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 29 Oct 2019 13:59:15 +0100 Subject: [PATCH 22/33] Remove comments from .gitmodules --- .gitmodules | 7 ------- 1 file changed, 7 deletions(-) diff --git a/.gitmodules b/.gitmodules index 22f0a75fd..86958d620 100644 --- a/.gitmodules +++ b/.gitmodules @@ -12,22 +12,15 @@ [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/bubba/cabal-helper.git [submodule "submodules/ghc-mod"] path = submodules/ghc-mod - # url = https://github.com/arbor/ghc-mod.git - # url = https://github.com/bubba/ghc-mod.git url = https://github.com/fendor/ghc-mod.git - #url = https://github.com/mpickering/ghc-mod.git [submodule "hie-bios"] path = hie-bios From 0517eaa3353139bd159c980f03c96145ed1f549b Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 29 Oct 2019 14:42:11 +0100 Subject: [PATCH 23/33] Implement the ancestors function --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 36 +++++++++++++++------ 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index b82ea8df9..4c9f55ef0 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -2,7 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} -module Haskell.Ide.Engine.Cradle (findLocalCradle, isStackCradle) where +module Haskell.Ide.Engine.Cradle where import HIE.Bios as BIOS import HIE.Bios.Types as BIOS @@ -14,7 +14,7 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty) import System.FilePath import qualified Data.Map as M -import Data.List (inits, sortOn, find) +import Data.List (sortOn, find) import Data.Maybe (listToMaybe, mapMaybe, isJust) import Data.Ord (Down(..)) import Data.Foldable (toList) @@ -58,7 +58,7 @@ isStackCradle = (`elem` ["stack", "Cabal-Helper-Stack"]) -- This guessing has no guarantees and may change at any time. findCabalHelperEntryPoint :: FilePath -> IO (Maybe (Ex ProjLoc)) findCabalHelperEntryPoint fp = do - projs <- concat <$> mapM findProjects subdirs + 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 @@ -66,13 +66,6 @@ findCabalHelperEntryPoint fp = do [] -> return Nothing where - -- | Subdirectories of a given FilePath. - -- Directory closest to the FilePath `fp` is the head, - -- followed by one directory taken away. - subdirs :: [FilePath] - subdirs = reverse . map joinPath . tail . inits - $ splitDirectories (takeDirectory fp) - isStackProject (Ex ProjLocStackYaml {}) = True isStackProject _ = False @@ -374,3 +367,26 @@ fixCradle cradle = where addOption fp (BIOS.ComponentOptions os ds) = BIOS.ComponentOptions (os ++ [fp]) ds + +-- | 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 From 97e6617c3f9175f71fc4c8f5ad1af3801c048628 Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 29 Oct 2019 14:47:34 +0100 Subject: [PATCH 24/33] If not package can be found, return none-cradle --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 4c9f55ef0..4dbe43668 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -13,6 +13,7 @@ import Data.Function ((&)) import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty) import System.FilePath +import System.Directory (getCurrentDirectory) import qualified Data.Map as M import Data.List (sortOn, find) import Data.Maybe (listToMaybe, mapMaybe, isJust) @@ -64,7 +65,6 @@ findCabalHelperEntryPoint fp = do [] -> case filter isCabalOldProject projs of (x:_) -> return $ Just x [] -> return Nothing - where isStackProject (Ex ProjLocStackYaml {}) = True isStackProject _ = False @@ -88,7 +88,14 @@ cabalHelperCradle file = do case projM of Nothing -> do errorm $ "Could not find a Project for file: " ++ file - error $ "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 From b775f13c4e5f10bc978ff3afc7d1ea18f7824bde Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 29 Oct 2019 14:57:32 +0100 Subject: [PATCH 25/33] Prefer canonicalisePath over normalise --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 4dbe43668..7c5383dcc 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -13,7 +13,7 @@ import Data.Function ((&)) import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty) import System.FilePath -import System.Directory (getCurrentDirectory) +import System.Directory (getCurrentDirectory, canonicalizePath) import qualified Data.Map as M import Data.List (sortOn, find) import Data.Maybe (listToMaybe, mapMaybe, isJust) @@ -128,7 +128,7 @@ cabalHelperCradle file = do debugm $ "Cabal-Helper cradle package: " ++ show realPackage -- Field `pSourceDir` often has the form `/./plugin` -- but we only want `/plugin` - let normalisedPackageLocation = normalise $ pSourceDir realPackage + normalisedPackageLocation <- canonicalizePath $ pSourceDir realPackage debugm $ "Cabal-Helper normalisedPackageLocation: " ++ normalisedPackageLocation From b4f232645b4af0811ca335e5345b833d297ed4d2 Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 29 Oct 2019 16:25:13 +0100 Subject: [PATCH 26/33] Remove redundant check for stack installation --- src/Haskell/Ide/Engine/Plugin/Base.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Haskell/Ide/Engine/Plugin/Base.hs b/src/Haskell/Ide/Engine/Plugin/Base.hs index bc177f70f..3a0053ecc 100644 --- a/src/Haskell/Ide/Engine/Plugin/Base.hs +++ b/src/Haskell/Ide/Engine/Plugin/Base.hs @@ -109,9 +109,8 @@ hieGhcDisplayVersion = compilerName ++ "-" ++ VERSION_ghc getProjectGhcVersion :: BIOS.Cradle -> IO String getProjectGhcVersion crdl = do - isStackProject <- doesFileExist "stack.yaml" isStackInstalled <- isJust <$> findExecutable "stack" - if isStackCradle crdl && isStackProject && isStackInstalled + if isStackCradle crdl && isStackInstalled then do L.infoM "hie" "Using stack GHC version" catch (tryCommand "stack ghc -- --numeric-version") $ \e -> do From 9ceec1ebad2733d4193c860e3e6f4fe3fc1b158a Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 29 Oct 2019 16:25:52 +0100 Subject: [PATCH 27/33] Move function relativeTo to the bottom of the file --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 22 ++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 7c5383dcc..7684e7917 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -236,17 +236,6 @@ partOfComponent fp' comp else c) (dropExtension fp) --- | Assuming a FilePath "src/Lib/Lib.hs" and a ciSourceDirs ["src"] --- into 'Just "Lib"' --- >>> relativeTo "src/Lib/Lib.hs" ["src"] --- Just "Lib/Lib.hs" --- --- >>> relativeTo "src/Lib/Lib.hs" ["app"] --- Nothing -relativeTo :: FilePath -> [FilePath] -> Maybe FilePath -relativeTo file sourceDirs = listToMaybe - $ mapMaybe (`stripFilePath` file) sourceDirs - -- | Get the flags necessary to compile the given component. getFlags :: ChComponentInfo -> [String] getFlags = ciGhcOptions @@ -397,3 +386,14 @@ ancestors dir | otherwise = dir : ancestors subdir where subdir = takeDirectory dir + +-- | Assuming a FilePath "src/Lib/Lib.hs" and a ciSourceDirs ["src"] +-- into 'Just "Lib"' +-- >>> relativeTo "src/Lib/Lib.hs" ["src"] +-- Just "Lib/Lib.hs" +-- +-- >>> relativeTo "src/Lib/Lib.hs" ["app"] +-- Nothing +relativeTo :: FilePath -> [FilePath] -> Maybe FilePath +relativeTo file sourceDirs = listToMaybe + $ mapMaybe (`stripFilePath` file) sourceDirs From 43096537a521333d573a69b60f6d59f85f1cf838 Mon Sep 17 00:00:00 2001 From: fendor Date: Thu, 31 Oct 2019 14:01:39 +0100 Subject: [PATCH 28/33] Move utility functions to the bottom of Cradle.hs --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 80 +++++++++++---------- 1 file changed, 44 insertions(+), 36 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 7684e7917..8754cf469 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -267,6 +267,50 @@ findPackageFor packages fp = packages & 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: @@ -327,42 +371,6 @@ stripFilePath dir' fp' stripPrefix _ [] = Nothing -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 -- | Obtain all ancestors from a given directory. -- From 9ee81566fc80bd41a476ff11b42b2393ae94655c Mon Sep 17 00:00:00 2001 From: fendor Date: Thu, 31 Oct 2019 16:23:13 +0100 Subject: [PATCH 29/33] Add exhautive documentation for Cabal-Helper-Helper implementation --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 241 ++++++++++++++++++-- 1 file changed, 219 insertions(+), 22 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 8754cf469..0665e6af1 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -38,25 +38,68 @@ findLocalCradle fp = do Just yaml -> fixCradle <$> BIOS.loadCradle yaml Nothing -> cabalHelperCradle fp --- | Check if the given Cradle is a stack cradle. +-- | 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` +-- 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"]) +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. +{- | 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/B/"})) + +or +>>> findCabalHelperEntryPoint "/Foo/B/src/Lib2.hs +Just (Ex (ProjLocV2File { plProjectDirV2 = "/Foo/B/"})) + +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)) @@ -77,11 +120,167 @@ findCabalHelperEntryPoint fp = do 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. +{- | 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. + +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", ..} } + +containing the compiler options retrieved from the package "B", +the unit "exe:B" and the appropriate component. + +=== No explicit executable folder + +Assume the project structure: + / + └── Library/ + ├── cabal.project + ├── stack.yaml + ├── Library.cabal + └── src + ├── Lib.hs + └── Exe.hs + +There probably 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. +It will be correct even if we check 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 @@ -144,13 +343,13 @@ cabalHelperCradle file = do } } where - -- | Cradle Action to query for the ComponentOptions that are needed + -- | 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. + -> 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. @@ -370,8 +569,6 @@ stripFilePath dir' fp' stripPrefix [] ys = Just ys stripPrefix _ [] = Nothing - - -- | Obtain all ancestors from a given directory. -- -- >>> ancestors "a/b/c/d/e" From 232e7d6f42fbc38ad9937c74c2fe28e41dd67b2d Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 1 Nov 2019 14:56:03 +0100 Subject: [PATCH 30/33] Update Documentation, e.g. fix typos and add explanations --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 23 +++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 0665e6af1..7a1317a7b 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -67,7 +67,7 @@ Assume the following project structure: ├── stack.yaml ├── cabal.project ├── src - │ ├── Lib.hs + │ └── Lib.hs └── B/ ├── B.cabal └── src/ @@ -147,6 +147,11 @@ 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: @@ -380,7 +385,8 @@ cabalHelperCradle file = do ("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 their component. +-- 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 @@ -592,13 +598,22 @@ ancestors dir where subdir = takeDirectory dir --- | Assuming a FilePath "src/Lib/Lib.hs" and a ciSourceDirs ["src"] --- into 'Just "Lib"' +-- | 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 From 3ed78331047de5920f7a8d6bb76a7b37b8cbceee Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 5 Nov 2019 17:18:04 +0100 Subject: [PATCH 31/33] Fix typo in documentation of the project root discovery --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index 7a1317a7b..a49b1c086 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -90,11 +90,11 @@ 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/B/"})) +Just (Ex (ProjLocStackYaml { plStackYaml = "/Foo/"})) or >>> findCabalHelperEntryPoint "/Foo/B/src/Lib2.hs -Just (Ex (ProjLocV2File { plProjectDirV2 = "/Foo/B/"})) +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 From a19ff9cb62795264a375b07f82bca01b4c332aa8 Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 5 Nov 2019 18:30:20 +0100 Subject: [PATCH 32/33] Catch exceptions on initialisation and add explicit import list --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 39 +++++++++++++++------ 1 file changed, 28 insertions(+), 11 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index a49b1c086..d53bfc966 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} @@ -7,18 +8,24 @@ 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 -import Distribution.Helper.Discover +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 System.FilePath -import System.Directory (getCurrentDirectory, canonicalizePath) 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. @@ -394,13 +401,23 @@ cabalHelperCradle file = do getComponent :: QueryEnv pt -> [Unit pt] -> FilePath -> IO (Maybe ChComponentInfo) getComponent _env [] _fp = return Nothing -getComponent env (unit:units) fp = do - ui <- runQuery (unitInfo unit) env - let components = M.elems (uiComponents ui) - debugm $ "Unit Info: " ++ show ui - case find (fp `partOfComponent`) components of - Nothing -> getComponent env units fp - comp {- Just component -} -> return comp +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: From 4a80ec3a2dc1ffda60866a22e6d3d1df1408020f Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 5 Nov 2019 18:37:20 +0100 Subject: [PATCH 33/33] Rework comments that do not make sense --- hie-plugin-api/Haskell/Ide/Engine/Cradle.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs index d53bfc966..8b693c725 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Cradle.hs @@ -249,10 +249,11 @@ 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", ..} } +Cradle { cradleRootDir = "/Mono/B/", CradleAction { actionName = "Cabal-Helper-Cabal-V2", ..} } -containing the compiler options retrieved from the package "B", -the unit "exe:B" and the appropriate component. +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 @@ -266,11 +267,13 @@ Assume the project structure: ├── Lib.hs └── Exe.hs -There probably are different dependencies for the library "Lib.hs" and the +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. -It will be correct even if we check the unit "lib:Library" before -the "exe:Library" because the unit "lib:Library" does not expose a module "Exe". +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