From dc93edd6b384d05515a2360d2d2e027c1dffc435 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Tue, 7 Nov 2023 23:10:51 +0000 Subject: [PATCH] Formatting, for consistency --- src/Stack/Ghci.hs | 518 +++++++++++++++++++++++++--------------------- 1 file changed, 277 insertions(+), 241 deletions(-) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 6d2dbe00bc..5de6cb05c4 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -492,98 +492,108 @@ runGhci :: -> [PackageName] -> RIO env () runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do - config <- view configL - let pkgopts = hidePkgOpts ++ genOpts ++ ghcOpts - shouldHidePackages = - fromMaybe (not (null pkgs && null exposePackages)) ghciHidePackages - 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 - else [] - oneWordOpts bio - | shouldHidePackages = bioOneWordOpts bio ++ bioPackageFlags bio - | otherwise = bioOneWordOpts bio - genOpts = nubOrd (concatMap (concatMap (oneWordOpts . snd) . ghciPkgOpts) pkgs) - (omittedOpts, ghcOpts) = L.partition badForGhci $ - concatMap (concatMap (bioOpts . snd) . ghciPkgOpts) pkgs ++ map T.unpack - ( fold (configGhcOptionsByCat config) -- include everything, locals, and targets + config <- view configL + let pkgopts = hidePkgOpts ++ genOpts ++ ghcOpts + shouldHidePackages = + fromMaybe (not (null pkgs && null exposePackages)) ghciHidePackages + 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 + else [] + oneWordOpts bio + | shouldHidePackages = bioOneWordOpts bio ++ bioPackageFlags bio + | otherwise = bioOneWordOpts bio + genOpts = nubOrd (concatMap (concatMap (oneWordOpts . snd) . ghciPkgOpts) pkgs) + (omittedOpts, ghcOpts) = L.partition badForGhci $ + concatMap (concatMap (bioOpts . snd) . ghciPkgOpts) pkgs + ++ map + T.unpack + ( fold (configGhcOptionsByCat config) + -- ^ include everything, locals, and targets ++ concatMap (getUserOptions . ghciPkgName) pkgs - ) - getUserOptions pkg = M.findWithDefault [] pkg (configGhcOptionsByName config) - badForGhci x = - L.isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky -static -Werror") - unless (null omittedOpts) $ - prettyWarn $ - fillSep - ( flow "The following GHC options are incompatible with GHCi and \ - \have not been passed to it:" - : mkNarrativeList (Just Current) False - (map fromString (nubOrd omittedOpts) :: [StyleDoc]) ) - <> line - oiDir <- view objectInterfaceDirL - let odir = - [ "-odir=" <> toFilePathNoTrailingSep oiDir - , "-hidir=" <> toFilePathNoTrailingSep oiDir ] - prettyInfoL - ( flow "Configuring GHCi with the following packages:" - : mkNarrativeList (Just Current) False - (map (fromString . packageNameString . ghciPkgName) pkgs :: [StyleDoc]) - ) - compilerExeName <- view $ compilerPathsL.to cpCompiler.to toFilePath - let execGhci extras = do - menv <- liftIO $ configProcessContextSettings config defaultEnvSettings - withPackageWorkingDir $ withProcessContext menv $ exec - (fromMaybe compilerExeName ghciGhcCommand) - (("--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 <> ghciGhcOptions <> ghciArgs) - withPackageWorkingDir = - case pkgs of - [pkg] -> withWorkingDir (toFilePath $ ghciPkgDir pkg) - _ -> id - -- TODO: Consider optimizing this check. Perhaps if no - -- "with-ghc" is specified, assume that it is not using intero. - checkIsIntero = - -- Optimization dependent on the behavior of renderScript - - -- it doesn't matter if it's intero or ghci when loading - -- multiple packages. - case pkgs of - [_] -> do - menv <- liftIO $ configProcessContextSettings config defaultEnvSettings - output <- withProcessContext menv - $ runGrabFirstLine (fromMaybe compilerExeName ghciGhcCommand) ["--version"] - pure $ "Intero" `L.isPrefixOf` output - _ -> pure False - -- Since usage of 'exec' does not pure, we cannot do any cleanup - -- on ghci exit. So, instead leave the generated files. To make this - -- more efficient and avoid gratuitous generation of garbage, the - -- file names are determined by hashing. This also has the nice side - -- effect of making it possible to copy the ghci invocation out of - -- the log and have it still work. - tmpDirectory <- getXdgDir XdgCache $ - Just (relDirStackProgName relDirGhciScript) - ghciDir <- view ghciDirL - ensureDir ghciDir - ensureDir tmpDirectory - macrosOptions <- writeMacrosFile ghciDir pkgs - if ghciNoLoadModules - then execGhci macrosOptions - else do - checkForDuplicateModules pkgs - isIntero <- checkIsIntero - scriptOptions <- writeGhciScript tmpDirectory (renderScript isIntero pkgs mainFile ghciOnlyMain extraFiles) - execGhci (macrosOptions ++ scriptOptions) + getUserOptions pkg = + M.findWithDefault [] pkg (configGhcOptionsByName config) + badForGhci x = + L.isPrefixOf "-O" x + || elem x (words "-debug -threaded -ticky -static -Werror") + unless (null omittedOpts) $ + prettyWarn $ + fillSep + ( flow "The following GHC options are incompatible with GHCi and \ + \have not been passed to it:" + : mkNarrativeList (Just Current) False + (map fromString (nubOrd omittedOpts) :: [StyleDoc]) + ) + <> line + oiDir <- view objectInterfaceDirL + let odir = + [ "-odir=" <> toFilePathNoTrailingSep oiDir + , "-hidir=" <> toFilePathNoTrailingSep oiDir + ] + prettyInfoL + ( flow "Configuring GHCi with the following packages:" + : mkNarrativeList (Just Current) False + (map (fromString . packageNameString . ghciPkgName) pkgs :: [StyleDoc]) + ) + compilerExeName <- view $ compilerPathsL.to cpCompiler.to toFilePath + let execGhci extras = do + menv <- liftIO $ configProcessContextSettings config defaultEnvSettings + withPackageWorkingDir $ withProcessContext menv $ exec + (fromMaybe compilerExeName ghciGhcCommand) + ( ("--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 <> ghciGhcOptions <> ghciArgs + ) + withPackageWorkingDir = + case pkgs of + [pkg] -> withWorkingDir (toFilePath $ ghciPkgDir pkg) + _ -> id + -- TODO: Consider optimizing this check. Perhaps if no "with-ghc" is + -- specified, assume that it is not using intero. + checkIsIntero = + -- Optimization dependent on the behavior of renderScript - it doesn't + -- matter if it's intero or ghci when loading multiple packages. + case pkgs of + [_] -> do + menv <- + liftIO $ configProcessContextSettings config defaultEnvSettings + output <- withProcessContext menv $ + runGrabFirstLine + (fromMaybe compilerExeName ghciGhcCommand) + ["--version"] + pure $ "Intero" `L.isPrefixOf` output + _ -> pure False + -- Since usage of 'exec' does not pure, we cannot do any cleanup on ghci exit. + -- So, instead leave the generated files. To make this more efficient and + -- avoid gratuitous generation of garbage, the file names are determined by + -- hashing. This also has the nice side effect of making it possible to copy + -- the ghci invocation out of the log and have it still work. + tmpDirectory <- getXdgDir XdgCache $ + Just (relDirStackProgName relDirGhciScript) + ghciDir <- view ghciDirL + ensureDir ghciDir + ensureDir tmpDirectory + macrosOptions <- writeMacrosFile ghciDir pkgs + if ghciNoLoadModules + then execGhci macrosOptions + else do + checkForDuplicateModules pkgs + isIntero <- checkIsIntero + scriptOptions <- + writeGhciScript + tmpDirectory + (renderScript isIntero pkgs mainFile ghciOnlyMain extraFiles) + execGhci (macrosOptions ++ scriptOptions) writeMacrosFile :: HasTerm env @@ -603,7 +613,9 @@ writeMacrosFile outputDirectory pkgs = do 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 + S8.concat $ map + (<> "\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") + files pure ["-optP-include", "-optP" <> toFilePath out] writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m [String] @@ -638,21 +650,22 @@ renderScript :: -> GhciScript renderScript isIntero pkgs mainFile onlyMain extraFiles = do let cdPhase = case (isIntero, pkgs) of - -- If only loading one package, set the cwd properly. - -- Otherwise don't try. See - -- https://github.com/commercialhaskell/stack/issues/3309 + -- If only loading one package, set the cwd properly. Otherwise don't + -- try. See https://github.com/commercialhaskell/stack/issues/3309 (True, [pkg]) -> cmdCdGhc (ghciPkgDir pkg) _ -> mempty addPhase = cmdAdd $ S.fromList (map Left allModules ++ addMain) addMain = case mainFile of - Just path -> [Right path] - _ -> [] + Just path -> [Right path] + _ -> [] modulePhase = cmdModule $ S.fromList allModules allModules = nubOrd $ concatMap (M.keys . ghciPkgModules) pkgs case getFileTargets pkgs <> extraFiles of [] -> if onlyMain - then cdPhase <> if isJust mainFile then cmdAdd (S.fromList addMain) else mempty + then + cdPhase + <> if isJust mainFile then cmdAdd (S.fromList addMain) else mempty else cdPhase <> addPhase <> modulePhase fileTargets -> cmdAdd (S.fromList (map Right fileTargets)) @@ -661,8 +674,8 @@ renderScript isIntero pkgs mainFile onlyMain extraFiles = do getFileTargets :: [GhciPkgInfo] -> [Path Abs File] getFileTargets = concatMap (concat . maybeToList . ghciPkgTargetFiles) --- | Figure out the main-is file to load based on the targets. Asks the --- user for input if there is more than one candidate main-is file. +-- | Figure out the main-is file to load based on the targets. Asks the user for +-- input if there is more than one candidate main-is file. figureOutMainFile :: (HasRunner env, HasTerm env) => BuildOpts @@ -671,71 +684,72 @@ figureOutMainFile :: -> [GhciPkgInfo] -> RIO env (Maybe (Path Abs File)) figureOutMainFile bopts mainIsTargets targets0 packages = - case candidates of - [] -> pure Nothing - [c@(_,_,fp)] -> do - prettyInfo $ - fillSep - [ "Using" - , style Current "main" - , "module:" - ] - <> line - <> renderCandidate c - <> line - pure (Just fp) - candidate:_ -> do - prettyWarn $ - fillSep - [ "The" - , style Current "main" - , flow "module to load is ambiguous. Candidates are:" - ] - <> line - <> mconcat (L.intersperse line (map renderCandidate candidates)) - <> blankLine - <> flow "You can specify which one to pick by:" - <> line - <> bulletedList - [ fillSep - [ flow "Specifying targets to" - , style Shell (flow "stack ghci") - , "e.g." - , style Shell ( fillSep - [ flow "stack ghci" - , sampleTargetArg candidate - ] - ) <> "." - ] - , fillSep - [ flow "Specifying what the" - , style Current "main" - , flow "is e.g." - , style Shell ( fillSep - [ flow "stack ghci" - , sampleMainIsArg candidate - ] - ) <> "." - ] - , flow - $ "Choosing from the candidate above [1.." - <> show (length candidates) - <> "]." - ] - <> line - liftIO userOption + case candidates of + [] -> pure Nothing + [c@(_,_,fp)] -> do + prettyInfo $ + fillSep + [ "Using" + , style Current "main" + , "module:" + ] + <> line + <> renderCandidate c + <> line + pure (Just fp) + candidate:_ -> do + prettyWarn $ + fillSep + [ "The" + , style Current "main" + , flow "module to load is ambiguous. Candidates are:" + ] + <> line + <> mconcat (L.intersperse line (map renderCandidate candidates)) + <> blankLine + <> flow "You can specify which one to pick by:" + <> line + <> bulletedList + [ fillSep + [ flow "Specifying targets to" + , style Shell (flow "stack ghci") + , "e.g." + , style Shell ( fillSep + [ flow "stack ghci" + , sampleTargetArg candidate + ] + ) <> "." + ] + , fillSep + [ flow "Specifying what the" + , style Current "main" + , flow "is e.g." + , style Shell ( fillSep + [ flow "stack ghci" + , sampleMainIsArg candidate + ] + ) <> "." + ] + , flow + $ "Choosing from the candidate above [1.." + <> show (length candidates) + <> "]." + ] + <> line + liftIO userOption where - targets = fromMaybe (M.fromList $ map (\(k, (_, x)) -> (k, x)) targets0) - mainIsTargets + targets = fromMaybe + (M.fromList $ map (\(k, (_, x)) -> (k, x)) targets0) + mainIsTargets candidates = do pkg <- packages case M.lookup (ghciPkgName pkg) targets of Nothing -> [] Just target -> do (component,mains) <- - M.toList $ - M.filterWithKey (\k _ -> k `S.member` wantedComponents) - (ghciPkgMainIs pkg) + M.toList $ + M.filterWithKey (\k _ -> k `S.member` wantedComponents) + (ghciPkgMainIs pkg) main <- mains pure (ghciPkgName pkg, component, main) where @@ -751,8 +765,8 @@ figureOutMainFile bopts mainIsTargets targets0 packages = [ "Package" , style Current pkgNameText <> "," , "component" - -- This is the format that can be directly copy-pasted as - -- an argument to `stack ghci`. + -- This is the format that can be directly copy-pasted as an + -- argument to `stack ghci`. , style PkgComponent ( pkgNameText @@ -769,9 +783,9 @@ figureOutMainFile bopts mainIsTargets targets0 packages = userOption = do option <- prompt "Specify main module to use (press enter to load none): " let selected = fromMaybe - ((+1) $ length candidateIndices) - (readMaybe (T.unpack option) :: Maybe Int) - case L.elemIndex selected candidateIndices of + ((+1) $ length candidateIndices) + (readMaybe (T.unpack option) :: Maybe Int) + case L.elemIndex selected candidateIndices of Nothing -> do putStrLn "Not loading any main modules, as no valid module selected" @@ -779,9 +793,9 @@ figureOutMainFile bopts mainIsTargets targets0 packages = pure Nothing Just op -> do (_, _, fp) <- maybe - (prettyThrowIO CandidatesIndexOutOfRangeBug) - pure - (candidates !? op) + (prettyThrowIO CandidatesIndexOutOfRangeBug) + pure + (candidates !? op) putStrLn ("Loading main module from candidate " <> show (op + 1) <> ", --main-is " <> @@ -853,7 +867,7 @@ loadGhciPkgDesc buildOptsCLI name cabalfp target = do -- retain that GenericPackageDescription in the relevant data -- structures to avoid reparsing. (gpdio, _name, _cabalfp) <- - loadCabalFilePath (Just stackProgName') (parent cabalfp) + loadCabalFilePath (Just stackProgName') (parent cabalfp) gpkgdesc <- liftIO $ gpdio YesPrintWarnings -- Source the package's *.buildinfo file created by configure if any. See @@ -869,11 +883,12 @@ loadGhciPkgDesc buildOptsCLI name cabalfp target = do packageFromPackageDescription config (C.genPackageFlags gpkgdesc) $ maybe pdp - (\bi -> - let PackageDescriptionPair x y = pdp - in PackageDescriptionPair - (C.updatePackageDescription bi x) - (C.updatePackageDescription bi y)) + ( \bi -> + let PackageDescriptionPair x y = pdp + in PackageDescriptionPair + (C.updatePackageDescription bi x) + (C.updatePackageDescription bi y) + ) mbuildinfo pure GhciPkgDesc { ghciDescPkg = pkg @@ -923,10 +938,15 @@ makeGhciPkgInfo installMap installedMap locals addPkgs mfileTargets pkgDesc = do , ghciPkgOpts = M.toList filteredOpts , ghciPkgDir = parent cabalfp , ghciPkgModules = unionModuleMaps $ - map (\(comp, mp) -> M.map (\fp -> M.singleton fp (S.singleton (packageName pkg, comp))) mp) - (M.toList (filterWanted mods)) + map + ( \(comp, mp) -> M.map + (\fp -> M.singleton fp (S.singleton (packageName pkg, comp))) + mp + ) + (M.toList (filterWanted mods)) , ghciPkgMainIs = M.map (mapMaybe dotCabalMainPath) files - , ghciPkgCFiles = mconcat (M.elems (filterWanted (M.map (mapMaybe dotCabalCFilePath) files))) + , ghciPkgCFiles = mconcat + (M.elems (filterWanted (M.map (mapMaybe dotCabalCFilePath) files))) , ghciPkgTargetFiles = mfileTargets >>= M.lookup name , ghciPkgPackage = pkg } @@ -937,13 +957,17 @@ makeGhciPkgInfo installMap installedMap locals addPkgs mfileTargets pkgDesc = do wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent wantedPackageComponents _ (TargetComps cs) _ = cs wantedPackageComponents bopts (TargetAll PTProject) pkg = S.fromList $ - (case packageLibraries pkg of - NoLibraries -> [] - HasLibraries names -> CLib : map CSubLib (S.toList names)) ++ - map CExe (S.toList (packageExes pkg)) <> - map CSubLib (S.toList $ packageSubLibraries pkg) <> - (if boptsTests bopts then map CTest (M.keys (packageTests pkg)) else []) <> - (if boptsBenchmarks bopts then map CBench (S.toList (packageBenchmarks pkg)) else []) + ( case packageLibraries pkg of + NoLibraries -> [] + HasLibraries names -> CLib : map CSubLib (S.toList names) + ) + <> map CExe (S.toList (packageExes pkg)) + <> map CSubLib (S.toList $ packageSubLibraries pkg) + <> (if boptsTests bopts then map CTest (M.keys (packageTests pkg)) else []) + <> ( if boptsBenchmarks bopts + then map CBench (S.toList (packageBenchmarks pkg)) + else [] + ) wantedPackageComponents _ _ _ = S.empty checkForIssues :: HasTerm env => [GhciPkgInfo] -> RIO env () @@ -1037,8 +1061,8 @@ checkForIssues pkgs = ) ] mixedFlag (flag, msgs) = - let x = partitionComps (== flag) in - [ fillSep $ msgs ++ showWhich x | mixedSettings x ] + let x = partitionComps (== flag) + in [ fillSep $ msgs ++ showWhich x | mixedSettings x ] mixedSettings (xs, ys) = xs /= [] && ys /= [] showWhich (haveIt, don'tHaveIt) = [ flow "It is specified for:" ] @@ -1107,78 +1131,90 @@ targetWarnings localTargets nonLocalTargets mfileTargets = do unless (null nonLocalTargets) $ prettyWarnL [ flow "Some targets" - , parens $ fillSep $ punctuate "," $ map (style Good . fromString . packageNameString) nonLocalTargets - , flow "are not local packages, and so cannot be directly loaded." - , flow "In future versions of Stack, this might be supported - see" + , parens $ fillSep $ punctuate "," $ map + (style Good . fromString . packageNameString) + nonLocalTargets + , flow "are not local packages, and so cannot be directly loaded. In \ + \future versions of Stack, this might be supported - see" , style Url "https://github.com/commercialhaskell/stack/issues/1441" , "." - , flow "It can still be useful to specify these, as they will be passed to ghci via -package flags." + , flow "It can still be useful to specify these, as they will be passed \ + \to ghci via -package flags." ] when (null localTargets && isNothing mfileTargets) $ do - smWanted <- view $ buildConfigL.to bcSMWanted - stackYaml <- view stackYamlL - prettyNote $ vsep - [ flow "No local targets specified, so a plain ghci will be started with no package hiding or package options." - , "" - , flow $ T.unpack $ utf8BuilderToText $ - "You are using snapshot: " <> - display (smwSnapshotLocation smWanted) - , "" - , flow "If you want to use package hiding and options, then you can try one of the following:" - , "" - , bulletedList - [ fillSep - [ flow "If you want to start a different project configuration than" <+> pretty stackYaml <> ", then you can use" - , style Shell "stack init" - , flow "to create a new stack.yaml for the packages in the current directory." - , line - ] - , flow "If you want to use the project configuration at" <+> pretty stackYaml <> ", then you can add to its 'packages' field." + smWanted <- view $ buildConfigL.to bcSMWanted + stackYaml <- view stackYamlL + prettyNote $ vsep + [ flow "No local targets specified, so a plain ghci will be started with \ + \no package hiding or package options." + , "" + , flow $ T.unpack $ utf8BuilderToText $ + "You are using snapshot: " <> + display (smwSnapshotLocation smWanted) + , "" + , flow "If you want to use package hiding and options, then you can try \ + \one of the following:" + , "" + , bulletedList + [ fillSep + [ flow "If you want to start a different project configuration \ + \than" + , pretty stackYaml <> "," + , flow "then you can use" + , style Shell "stack init" + , flow "to create a new stack.yaml for the packages in the \ + \current directory." + , line ] - , "" + , flow "If you want to use the project configuration at" + , pretty stackYaml <> "," + , flow "then you can add to its 'packages' field." ] + , "" + ] --- 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). +-- 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. +-- 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 -> M.keys (packageDeps (lpPackage lp)) -- 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 = M.keys (packageDeps (lpPackage lp)) - shouldLoad <- or <$> mapM go deps - if shouldLoad - then do - modify (M.insert name (Just (lpCabalFile lp, TargetComps (S.singleton CLib)))) - pure True - else do - modify (M.insert name Nothing) - pure False - (_, _) -> pure False + 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 -> M.keys (packageDeps (lpPackage lp)) -- 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 = M.keys (packageDeps (lpPackage lp)) + shouldLoad <- or <$> mapM go deps + if shouldLoad + then do + modify (M.insert name (Just (lpCabalFile lp, 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