diff --git a/doc/maintainers/stack_errors.md b/doc/maintainers/stack_errors.md index 3434b03552..c93f800723 100644 --- a/doc/maintainers/stack_errors.md +++ b/doc/maintainers/stack_errors.md @@ -156,6 +156,12 @@ to take stock of the errors that Stack itself can raise, by reference to the [S-3025] | HoogleDatabaseNotFound ~~~ + - `Stack.IDE.IdePrettyException` + + ~~~haskell + [S-9208] = FileTargetIsInvalidAbsFile + ~~~ + - `Stack.Init.InitException` ~~~haskell diff --git a/package.yaml b/package.yaml index 994b9b4f55..4422efb717 100644 --- a/package.yaml +++ b/package.yaml @@ -179,6 +179,7 @@ library: - Stack.Build.Execute - Stack.Build.ExecuteEnv - Stack.Build.ExecutePackage + - Stack.Build.FileTargets - Stack.Build.Haddock - Stack.Build.Installed - Stack.Build.Source @@ -281,6 +282,7 @@ library: - Stack.Types.Build - Stack.Types.Build.ConstructPlan - Stack.Types.Build.Exception + - Stack.Types.Build.FileTargets - Stack.Types.BuildConfig - Stack.Types.BuildOpts - Stack.Types.BuildOptsCLI @@ -321,6 +323,7 @@ library: - Stack.Types.GhcPkgExe - Stack.Types.GhcPkgId - Stack.Types.GhciOpts + - Stack.Types.GhciPkg - Stack.Types.GlobalOpts - Stack.Types.GlobalOptsMonoid - Stack.Types.HpcReportOpts diff --git a/src/Stack/Build/FileTargets.hs b/src/Stack/Build/FileTargets.hs new file mode 100644 index 0000000000..7d927194fd --- /dev/null +++ b/src/Stack/Build/FileTargets.hs @@ -0,0 +1,517 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Stack.Build.FileTargets +License : BSD-3-Clause +-} + +module Stack.Build.FileTargets + ( findFileTargets + , getAllLocalTargets + , getAllNonLocalTargets + , loadGhciPkgDescs + , getGhciPkgInfos + , optsAndMacros + , wantedPackageComponents + ) where + +import Control.Monad.State.Strict ( State, execState, get, modify ) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.List as L +import qualified Data.Map as Map +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Distribution.PackageDescription as C +import Path ( (), parent, parseRelFile ) +import Path.IO ( doesFileExist ) +import Stack.Build.Installed ( getInstalled ) +import Stack.Constants ( stackProgName' ) +import Stack.Package + ( buildableExes, buildableForeignLibs, buildableSubLibs + , buildableTestSuites, buildableBenchmarks + , hasBuildableMainLibrary + , getPackageOpts, listOfPackageDeps + , packageFromPackageDescription, readDotBuildinfo + , resolvePackageDescription + ) +import Stack.PackageFile ( getPackageFile ) +import Stack.Prelude +import Stack.Types.BuildOpts ( BuildOpts (..) ) +import Stack.Types.BuildOptsCLI ( ApplyCLIFlag (..) ) +import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL ) +import Stack.Types.EnvConfig + ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL ) +import Stack.Types.Build.FileTargets + ( FileTarget (..), unionFileTargets ) +import Stack.Types.GhciPkg + ( GhciPkgDesc (..), GhciPkgInfo (..), unionModuleMaps ) +import Stack.Types.Installed ( InstallMap, InstalledMap ) +import Stack.Types.NamedComponent + ( NamedComponent (..), displayPkgComponent, isCLib ) +import Stack.Types.Package + ( BuildInfoOpts (..), LocalPackage (..), Package (..) + , PackageConfig (..), dotCabalCFilePath, dotCabalGetPath + , dotCabalMainPath + ) +import Stack.Types.PackageFile ( PackageComponentFile (..) ) +import Stack.Types.Platform ( HasPlatform (..) ) +import Stack.Types.SourceMap + ( CommonPackage (..), DepPackage (..), PackageType (..) + , ProjectPackage (..), SourceMap (..), Target (..) + , unionTargets + ) + +-- | Given a list of project packages and a list of absolute paths to files, +-- seek to identify which component of which project package each file relates +-- to (if any). +findFileTargets :: + HasEnvConfig env + => [LocalPackage] + -- ^ All project packages + -> [Path Abs File] + -- ^ File targets to find + -> RIO + env + ( Map PackageName FileTarget + , Maybe + ( Map PackageName [Path Abs File] + -- Dictionary of project package names and lists of file targets + -- associated with the package. + , [Path Abs File] + -- List of file targets not associated with any project package. + ) + ) +findFileTargets locals fileTargets = do + filePackages <- forM locals $ \lp -> do + PackageComponentFile _ compFiles _ _ <- getPackageFile lp.package lp.cabalFP + pure (lp, M.map (map dotCabalGetPath) compFiles) + let foundFileTargetComponents :: + [ ( Path Abs File + -- The target file. + , [ ( PackageName + -- A relevant package. + , NamedComponent + -- A relevant component of the relevant package. + , [Path Abs File] + -- The module source files of the relevant component. + ) + ] + ) + ] + foundFileTargetComponents = map + ( \fp -> + (fp,) + $ L.sort + $ concatMap + ( \(lp, files) -> map + (\(comp, compFiles) -> (lp.package.name, comp, compFiles)) + (filter (elem fp . snd) (M.toList files)) + ) + filePackages + ) + fileTargets + results <- forM foundFileTargetComponents $ \(fp, xs) -> + case xs of + [] -> do + prettyWarnL + [ flow "Couldn't find a component for file target" + , pretty fp <> "." + , flow "This means that the correct GHC options might not be used. \ + \Attempting to load the file anyway." + ] + pure $ Left fp + [x@(name, comp, _)] -> do + prettyInfoL + [ flow "Using configuration for" + , displayPkgComponent (name, comp) + , flow "to load" + , pretty fp + ] + pure $ Right (fp, x) + (x@(name, comp, _):_) -> do + prettyWarn $ + fillSep + [ flow "Multiple components contain file target" + , pretty fp <> ":" + , fillSep $ punctuate "," (map (\(n, c, _) -> displayPkgComponent (n, c)) xs) + ] + <> line + <> fillSep + [ flow "Guessing the first one," + , displayPkgComponent (name, comp) <> "." + ] + pure $ Right (fp, x) + let (extraFiles, associatedFiles) = partitionEithers results + targetMap = + foldl' unionFileTargets M.empty + $ map + (\(_, (name, comp, compFiles)) -> M.singleton name (FileTarget (M.singleton comp compFiles))) + associatedFiles + infoMap = + foldl' (M.unionWith (<>)) M.empty + $ map + (\(fp, (name, _, _)) -> M.singleton name [fp]) + associatedFiles + pure (targetMap, Just (infoMap, extraFiles)) + +-- | Yields all of the targets that are local, those that are directly wanted +-- and those that are extra dependencies to load. +getAllLocalTargets :: + HasEnvConfig env + => Bool + -- ^ Load local dependencies? + -> Map PackageName Target + -- ^ Targets. + -> Maybe (Map PackageName Target) + -- ^ Optional @--main-is@ targets, applicable only to Stack's @ghci@ and + -- @repl@ commands. + -> Map PackageName LocalPackage + -> RIO + env + ( [(PackageName, (Path Abs File, Target))] + -- Directly wanted. + , [(PackageName, (Path Abs File, Target))] + -- Extra dependencies to load. + ) +getAllLocalTargets loadLocalDeps targets0 mainIsTargets localMap = do + -- Use the 'mainIsTargets' as normal targets, for CLI concision. See #1845. + -- This is a little subtle - we need to do the target parsing independently in + -- order to handle the case where no targets are specified. + let targets = maybe targets0 (unionTargets targets0) mainIsTargets + packages <- view $ envConfigL . to (.sourceMap.project) + -- Find all of the packages that are directly demanded by the targets. + let directlyWanted = flip mapMaybe (M.toList packages) $ + \(name, pp) -> + case M.lookup name targets of + Just simpleTargets -> Just (name, (pp.cabalFP, simpleTargets)) + Nothing -> Nothing + -- Figure out + extraLoadDeps = getExtraLoadDeps loadLocalDeps localMap directlyWanted + pure (directlyWanted, extraLoadDeps) + +-- | Yields the names of all the packages where the target is (a) not a project +-- package and (b) a dependency. +getAllNonLocalTargets :: Map PackageName Target -> RIO env [PackageName] +getAllNonLocalTargets targets = do + let isNonLocal (TargetAll PTDependency) = True + isNonLocal _ = False + pure $ map fst $ filter (isNonLocal . snd) (M.toList targets) + +-- | For the given list of local targets, yields the corresponding list of +-- v'GhciPkgDesc'. +loadGhciPkgDescs :: + HasEnvConfig env + => Map ApplyCLIFlag (Map FlagName Bool) + -- ^ Flags specified on the command line. + -> [(PackageName, (Path Abs File, Target))] + -- ^ Local targets. + -> RIO env [GhciPkgDesc] +loadGhciPkgDescs cliFlags localTargets = + forM localTargets $ \(name, (cabalFP, target)) -> + loadGhciPkgDesc cliFlags name cabalFP target + +-- | Load package description information for a ghci target. +loadGhciPkgDesc :: + HasEnvConfig env + => Map ApplyCLIFlag (Map FlagName Bool) + -- ^ Flags specified on the command line. + -> PackageName + -> Path Abs File + -> Target + -> RIO env GhciPkgDesc +loadGhciPkgDesc cliFlags name cabalFP target = do + econfig <- view envConfigL + compilerVersion <- view actualCompilerVersionL + let sm = econfig.sourceMap + -- Currently this source map is being build with + -- the default targets + sourceMapGhcOptions = fromMaybe [] $ + ((.projectCommon.ghcOptions) <$> M.lookup name sm.project) + <|> + ((.depCommon.ghcOptions) <$> M.lookup name sm.deps) + sourceMapCabalConfigOpts = fromMaybe [] $ + ( (.projectCommon.cabalConfigOpts) <$> M.lookup name sm.project) + <|> + ((.depCommon.cabalConfigOpts) <$> M.lookup name sm.deps) + sourceMapFlags = + maybe mempty (.projectCommon.flags) $ M.lookup name sm.project + config = PackageConfig + { enableTests = True + , enableBenchmarks = True + , flags = getCliFlags <> sourceMapFlags + , ghcOptions = sourceMapGhcOptions + , cabalConfigOpts = sourceMapCabalConfigOpts + , compilerVersion = compilerVersion + , platform = view platformL econfig + } + -- TODO we've already parsed this information, otherwise we wouldn't have + -- figured out the cabalFP already. In the future: retain that + -- GenericPackageDescription in the relevant data structures to avoid + -- reparsing. + (gpdio, _name, _cabalFP) <- + loadCabalFilePath (Just stackProgName') (parent cabalFP) + gpkgdesc <- liftIO $ gpdio YesPrintWarnings + + -- Source the package's *.buildinfo file created by configure if any. See + -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters + buildinfofp <- parseRelFile (packageNameString name ++ ".buildinfo") + hasDotBuildinfo <- doesFileExist (parent cabalFP buildinfofp) + let mbuildinfofp + | hasDotBuildinfo = Just (parent cabalFP buildinfofp) + | otherwise = Nothing + mbuildinfo <- forM mbuildinfofp readDotBuildinfo + let pdp = resolvePackageDescription config gpkgdesc + package = + packageFromPackageDescription config (C.genPackageFlags gpkgdesc) $ + maybe pdp (`C.updatePackageDescription` pdp) mbuildinfo + pure GhciPkgDesc + { package + , cabalFP + , target + } + where + -- | All CLI Cabal flags for a package. + getCliFlags :: Map FlagName Bool + getCliFlags = Map.unions + [ Map.findWithDefault Map.empty (ACFByName name) cliFlags + , Map.findWithDefault Map.empty ACFAllProjectPackages cliFlags + ] + +-- | Yields the GHC options that are incompatible with GHCi, the other GHC +-- options (other than those that add the macros file as an @-include@), and +-- the content of the macros file. +optsAndMacros :: + HasEnvConfig env + => Maybe Bool + -- ^ Should hide package options + -> [(PackageName, (Path Abs File, Target))] + -> [GhciPkgInfo] + -> [PackageName] + -> Map PackageName (Seq NamedComponent) + -> RIO + env + ( [String] + -- GHC options that are incompatible with GHCi. + , [String] + -- Other GHC options, other than those that add the macros file as an + -- @-include@. + , ByteString + -- The content of the macros file. + ) +optsAndMacros + hidePackages + targets + pkgs + exposePackages + exposeInternalDep + = do + config <- view configL + let subDepsPackageUnhide pName deps = + if null deps then [] else ["-package", fromPackageName pName] + pkgopts = hidePkgOpts ++ genOpts ++ ghcOpts + shouldHidePackages = fromMaybe + (not (null pkgs && null exposePackages)) + hidePackages + hidePkgOpts = + if shouldHidePackages + then + ["-hide-all-packages"] + -- This is necessary, because current versions of ghci will + -- entirely fail to start if base isn't visible. This is because + -- it tries to use the interpreter to set buffering options on + -- standard IO. + ++ (if null targets then ["-package", "base"] else []) + ++ concatMap + (\n -> ["-package", packageNameString n]) + exposePackages + ++ M.foldMapWithKey subDepsPackageUnhide exposeInternalDep + else [] + oneWordOpts bio + | shouldHidePackages = bio.oneWordOpts ++ bio.packageFlags + | otherwise = bio.oneWordOpts + genOpts = nubOrd + (concatMap (concatMap (oneWordOpts . snd) . (.opts)) pkgs) + (omittedOpts, ghcOpts) = L.partition badForGhci $ + concatMap (concatMap ((.opts) . snd) . (.opts)) pkgs + ++ map + T.unpack + ( fold config.ghcOptionsByCat + -- ^ include everything, locals, and targets + ++ concatMap (getUserOptions . (.name)) pkgs + ) + getUserOptions pkg = + M.findWithDefault [] pkg config.ghcOptionsByName + badForGhci x = + L.isPrefixOf "-O" x + || elem x (words "-debug -threaded -ticky -static -Werror") + bs <- macrosFileContents pkgs + pure + ( omittedOpts + -- This initial "-i" resets the include directories to not + -- include CWD. If there aren't any packages, CWD is included. + , (if null pkgs then id else ("-i" : )) pkgopts + , bs + ) + +-- Adds in intermediate dependencies between ghci targets. Note that it will +-- return a Lib component for these intermediate dependencies even if they don't +-- have a library (but that's fine for the usage within this module). +-- +-- If 'True' is passed for loadAllDeps, this loads all local deps, even if they +-- aren't intermediate. +getExtraLoadDeps :: + Bool + -> Map PackageName LocalPackage + -> [(PackageName, (Path Abs File, Target))] + -> [(PackageName, (Path Abs File, Target))] +getExtraLoadDeps loadAllDeps localMap targets = + M.toList $ + (\mp -> foldl' (flip M.delete) mp (map fst targets)) $ + M.mapMaybe id $ + execState (mapM_ (mapM_ go . getDeps . fst) targets) + (M.fromList (map (second Just) targets)) + where + getDeps :: PackageName -> [PackageName] + getDeps name = + case M.lookup name localMap of + Just lp -> listOfPackageDeps lp.package -- FIXME just Local? + _ -> [] + go :: + PackageName + -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool + go name = do + cache <- get + case (M.lookup name cache, M.lookup name localMap) of + (Just (Just _), _) -> pure True + (Just Nothing, _) | not loadAllDeps -> pure False + (_, Just lp) -> do + let deps = listOfPackageDeps lp.package + shouldLoad <- or <$> mapM go deps + if shouldLoad + then do + modify (M.insert name (Just (lp.cabalFP, TargetComps (S.singleton CLib)))) + pure True + else do + modify (M.insert name Nothing) + pure False + (_, _) -> pure False + +macrosFileContents :: + HasTerm env + => [GhciPkgInfo] + -> RIO env ByteString +macrosFileContents pkgs = do + fps <- fmap (nubOrd . concatMap catMaybes) $ + forM pkgs $ \pkg -> forM pkg.opts $ \(_, bio) -> do + let cabalMacros = bio.cabalMacros + exists <- liftIO $ doesFileExist cabalMacros + if exists + then pure $ Just cabalMacros + else do + prettyWarnL ["Didn't find expected autogen file:", pretty cabalMacros] + pure Nothing + files <- liftIO $ mapM (S8.readFile . toFilePath) fps + pure $ if null files + then mempty + else + S8.concat $ map + (<> "\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") + files + +getGhciPkgInfos :: + HasEnvConfig env + => InstallMap + -> [PackageName] + -> Maybe (Map PackageName [Path Abs File]) + -> [GhciPkgDesc] + -> RIO env [GhciPkgInfo] +getGhciPkgInfos installMap addPkgs mfileTargets localTargets = do + (installedMap, _, _, _) <- getInstalled installMap + let localLibs = + [ desc.package.name + | desc <- localTargets + , hasLocalComp isCLib desc.target + ] + forM localTargets $ \pkgDesc -> + makeGhciPkgInfo installMap installedMap localLibs addPkgs mfileTargets pkgDesc + +hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool +hasLocalComp p t = case t of + TargetComps s -> any p (S.toList s) + TargetAll PTProject -> True + _ -> False + +-- | Make information necessary to load the given package in GHCi. +makeGhciPkgInfo :: + HasEnvConfig env + => InstallMap + -> InstalledMap + -> [PackageName] + -> [PackageName] + -> Maybe (Map PackageName [Path Abs File]) + -> GhciPkgDesc + -> RIO env GhciPkgInfo +makeGhciPkgInfo installMap installedMap locals addPkgs mfileTargets pkgDesc = do + bopts <- view buildOptsL + let pkg = pkgDesc.package + cabalFP = pkgDesc.cabalFP + target = pkgDesc.target + name = pkg.name + (mods, files, opts) <- + getPackageOpts pkg installMap installedMap locals addPkgs cabalFP + let filteredOpts = filterWanted opts + filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted) + allWanted = wantedPackageComponents bopts target pkg + pure GhciPkgInfo + { name + , opts = M.toList filteredOpts + , dir = parent cabalFP + , modules = unionModuleMaps $ + map + ( \(comp, mp) -> M.map + (\fp -> M.singleton fp (S.singleton (pkg.name, comp))) + mp + ) + (M.toList (filterWanted mods)) + , mainIs = M.map (mapMaybe dotCabalMainPath) files + , cFiles = mconcat + (M.elems (filterWanted (M.map (mapMaybe dotCabalCFilePath) files))) + , targetFiles = mfileTargets >>= M.lookup name + , package = pkg + } + +-- | For the given build options, target and package, yields a set of the wanted +-- components. +-- +-- NOTE: this should make the same choices as the components code in +-- 'Stack.Build.Source.loadLocalPackage'. Unfortunately for now we reiterate +-- this logic (differently). +wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent +wantedPackageComponents _ (TargetComps cs) _ = cs +wantedPackageComponents bopts (TargetAll PTProject) pkg = + ( if hasBuildableMainLibrary pkg + then S.insert CLib (S.mapMonotonic CSubLib buildableForeignLibs') + else S.empty + ) + <> S.mapMonotonic CExe buildableExes' + <> S.mapMonotonic CSubLib buildableSubLibs' + <> ( if bopts.tests + then S.mapMonotonic CTest buildableTestSuites' + else S.empty + ) + <> ( if bopts.benchmarks + then S.mapMonotonic CBench buildableBenchmarks' + else S.empty + ) + where + buildableForeignLibs' = buildableForeignLibs pkg + buildableSubLibs' = buildableSubLibs pkg + buildableExes' = buildableExes pkg + buildableTestSuites' = buildableTestSuites pkg + buildableBenchmarks' = buildableBenchmarks pkg +wantedPackageComponents _ _ _ = S.empty diff --git a/src/Stack/CLI.hs b/src/Stack/CLI.hs index 24da64ea85..3aeb020f25 100644 --- a/src/Stack/CLI.hs +++ b/src/Stack/CLI.hs @@ -49,7 +49,7 @@ import Stack.Exec ( SpecialExecCmd (..), execCmd ) import Stack.Eval ( evalCmd ) import Stack.Ghci ( ghciCmd ) import Stack.Hoogle ( hoogleCmd ) -import Stack.IDE ( idePackagesCmd, ideTargetsCmd ) +import Stack.IDE ( ideGhcOptionsCmd, idePackagesCmd, ideTargetsCmd ) import Stack.Init ( initCmd ) import Stack.List ( listCmd ) import Stack.Ls ( lsCmd ) @@ -65,7 +65,8 @@ import Stack.Options.ExecParser ( execOptsParser ) import Stack.Options.GhciParser ( ghciOptsParser ) import Stack.Options.GlobalParser ( globalOptsParser ) import Stack.Options.HpcReportParser ( hpcReportOptsParser ) -import Stack.Options.IdeParser ( idePackagesParser, ideTargetsParser ) +import Stack.Options.IdeParser + ( ideGhcOptionsParser, idePackagesParser, ideTargetsParser ) import Stack.Options.InitParser ( initOptsParser ) import Stack.Options.LsParser ( lsOptsParser ) import Stack.Options.NewParser ( newOptsParser ) @@ -368,6 +369,12 @@ commandLineHandler currentDir progName mExecutablePath isInterpreter = "List all targets or pick component types to list." ideTargetsCmd ideTargetsParser + addCommand' + "ghc-options" + "List, on the standard output stream, GHC options and other \ + \information passed to GHCi for a given Haskell source code file." + ideGhcOptionsCmd + ideGhcOptionsParser ) init = addCommand' diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 86a2eeaccd..a612a05b8d 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -21,9 +21,8 @@ module Stack.Ghci ) where import Control.Monad.Extra ( whenJust ) -import Control.Monad.State.Strict ( State, execState, get, modify ) +import qualified Data.ByteString as BS import Data.ByteString.Builder ( byteString ) -import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as LBS import qualified Data.List as L import Data.List.Extra ( (!?) ) @@ -31,72 +30,63 @@ import qualified Data.Map as Map import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T -import qualified Distribution.PackageDescription as C -import Path ((), parent, parseRelFile ) +import Path ( () ) import Path.Extra ( forgivingResolveFile', toFilePathNoTrailingSep ) import Path.IO ( XdgDirectory (..), doesFileExist, ensureDir, getXdgDir ) import RIO.NonEmpty ( nonEmpty ) import RIO.Process ( exec, withWorkingDir ) import Stack.Build ( buildLocalTargets ) -import Stack.Build.Installed ( getInstalled, toInstallMap ) +import Stack.Build.FileTargets + ( findFileTargets, getAllLocalTargets, getAllNonLocalTargets + , getGhciPkgInfos, loadGhciPkgDescs, optsAndMacros + , wantedPackageComponents + ) +import Stack.Build.Installed ( toInstallMap ) import Stack.Build.Source ( localDependencies, projectLocalPackages ) import Stack.Build.Target ( NeedTargets (..), parseTargets ) import Stack.Constants ( relDirGhciScript, relDirStackProgName, relFileCabalMacrosH - , relFileGhciScript, stackProgName' + , relFileGhciScript ) import Stack.Constants.Config ( ghciDirL, objectInterfaceDirL ) import Stack.Ghci.Script ( GhciScript, ModuleName, cmdAdd, cmdModule , scriptToLazyByteString ) -import Stack.Package - ( buildableExes, buildableForeignLibs, buildableSubLibs - , buildableTestSuites, buildableBenchmarks, getPackageOpts - , hasBuildableMainLibrary, listOfPackageDeps - , packageFromPackageDescription, readDotBuildinfo - , resolvePackageDescription, topSortPackageComponent - ) -import Stack.PackageFile ( getPackageFile ) +import Stack.Package ( topSortPackageComponent ) import Stack.Prelude import Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig ) import Stack.Types.Build.Exception ( BuildPrettyException (..), pprintTargetParseErrors ) +import Stack.Types.Build.FileTargets ( toTarget ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..), configFileL ) import Stack.Types.BuildOpts ( BuildOpts (..) ) import qualified Stack.Types.BuildOpts as BenchmarkOpts ( BenchmarkOpts (..) ) import qualified Stack.Types.BuildOpts as TestOpts ( TestOpts (..) ) import Stack.Types.BuildOptsCLI - ( ApplyCLIFlag (..), BuildOptsCLI (..), defaultBuildOptsCLI ) + ( BuildOptsCLI (..), defaultBuildOptsCLI ) import Stack.Types.CompilerPaths ( CompilerPaths (..), HasCompiler (..) ) import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL ) import Stack.Types.Config.Exception ( ConfigPrettyException (..) ) import Stack.Types.EnvConfig - ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL - , shaPathForBytes - ) + ( EnvConfig (..), HasEnvConfig (..), shaPathForBytes ) import Stack.Types.EnvSettings ( defaultEnvSettings ) import Stack.Types.GhciOpts ( GhciOpts (..) ) -import Stack.Types.Installed ( InstallMap, InstalledMap ) +import Stack.Types.GhciPkg + ( GhciPkgInfo (..), ModuleMap, unionModuleMaps ) import Stack.Types.NamedComponent - ( NamedComponent (..), isCLib, isCSubLib, renderComponentTo - , renderPkgComponent + ( NamedComponent (..), displayPkgComponent, isCSubLib + , renderComponentTo, renderPkgComponent ) import Stack.Types.Package - ( BuildInfoOpts (..), LocalPackage (..), Package (..) - , PackageConfig (..), dotCabalCFilePath, dotCabalGetPath - , dotCabalMainPath - ) -import Stack.Types.PackageFile ( PackageComponentFile (..) ) -import Stack.Types.Platform ( HasPlatform (..) ) + ( BuildInfoOpts (..), LocalPackage (..), Package (..) ) import Stack.Types.Runner ( HasRunner, Runner ) import Stack.Types.SourceMap - ( CommonPackage (..), DepPackage (..), GlobalPackage - , PackageType (..), ProjectPackage (..), SMActual (..) - , SMTargets (..), SMWanted (..), SourceMap (..), Target (..) + ( GlobalPackage, SMActual (..), SMTargets (..), SMWanted (..) + , SourceMap (..), Target (..) ) import System.IO ( putStrLn ) import System.Permissions ( setScriptPerms ) @@ -161,41 +151,6 @@ instance Pretty GhciPrettyException where instance Exception GhciPrettyException --- | Type representing information required to load a package or its components. --- --- NOTE: GhciPkgInfo has paths as list instead of a Set to preserve files order --- as a workaround for bug https://ghc.haskell.org/trac/ghc/ticket/13786 -data GhciPkgInfo = GhciPkgInfo - { name :: !PackageName - , opts :: ![(NamedComponent, BuildInfoOpts)] - , dir :: !(Path Abs Dir) - , modules :: !ModuleMap - , cFiles :: ![Path Abs File] -- ^ C files. - , mainIs :: !(Map NamedComponent [Path Abs File]) - , targetFiles :: !(Maybe [Path Abs File]) - , package :: !Package - } - deriving Show - --- | Type representing loaded package description and related information. -data GhciPkgDesc = GhciPkgDesc - { package :: !Package - , cabalFP :: !(Path Abs File) - , target :: !Target - } - --- | Type synonym representing maps from a module name to a map with all of the --- paths that use that name. Each of those paths is associated with a set of --- components that contain it. - --- The purpose of this complex structure is for use in --- 'checkForDuplicateModules'. -type ModuleMap = - Map ModuleName (Map (Path Abs File) (Set (PackageName, NamedComponent))) - -unionModuleMaps :: [ModuleMap] -> ModuleMap -unionModuleMaps = M.unionsWith (M.unionWith S.union) - -- | Function underlying the @stack ghci@ and @stack repl@ commands. Run GHCi in -- the context of a project. ghciCmd :: GhciOpts -> RIO Runner () @@ -247,10 +202,9 @@ ghci opts = do Left rawFileTargets -> do whenJust mainIsTargets $ \_ -> prettyThrowM Can'tSpecifyFilesAndMainIs -- Figure out targets based on filepath targets - (targetMap, fileInfo, extraFiles) <- findFileTargets locals rawFileTargets - pure (targetMap, Just (fileInfo, extraFiles)) + findFileTargets' locals rawFileTargets -- Get a list of all the local target packages. - localTargets <- getAllLocalTargets opts inputTargets mainIsTargets localMap + localTargets <- getAllLocalTargets' opts inputTargets mainIsTargets localMap -- Get a list of all the non-local target packages. nonLocalTargets <- getAllNonLocalTargets inputTargets let getInternalDependencies target localPackage = @@ -261,7 +215,7 @@ ghci opts = do -- Check if additional package arguments are sensible. addPkgs <- checkAdditionalPackages opts.additionalPackages -- Load package descriptions. - pkgDescs <- loadGhciPkgDescs buildOptsCLI localTargets + pkgDescs <- loadGhciPkgDescs buildOptsCLI.flags localTargets -- If necessary, ask user about which main module to load. bopts <- view buildOptsL mainFile <- if opts.noLoadModules @@ -340,94 +294,43 @@ parseMainIsTargets buildOptsCLI sma mtarget = forM mtarget $ \target -> do targets <- parseTargets AllowNoTargets False boptsCLI sma pure targets.targets --- | Display PackageName + NamedComponent -displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc -displayPkgComponent = - style PkgComponent . fromString . T.unpack . renderPkgComponent - -findFileTargets :: +-- | Given a list of project packages and a list of absolute paths to files, +-- seek to identify which component of which project package each file relates +-- to (if any). +findFileTargets' :: HasEnvConfig env => [LocalPackage] + -- ^ All project packages -> [Path Abs File] - -> RIO env (Map PackageName Target, Map PackageName [Path Abs File], [Path Abs File]) -findFileTargets locals fileTargets = do - filePackages <- forM locals $ \lp -> do - PackageComponentFile _ compFiles _ _ <- getPackageFile lp.package lp.cabalFP - pure (lp, M.map (map dotCabalGetPath) compFiles) - let foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])] - foundFileTargetComponents = - map (\fp -> (fp, ) $ L.sort $ - concatMap (\(lp, files) -> map ((lp.package.name,) . fst) - (filter (elem fp . snd) (M.toList files)) - ) filePackages - ) fileTargets - results <- forM foundFileTargetComponents $ \(fp, xs) -> - case xs of - [] -> do - prettyWarnL - [ flow "Couldn't find a component for file target" - , pretty fp <> "." - , flow "This means that the correct GHC options might not be used. \ - \Attempting to load the file anyway." - ] - pure $ Left fp - [x] -> do - prettyInfoL - [ flow "Using configuration for" - , displayPkgComponent x - , flow "to load" - , pretty fp - ] - pure $ Right (fp, x) - (x:_) -> do - prettyWarn $ - fillSep - [ flow "Multiple components contain file target" - , pretty fp <> ":" - , fillSep $ punctuate "," (map displayPkgComponent xs) - ] - <> line - <> fillSep - [ flow "Guessing the first one," - , displayPkgComponent x <> "." - ] - pure $ Right (fp, x) - let (extraFiles, associatedFiles) = partitionEithers results - targetMap = - foldl' unionTargets M.empty $ - map (\(_, (name, comp)) -> M.singleton name (TargetComps (S.singleton comp))) - associatedFiles - infoMap = - foldl' (M.unionWith (<>)) M.empty $ - map (\(fp, (name, _)) -> M.singleton name [fp]) - associatedFiles - pure (targetMap, infoMap, extraFiles) - -getAllLocalTargets :: + -- ^ File targets to find + -> RIO + env + ( Map PackageName Target + , Maybe + ( Map PackageName [Path Abs File] + -- Dictionary of project package names and lists of file targets + -- associated with the package. + , [Path Abs File] + -- List of file targets not associated with any project package. + ) + ) +findFileTargets' locals fileTargets = + first ( Map.map toTarget ) <$> findFileTargets locals fileTargets + +getAllLocalTargets' :: HasEnvConfig env => GhciOpts -> Map PackageName Target -> Maybe (Map PackageName Target) -> Map PackageName LocalPackage -> RIO env [(PackageName, (Path Abs File, Target))] -getAllLocalTargets ghciOpts targets0 mainIsTargets localMap = do - -- Use the 'mainIsTargets' as normal targets, for CLI concision. See - -- #1845. This is a little subtle - we need to do the target parsing - -- independently in order to handle the case where no targets are - -- specified. - let targets = maybe targets0 (unionTargets targets0) mainIsTargets - packages <- view $ envConfigL . to (.sourceMap.project) - -- Find all of the packages that are directly demanded by the - -- targets. - let directlyWanted = flip mapMaybe (M.toList packages) $ - \(name, pp) -> - case M.lookup name targets of - Just simpleTargets -> Just (name, (pp.cabalFP, simpleTargets)) - Nothing -> Nothing - -- Figure out - let extraLoadDeps = - getExtraLoadDeps ghciOpts.loadLocalDeps localMap directlyWanted - if null extraLoadDeps +getAllLocalTargets' ghciOpts targets0 mainIsTargets localMap = do + (directlyWanted, extraLoadDeps) <- getAllLocalTargets + ghciOpts.loadLocalDeps + targets0 + mainIsTargets + localMap + if null extraLoadDeps then pure directlyWanted else do let extraList' = @@ -451,14 +354,6 @@ getAllLocalTargets ghciOpts targets0 mainIsTargets localMap = do ) pure (directlyWanted ++ extraLoadDeps) -getAllNonLocalTargets :: - Map PackageName Target - -> RIO env [PackageName] -getAllNonLocalTargets targets = do - let isNonLocal (TargetAll PTDependency) = True - isNonLocal _ = False - pure $ map fst $ filter (isNonLocal . snd) (M.toList targets) - buildDepsAndInitialSteps :: HasEnvConfig env => GhciOpts -> [Text] -> RIO env () buildDepsAndInitialSteps ghciOpts localTargets = do let targets = localTargets ++ map T.pack ghciOpts.additionalPackages @@ -501,45 +396,13 @@ runGhci exposePackages exposeInternalDep = do - config <- view configL - let subDepsPackageUnhide pName deps = - if null deps then [] else ["-package", fromPackageName pName] - pkgopts = hidePkgOpts ++ genOpts ++ ghcOpts - shouldHidePackages = fromMaybe - (not (null pkgs && null exposePackages)) - ghciOpts.hidePackages - hidePkgOpts = - if shouldHidePackages - then - ["-hide-all-packages"] - -- This is necessary, because current versions of ghci will - -- entirely fail to start if base isn't visible. This is because - -- it tries to use the interpreter to set buffering options on - -- standard IO. - ++ (if null targets then ["-package", "base"] else []) - ++ concatMap - (\n -> ["-package", packageNameString n]) - exposePackages - ++ M.foldMapWithKey subDepsPackageUnhide exposeInternalDep - else [] - oneWordOpts bio - | shouldHidePackages = bio.oneWordOpts ++ bio.packageFlags - | otherwise = bio.oneWordOpts - genOpts = nubOrd - (concatMap (concatMap (oneWordOpts . snd) . (.opts)) pkgs) - (omittedOpts, ghcOpts) = L.partition badForGhci $ - concatMap (concatMap ((.opts) . snd) . (.opts)) pkgs - ++ map - T.unpack - ( fold config.ghcOptionsByCat - -- ^ include everything, locals, and targets - ++ concatMap (getUserOptions . (.name)) pkgs - ) - getUserOptions pkg = - M.findWithDefault [] pkg config.ghcOptionsByName - badForGhci x = - L.isPrefixOf "-O" x - || elem x (words "-debug -threaded -ticky -static -Werror") + (omittedOpts, pkgopts, macros) <- + optsAndMacros + ghciOpts.hidePackages + targets + pkgs + exposePackages + exposeInternalDep unless (null omittedOpts) $ prettyWarn $ fillSep @@ -562,14 +425,12 @@ runGhci compilerExeName <- view $ compilerPathsL . to (.compiler) . to toFilePath let execGhci extras = do + config <- view configL menv <- liftIO $ config.processContextSettings defaultEnvSettings withPackageWorkingDir $ withProcessContext menv $ exec (fromMaybe compilerExeName ghciOpts.ghcCommand) ( ("--interactive" : ) $ - -- This initial "-i" resets the include directories to not - -- include CWD. If there aren't any packages, CWD is included. - (if null pkgs then id else ("-i" : )) $ odir <> pkgopts <> extras @@ -591,7 +452,7 @@ runGhci ghciDir <- view ghciDirL ensureDir ghciDir ensureDir tmpDirectory - macrosOptions <- writeMacrosFile ghciDir pkgs + macrosOptions <- writeMacrosFile ghciDir macros if ghciOpts.noLoadModules then execGhci macrosOptions else do @@ -605,24 +466,14 @@ runGhci writeMacrosFile :: HasTerm env => Path Abs Dir - -> [GhciPkgInfo] + -> ByteString -> RIO env [String] -writeMacrosFile outputDirectory pkgs = do - fps <- fmap (nubOrd . concatMap catMaybes) $ - forM pkgs $ \pkg -> forM pkg.opts $ \(_, bio) -> do - let cabalMacros = bio.cabalMacros - exists <- liftIO $ doesFileExist cabalMacros - if exists - then pure $ Just cabalMacros - else do - prettyWarnL ["Didn't find expected autogen file:", pretty cabalMacros] - pure Nothing - files <- liftIO $ mapM (S8.readFile . toFilePath) fps - if null files then pure [] else do - out <- liftIO $ writeHashedFile outputDirectory relFileCabalMacrosH $ - S8.concat $ map - (<> "\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") - files +writeMacrosFile outputDirectory bs = do + if BS.null bs + then + pure [] + else do + out <- liftIO $ writeHashedFile outputDirectory relFileCabalMacrosH bs pure ["-optP-include", "-optP" <> toFilePath out] writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m [String] @@ -812,166 +663,6 @@ figureOutMainFile bopts mainIsTargets targets0 packages = , fromPackageName pkg <> ":" <> renderComponentTo comp ] -loadGhciPkgDescs :: - HasEnvConfig env - => BuildOptsCLI - -> [(PackageName, (Path Abs File, Target))] - -> RIO env [GhciPkgDesc] -loadGhciPkgDescs buildOptsCLI localTargets = - forM localTargets $ \(name, (cabalFP, target)) -> - loadGhciPkgDesc buildOptsCLI name cabalFP target - --- | Load package description information for a ghci target. -loadGhciPkgDesc :: - HasEnvConfig env - => BuildOptsCLI - -> PackageName - -> Path Abs File - -> Target - -> RIO env GhciPkgDesc -loadGhciPkgDesc buildOptsCLI name cabalFP target = do - econfig <- view envConfigL - compilerVersion <- view actualCompilerVersionL - let sm = econfig.sourceMap - -- Currently this source map is being build with - -- the default targets - sourceMapGhcOptions = fromMaybe [] $ - ((.projectCommon.ghcOptions) <$> M.lookup name sm.project) - <|> - ((.depCommon.ghcOptions) <$> M.lookup name sm.deps) - sourceMapCabalConfigOpts = fromMaybe [] $ - ( (.projectCommon.cabalConfigOpts) <$> M.lookup name sm.project) - <|> - ((.depCommon.cabalConfigOpts) <$> M.lookup name sm.deps) - sourceMapFlags = - maybe mempty (.projectCommon.flags) $ M.lookup name sm.project - config = PackageConfig - { enableTests = True - , enableBenchmarks = True - , flags = getCliFlags <> sourceMapFlags - , ghcOptions = sourceMapGhcOptions - , cabalConfigOpts = sourceMapCabalConfigOpts - , compilerVersion = compilerVersion - , platform = view platformL econfig - } - -- TODO we've already parsed this information, otherwise we wouldn't have - -- figured out the cabalFP already. In the future: retain that - -- GenericPackageDescription in the relevant data structures to avoid - -- reparsing. - (gpdio, _name, _cabalFP) <- - loadCabalFilePath (Just stackProgName') (parent cabalFP) - gpkgdesc <- liftIO $ gpdio YesPrintWarnings - - -- Source the package's *.buildinfo file created by configure if any. See - -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters - buildinfofp <- parseRelFile (packageNameString name ++ ".buildinfo") - hasDotBuildinfo <- doesFileExist (parent cabalFP buildinfofp) - let mbuildinfofp - | hasDotBuildinfo = Just (parent cabalFP buildinfofp) - | otherwise = Nothing - mbuildinfo <- forM mbuildinfofp readDotBuildinfo - let pdp = resolvePackageDescription config gpkgdesc - package = - packageFromPackageDescription config (C.genPackageFlags gpkgdesc) $ - maybe pdp (`C.updatePackageDescription` pdp) mbuildinfo - pure GhciPkgDesc - { package - , cabalFP - , target - } - where - cliFlags = buildOptsCLI.flags - -- | All CLI Cabal flags for a package. - getCliFlags :: Map FlagName Bool - getCliFlags = Map.unions - [ Map.findWithDefault Map.empty (ACFByName name) cliFlags - , Map.findWithDefault Map.empty ACFAllProjectPackages cliFlags - ] - -getGhciPkgInfos :: - HasEnvConfig env - => InstallMap - -> [PackageName] - -> Maybe (Map PackageName [Path Abs File]) - -> [GhciPkgDesc] - -> RIO env [GhciPkgInfo] -getGhciPkgInfos installMap addPkgs mfileTargets localTargets = do - (installedMap, _, _, _) <- getInstalled installMap - let localLibs = - [ desc.package.name - | desc <- localTargets - , hasLocalComp isCLib desc.target - ] - forM localTargets $ \pkgDesc -> - makeGhciPkgInfo installMap installedMap localLibs addPkgs mfileTargets pkgDesc - --- | Make information necessary to load the given package in GHCi. -makeGhciPkgInfo :: - HasEnvConfig env - => InstallMap - -> InstalledMap - -> [PackageName] - -> [PackageName] - -> Maybe (Map PackageName [Path Abs File]) - -> GhciPkgDesc - -> RIO env GhciPkgInfo -makeGhciPkgInfo installMap installedMap locals addPkgs mfileTargets pkgDesc = do - bopts <- view buildOptsL - let pkg = pkgDesc.package - cabalFP = pkgDesc.cabalFP - target = pkgDesc.target - name = pkg.name - (mods, files, opts) <- - getPackageOpts pkg installMap installedMap locals addPkgs cabalFP - let filteredOpts = filterWanted opts - filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted) - allWanted = wantedPackageComponents bopts target pkg - pure GhciPkgInfo - { name - , opts = M.toList filteredOpts - , dir = parent cabalFP - , modules = unionModuleMaps $ - map - ( \(comp, mp) -> M.map - (\fp -> M.singleton fp (S.singleton (pkg.name, comp))) - mp - ) - (M.toList (filterWanted mods)) - , mainIs = M.map (mapMaybe dotCabalMainPath) files - , cFiles = mconcat - (M.elems (filterWanted (M.map (mapMaybe dotCabalCFilePath) files))) - , targetFiles = mfileTargets >>= M.lookup name - , package = pkg - } - --- NOTE: this should make the same choices as the components code in --- 'loadLocalPackage'. Unfortunately for now we reiterate this logic --- (differently). -wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent -wantedPackageComponents _ (TargetComps cs) _ = cs -wantedPackageComponents bopts (TargetAll PTProject) pkg = - ( if hasBuildableMainLibrary pkg - then S.insert CLib (S.mapMonotonic CSubLib buildableForeignLibs') - else S.empty - ) - <> S.mapMonotonic CExe buildableExes' - <> S.mapMonotonic CSubLib buildableSubLibs' - <> ( if bopts.tests - then S.mapMonotonic CTest buildableTestSuites' - else S.empty - ) - <> ( if bopts.benchmarks - then S.mapMonotonic CBench buildableBenchmarks' - else S.empty - ) - where - buildableForeignLibs' = buildableForeignLibs pkg - buildableSubLibs' = buildableSubLibs pkg - buildableExes' = buildableExes pkg - buildableTestSuites' = buildableTestSuites pkg - buildableBenchmarks' = buildableBenchmarks pkg -wantedPackageComponents _ _ _ = S.empty - checkForIssues :: HasTerm env => [GhciPkgInfo] -> RIO env () checkForIssues pkgs = when (length pkgs > 1) $ do @@ -1182,60 +873,3 @@ targetWarnings localTargets nonLocalTargets mfileTargets = do ] , "" ] - --- Adds in intermediate dependencies between ghci targets. Note that it will --- return a Lib component for these intermediate dependencies even if they don't --- have a library (but that's fine for the usage within this module). --- --- If 'True' is passed for loadAllDeps, this loads all local deps, even if they --- aren't intermediate. -getExtraLoadDeps :: - Bool - -> Map PackageName LocalPackage - -> [(PackageName, (Path Abs File, Target))] - -> [(PackageName, (Path Abs File, Target))] -getExtraLoadDeps loadAllDeps localMap targets = - M.toList $ - (\mp -> foldl' (flip M.delete) mp (map fst targets)) $ - M.mapMaybe id $ - execState (mapM_ (mapM_ go . getDeps . fst) targets) - (M.fromList (map (second Just) targets)) - where - getDeps :: PackageName -> [PackageName] - getDeps name = - case M.lookup name localMap of - Just lp -> listOfPackageDeps lp.package -- FIXME just Local? - _ -> [] - go :: - PackageName - -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool - go name = do - cache <- get - case (M.lookup name cache, M.lookup name localMap) of - (Just (Just _), _) -> pure True - (Just Nothing, _) | not loadAllDeps -> pure False - (_, Just lp) -> do - let deps = listOfPackageDeps lp.package - shouldLoad <- or <$> mapM go deps - if shouldLoad - then do - modify (M.insert name (Just (lp.cabalFP, TargetComps (S.singleton CLib)))) - pure True - else do - modify (M.insert name Nothing) - pure False - (_, _) -> pure False - -unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target -unionTargets = M.unionWith $ \l r -> case (l, r) of - (TargetAll PTDependency, _) -> r - (TargetComps sl, TargetComps sr) -> TargetComps (S.union sl sr) - (TargetComps _, TargetAll PTProject) -> TargetAll PTProject - (TargetComps _, _) -> l - (TargetAll PTProject, _) -> TargetAll PTProject - -hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool -hasLocalComp p t = case t of - TargetComps s -> any p (S.toList s) - TargetAll PTProject -> True - _ -> False diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs index 9de8fea9f6..9ff448d230 100644 --- a/src/Stack/IDE.hs +++ b/src/Stack/IDE.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} {-| Module : Stack.IDE @@ -11,32 +13,68 @@ Types and functions related to Stack's @ide@ command. -} module Stack.IDE - ( OutputStream (..) - , ListPackagesCmd (..) - , idePackagesCmd + ( idePackagesCmd , ideTargetsCmd - , listPackages - , listTargets + , ideGhcOptionsCmd ) where +import qualified Data.ByteString as BS import qualified Data.Map as Map +import qualified Data.Map.Strict as M import qualified Data.Set as Set import qualified Data.Text as T import Data.Tuple ( swap ) +import Stack.Build.FileTargets + ( findFileTargets, getAllLocalTargets, getAllNonLocalTargets + , getGhciPkgInfos, loadGhciPkgDescs, optsAndMacros + ) +import Stack.Build.Installed ( toInstallMap ) +import Stack.Build.Source ( localDependencies, projectLocalPackages ) +import Stack.Build.Target ( NeedTargets (..) ) +import Stack.Package ( topSortPackageComponent ) +import Path.Extra ( forgivingResolveFile' ) import Stack.Prelude import Stack.Runners - ( ShouldReexec (..), withBuildConfig, withConfig ) + ( ShouldReexec (..), withBuildConfig, withConfig + , withEnvConfig + ) +import Stack.Types.Build.FileTargets ( FileTarget (..), toTarget ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..) ) +import Stack.Types.BuildOpts ( BuildOpts (..) ) +import qualified Stack.Types.BuildOpts as BenchmarkOpts ( BenchmarkOpts (..) ) +import qualified Stack.Types.BuildOpts as TestOpts ( TestOpts (..) ) +import Stack.Types.BuildOptsCLI + ( BuildOptsCLI (..), defaultBuildOptsCLI ) +import Stack.Types.Config ( buildOptsL ) +import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..) ) import Stack.Types.IdeOpts ( ListPackagesCmd (..), OutputStream (..) ) import Stack.Types.NamedComponent - ( NamedComponent, isCBench, isCExe, isCTest + ( NamedComponent, isCBench, isCExe, isCSubLib, isCTest , renderPkgComponent ) +import Stack.Types.Package ( LocalPackage (..), Package (..) ) import Stack.Types.Runner ( Runner ) import Stack.Types.SourceMap ( ProjectPackage (..), SMWanted (..), ppComponentsMaybe ) -import System.IO ( putStrLn ) +import System.IO ( print, putStrLn ) + +-- | Type representing \'pretty\' exceptions thrown by functions exported by the +-- "Stack.IDE" module. +newtype IdePrettyException + = FileTargetIsInvalidAbsFile String + deriving (Show, Typeable) + +instance Pretty IdePrettyException where + pretty (FileTargetIsInvalidAbsFile name) = + "[S-9208]" + <> line + <> fillSep + [ flow "Cannot work out a valid path for file target" + , style File (fromString name) <> "." + ] + +instance Exception IdePrettyException -- | Function underlying the @stack ide packages@ command. List packages in the -- project. @@ -93,3 +131,74 @@ listTargets stream isCompType = do toNameAndComponent pkgName' = fmap (map (pkgName',) . Set.toList) . ppComponentsMaybe (\x -> if isCompType x then Just x else Nothing) + +-- | Function underlying the @stack ide ghc-options@ command. +ideGhcOptionsCmd :: Text -> RIO Runner () +ideGhcOptionsCmd rawTarget = + let boptsCLI = defaultBuildOptsCLI { initialBuildSteps = True } + in withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do + bopts <- view buildOptsL + -- override env so running of tests and benchmarks is disabled + let boptsLocal = bopts + { testOpts = bopts.testOpts { TestOpts.runTests = False } + , benchmarkOpts = + bopts.benchmarkOpts { BenchmarkOpts.runBenchmarks = False } + } + local (set buildOptsL boptsLocal) (ideGhcOptions rawTarget) + +ideGhcOptions :: HasEnvConfig env => Text -> RIO env () +ideGhcOptions rawTarget = do + sourceMap <- view $ envConfigL . to (.sourceMap) + installMap <- toInstallMap sourceMap + locals <- projectLocalPackages + depLocals <- localDependencies + let localMap = M.fromList [(lp.package.name, lp) | lp <- locals ++ depLocals] + -- Parse to either file targets or build targets + (inputTargets', mfileTargets) <- processRawTarget rawTarget >>= maybe + (pure (mempty, Nothing)) + -- Figure out targets based on file target + (findFileTargets locals . pure) + let inputTargets = Map.map toTarget inputTargets' + -- Get a list of all the local target packages. + (directlyWanted, extraLoadDeps) <- + getAllLocalTargets True inputTargets Nothing localMap + -- Get a list of all the non-local target packages. + nonLocalTargets <- getAllNonLocalTargets inputTargets + let localTargets = directlyWanted <> extraLoadDeps + getInternalDependencies target localPackage = + topSortPackageComponent localPackage.package target False + internalDependencies = + M.intersectionWith getInternalDependencies inputTargets localMap + relevantDependencies = M.filter (any isCSubLib) internalDependencies + -- Load package descriptions. + pkgDescs <- loadGhciPkgDescs mempty localTargets + pkgs <- getGhciPkgInfos installMap [] (fmap fst mfileTargets) pkgDescs + (omittedOpts, pkgopts, macros) <- + optsAndMacros + Nothing + localTargets + pkgs + nonLocalTargets + relevantDependencies + let outputDivider = liftIO $ putStrLn "---" + outputDivider + mapM_ (liftIO . print) $ + concatMap (\(FileTarget t) -> concat $ Map.elems t) (Map.elems inputTargets') + outputDivider + mapM_ (liftIO . putStrLn) pkgopts + outputDivider + liftIO $ BS.putStr macros + outputDivider + mapM_ (liftIO . putStrLn) omittedOpts + outputDivider + +processRawTarget :: HasEnvConfig env => Text -> RIO env (Maybe (Path Abs File)) +processRawTarget rawTarget = + if ".hs" `T.isSuffixOf` rawTarget || ".lhs" `T.isSuffixOf` rawTarget + then + forgivingResolveFile' rawTarget' >>= maybe + (prettyThrowM $ FileTargetIsInvalidAbsFile rawTarget') + (pure . Just) + else pure Nothing + where + rawTarget' = T.unpack rawTarget diff --git a/src/Stack/Options/IdeParser.hs b/src/Stack/Options/IdeParser.hs index 14fb2a081e..1701bb229a 100644 --- a/src/Stack/Options/IdeParser.hs +++ b/src/Stack/Options/IdeParser.hs @@ -12,9 +12,13 @@ Functions to parse command line arguments for Stack's @ide@ commands. module Stack.Options.IdeParser ( idePackagesParser , ideTargetsParser + , ideGhcOptionsParser ) where -import Options.Applicative ( Parser, flag, help, long, switch ) +import Options.Applicative + ( Parser, completer, flag, help, long, metavar, switch ) +import Options.Applicative.Builder.Extra + ( fileExtCompleter, textArgument ) import Stack.Prelude import Stack.Types.IdeOpts ( ListPackagesCmd (..), OutputStream (..) ) @@ -27,6 +31,13 @@ ideTargetsParser :: Parser ((Bool, Bool, Bool), OutputStream) ideTargetsParser = (,) <$> ((,,) <$> exeFlag <*> testFlag <*> benchFlag) <*> outputFlag +-- | Parse command line arguments for Stack's @ide ghc-options@ command. +ideGhcOptionsParser :: Parser Text +ideGhcOptionsParser = textArgument + ( metavar "FILE" + <> completer (fileExtCompleter [".hs", ".lhs"]) + ) + outputFlag :: Parser OutputStream outputFlag = flag OutputLogInfo diff --git a/src/Stack/PackageFile.hs b/src/Stack/PackageFile.hs index 0ba4ca3fc4..954ac5a310 100644 --- a/src/Stack/PackageFile.hs +++ b/src/Stack/PackageFile.hs @@ -132,6 +132,7 @@ getPackageFile :: ( HasEnvConfig s, MonadReader s m, MonadThrow m, MonadUnliftIO m ) => Package -> Path Abs File + -- ^ The Cabal file describing the package. -> m PackageComponentFile getPackageFile pkg cabalFP = debugBracket ("getPackageFiles" <+> pretty cabalFP) $ do diff --git a/src/Stack/Types/Build/FileTargets.hs b/src/Stack/Types/Build/FileTargets.hs new file mode 100644 index 0000000000..b61e0075a8 --- /dev/null +++ b/src/Stack/Types/Build/FileTargets.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Stack.Types.Build.FileTargets +License : BSD-3-Clause +-} + +module Stack.Types.Build.FileTargets + ( FileTarget (..) + , unionFileTargets + , toTarget + ) where + +import qualified Data.Map as Map +import Stack.Prelude +import Stack.Types.NamedComponent ( NamedComponent ) +import Stack.Types.SourceMap ( Target (..) ) + +-- Type representing information about file targets that are associated with a +-- project package. +newtype FileTarget = FileTarget (Map NamedComponent [Path Abs File]) + +-- | Combine file targets. +unionFileTargets :: + Ord k + => Map k FileTarget + -> Map k FileTarget + -> Map k FileTarget +unionFileTargets = Map.unionWith $ \(FileTarget l) (FileTarget r) -> + FileTarget (Map.unionWith (<>) l r) + +-- | For the given v'FileTarget', yield the corresponding 'Target'. +toTarget :: FileTarget -> Target +toTarget (FileTarget t) = TargetComps $ Map.keysSet t diff --git a/src/Stack/Types/GhciPkg.hs b/src/Stack/Types/GhciPkg.hs new file mode 100644 index 0000000000..b33b70e9da --- /dev/null +++ b/src/Stack/Types/GhciPkg.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} + +{-| +Module : Stack.Types.GhciPkg +License : BSD-3-Clause +-} + +module Stack.Types.GhciPkg + ( GhciPkgInfo (..) + , ModuleMap + , unionModuleMaps + , GhciPkgDesc (..) + ) where + +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Stack.Ghci.Script ( ModuleName ) +import Stack.Prelude +import Stack.Types.NamedComponent ( NamedComponent (..) ) +import Stack.Types.Package ( BuildInfoOpts, Package ) +import Stack.Types.SourceMap ( Target ) + +-- | Type representing information required to load a package or its components. +-- +-- NOTE: v'GhciPkgInfo' has paths as list instead of a t'Data.Set.Set' to +-- preserve the order of files as a workaround for bug +-- https://ghc.haskell.org/trac/ghc/ticket/13786 +data GhciPkgInfo = GhciPkgInfo + { name :: !PackageName + , opts :: ![(NamedComponent, BuildInfoOpts)] + , dir :: !(Path Abs Dir) + , modules :: !ModuleMap + , cFiles :: ![Path Abs File] -- ^ C files. + , mainIs :: !(Map NamedComponent [Path Abs File]) + , targetFiles :: !(Maybe [Path Abs File]) + , package :: !Package + } + deriving Show + +-- | Type synonym representing maps from a module name to a map with all of the +-- paths that use that name. Each of those paths is associated with a set of +-- components that contain it. + +-- The purpose of this complex structure is for use +-- in 'checkForDuplicateModules'. +type ModuleMap = + Map ModuleName (Map (Path Abs File) (Set (PackageName, NamedComponent))) + +unionModuleMaps :: [ModuleMap] -> ModuleMap +unionModuleMaps = M.unionsWith (M.unionWith S.union) + +-- | Type representing loaded package description and related information. +data GhciPkgDesc = GhciPkgDesc + { package :: !Package + , cabalFP :: !(Path Abs File) + , target :: !Target + } diff --git a/src/Stack/Types/NamedComponent.hs b/src/Stack/Types/NamedComponent.hs index dac24005e8..e184c0eae9 100644 --- a/src/Stack/Types/NamedComponent.hs +++ b/src/Stack/Types/NamedComponent.hs @@ -16,6 +16,7 @@ module Stack.Types.NamedComponent , renderComponentTo , renderPkgComponents , renderPkgComponent + , displayPkgComponent , exeComponents , testComponents , benchComponents @@ -80,6 +81,11 @@ renderPkgComponent :: (PackageName, NamedComponent) -> Text renderPkgComponent (pkg, comp) = fromPackageName pkg <> ":" <> renderComponent comp +-- | Display PackageName + NamedComponent +displayPkgComponent :: (PackageName, NamedComponent) -> StyleDoc +displayPkgComponent = + style PkgComponent . fromString . T.unpack . renderPkgComponent + exeComponents :: Set NamedComponent -> Set StackUnqualCompName exeComponents = Set.fromList . mapMaybe mExeName . Set.toList where diff --git a/src/Stack/Types/SourceMap.hs b/src/Stack/Types/SourceMap.hs index 699319ccfc..853a162131 100644 --- a/src/Stack/Types/SourceMap.hs +++ b/src/Stack/Types/SourceMap.hs @@ -17,6 +17,7 @@ module Stack.Types.SourceMap SMWanted (..) , SMActual (..) , Target (..) + , unionTargets , PackageType (..) , SMTargets (..) , SourceMap (..) @@ -37,6 +38,7 @@ module Stack.Types.SourceMap , smRelDir ) where +import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T import Distribution.PackageDescription ( GenericPackageDescription ) @@ -109,7 +111,16 @@ data Target = TargetAll !PackageType -- ^ Build all of the default components. | TargetComps !(Set NamedComponent) - -- ^ Only build specific components + -- ^ Build only the specified components. + +-- | Combine targets. +unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target +unionTargets = Map.unionWith $ \l r -> case (l, r) of + (TargetAll PTDependency, _) -> r + (TargetComps sl, TargetComps sr) -> TargetComps (Set.union sl sr) + (TargetComps _, TargetAll PTProject) -> TargetAll PTProject + (TargetComps _, _) -> l + (TargetAll PTProject, _) -> TargetAll PTProject -- | A type representing types of packages. data PackageType diff --git a/stack.cabal b/stack.cabal index d333e1291b..d9de373c50 100644 --- a/stack.cabal +++ b/stack.cabal @@ -215,6 +215,7 @@ library Stack.Build.Execute Stack.Build.ExecuteEnv Stack.Build.ExecutePackage + Stack.Build.FileTargets Stack.Build.Haddock Stack.Build.Installed Stack.Build.Source @@ -317,6 +318,7 @@ library Stack.Types.Build Stack.Types.Build.ConstructPlan Stack.Types.Build.Exception + Stack.Types.Build.FileTargets Stack.Types.BuildConfig Stack.Types.BuildOpts Stack.Types.BuildOptsCLI @@ -357,6 +359,7 @@ library Stack.Types.GhcPkgExe Stack.Types.GhcPkgId Stack.Types.GhciOpts + Stack.Types.GhciPkg Stack.Types.GlobalOpts Stack.Types.GlobalOptsMonoid Stack.Types.HpcReportOpts