Skip to content

Commit d527173

Browse files
kadobankadoban
committed
prepare s/S/Package functions for being made pretty
1 parent 3768a48 commit d527173

1 file changed

Lines changed: 46 additions & 28 deletions

File tree

‎src/Stack/Package.hs‎

Lines changed: 46 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -70,6 +70,7 @@ import qualified Distribution.Types.LegacyExeDependency as Cabal
7070
import qualified Distribution.Types.UnqualComponentName as Cabal
7171
import qualified Distribution.Verbosity as D
7272
import Distribution.Version (showVersion)
73+
import Lens.Micro (lens)
7374
import qualified Hpack
7475
import qualified Hpack.Config as Hpack
7576
import Path as FL
@@ -97,6 +98,22 @@ import System.FilePath (splitExtensions, replaceExtension)
9798
import qualified System.FilePath as FilePath
9899
import System.IO.Error
99100

101+
data Ctx = Ctx { ctxFile :: !(Path Abs File)
102+
, ctxDir :: !(Path Abs Dir)
103+
, ctxEnvConfig :: !EnvConfig
104+
}
105+
106+
instance HasPlatform Ctx
107+
instance HasGHCVariant Ctx
108+
instance HasLogFunc Ctx where
109+
logFuncL = configL.logFuncL
110+
instance HasRunner Ctx where
111+
runnerL = configL.runnerL
112+
instance HasConfig Ctx
113+
instance HasBuildConfig Ctx
114+
instance HasEnvConfig Ctx where
115+
envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y })
116+
100117
-- | Read the raw, unresolved package information.
101118
readPackageUnresolved :: (MonadIO m, MonadThrow m)
102119
=> Path Abs File
@@ -269,10 +286,11 @@ packageFromPackageDescription packageConfig pkgFlags pkg =
269286
\cabalfp -> debugBracket ("getPackageFiles" <+> display cabalfp) $ do
270287
let pkgDir = parent cabalfp
271288
distDir <- distDirFromDir pkgDir
289+
env <- view envConfigL
272290
(componentModules,componentFiles,dataFiles',warnings) <-
273291
runReaderT
274292
(packageDescModulesAndFiles pkg)
275-
(cabalfp, buildDir distDir)
293+
(Ctx cabalfp (buildDir distDir) env)
276294
setupFiles <-
277295
if buildType pkg `elem` [Nothing, Just Custom]
278296
then do
@@ -558,7 +576,7 @@ packageDescTools =
558576

559577
-- | Get all files referenced by the package.
560578
packageDescModulesAndFiles
561-
:: (MonadLogger m, MonadUnliftIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m)
579+
:: (MonadLogger m, MonadUnliftIO m, MonadReader Ctx m, MonadThrow m)
562580
=> PackageDescription
563581
-> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning])
564582
packageDescModulesAndFiles pkg = do
@@ -603,7 +621,7 @@ packageDescModulesAndFiles pkg = do
603621
foldTuples = foldl' (<>) (M.empty, M.empty, [])
604622

605623
-- | Resolve globbing of files (e.g. data files) to absolute paths.
606-
resolveGlobFiles :: (MonadLogger m,MonadUnliftIO m,MonadReader (Path Abs File, Path Abs Dir) m)
624+
resolveGlobFiles :: (MonadLogger m,MonadUnliftIO m,MonadReader Ctx m)
607625
=> [String] -> m (Set (Path Abs File))
608626
resolveGlobFiles =
609627
liftM (S.fromList . catMaybes . concat) .
@@ -614,7 +632,7 @@ resolveGlobFiles =
614632
then explode name
615633
else liftM return (resolveFileOrWarn name)
616634
explode name = do
617-
dir <- asks (parent . fst)
635+
dir <- asks (parent . ctxFile)
618636
names <-
619637
matchDirFileGlob'
620638
(FL.toFilePath dir)
@@ -672,11 +690,11 @@ matchDirFileGlob_ dir filepath = case parseFileGlob filepath of
672690

673691
-- | Get all files referenced by the benchmark.
674692
benchmarkFiles
675-
:: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m)
693+
:: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m)
676694
=> Benchmark -> m (Set ModuleName, Set DotCabalPath, [PackageWarning])
677695
benchmarkFiles bench = do
678696
dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
679-
dir <- asks (parent . fst)
697+
dir <- asks (parent . ctxFile)
680698
(modules,files,warnings) <-
681699
resolveFilesAndDeps
682700
(Just $ Cabal.unUnqualComponentName $ benchmarkName bench)
@@ -695,12 +713,12 @@ benchmarkFiles bench = do
695713

696714
-- | Get all files referenced by the test.
697715
testFiles
698-
:: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m)
716+
:: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m)
699717
=> TestSuite
700718
-> m (Set ModuleName, Set DotCabalPath, [PackageWarning])
701719
testFiles test = do
702720
dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
703-
dir <- asks (parent . fst)
721+
dir <- asks (parent . ctxFile)
704722
(modules,files,warnings) <-
705723
resolveFilesAndDeps
706724
(Just $ Cabal.unUnqualComponentName $ testName test)
@@ -720,12 +738,12 @@ testFiles test = do
720738

721739
-- | Get all files referenced by the executable.
722740
executableFiles
723-
:: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m)
741+
:: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m)
724742
=> Executable
725743
-> m (Set ModuleName, Set DotCabalPath, [PackageWarning])
726744
executableFiles exe = do
727745
dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
728-
dir <- asks (parent . fst)
746+
dir <- asks (parent . ctxFile)
729747
(modules,files,warnings) <-
730748
resolveFilesAndDeps
731749
(Just $ Cabal.unUnqualComponentName $ exeName exe)
@@ -740,11 +758,11 @@ executableFiles exe = do
740758

741759
-- | Get all files referenced by the library.
742760
libraryFiles
743-
:: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m)
761+
:: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m)
744762
=> Library -> m (Set ModuleName, Set DotCabalPath, [PackageWarning])
745763
libraryFiles lib = do
746764
dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
747-
dir <- asks (parent . fst)
765+
dir <- asks (parent . ctxFile)
748766
(modules,files,warnings) <-
749767
resolveFilesAndDeps
750768
Nothing
@@ -760,7 +778,7 @@ libraryFiles lib = do
760778
build = libBuildInfo lib
761779

762780
-- | Get all C sources and extra source files in a build.
763-
buildOtherSources :: (MonadLogger m,MonadIO m,MonadReader (Path Abs File, Path Abs Dir) m)
781+
buildOtherSources :: (MonadLogger m,MonadIO m,MonadReader Ctx m)
764782
=> BuildInfo -> m (Set DotCabalPath)
765783
buildOtherSources build =
766784
do csources <- liftM
@@ -914,7 +932,7 @@ depRange (Dependency _ r) = r
914932
-- extensions, plus find any of their module and TemplateHaskell
915933
-- dependencies.
916934
resolveFilesAndDeps
917-
:: (MonadIO m, MonadLogger m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m)
935+
:: (MonadIO m, MonadLogger m, MonadReader Ctx m, MonadThrow m)
918936
=> Maybe String -- ^ Package component name
919937
-> [Path Abs Dir] -- ^ Directories to look in.
920938
-> [DotCabalDescriptor] -- ^ Base names.
@@ -968,7 +986,7 @@ resolveFilesAndDeps component dirs names0 exts = do
968986
-- TODO: bring this back - see
969987
-- https://github.com/commercialhaskell/stack/issues/2649
970988
{-
971-
cabalfp <- asks fst
989+
cabalfp <- asks ctxFile
972990
return $
973991
if null missingModules
974992
then []
@@ -981,7 +999,7 @@ resolveFilesAndDeps component dirs names0 exts = do
981999

9821000
-- | Get the dependencies of a Haskell module file.
9831001
getDependencies
984-
:: (MonadReader (Path Abs File, Path Abs Dir) m, MonadIO m, MonadLogger m)
1002+
:: (MonadReader Ctx m, MonadIO m, MonadLogger m)
9851003
=> Maybe String -> DotCabalPath -> m (Set ModuleName, [Path Abs File])
9861004
getDependencies component dotCabalPath =
9871005
case dotCabalPath of
@@ -992,7 +1010,7 @@ getDependencies component dotCabalPath =
9921010
where
9931011
readResolvedHi resolvedFile = do
9941012
dumpHIDir <- getDumpHIDir
995-
dir <- asks (parent . fst)
1013+
dir <- asks (parent . ctxFile)
9961014
case stripProperPrefix dir resolvedFile of
9971015
Nothing -> return (S.empty, [])
9981016
Just fileRel -> do
@@ -1005,15 +1023,15 @@ getDependencies component dotCabalPath =
10051023
then parseDumpHI dumpHIPath
10061024
else return (S.empty, [])
10071025
getDumpHIDir = do
1008-
bld <- asks snd
1026+
bld <- asks ctxDir
10091027
return $ maybe bld (bld </>) (getBuildComponentDir component)
10101028

10111029
-- | Parse a .dump-hi file into a set of modules and files.
10121030
parseDumpHI
1013-
:: (MonadReader (Path Abs File, void) m, MonadIO m, MonadLogger m)
1031+
:: (MonadReader Ctx m, MonadIO m, MonadLogger m)
10141032
=> FilePath -> m (Set ModuleName, [Path Abs File])
10151033
parseDumpHI dumpHIPath = do
1016-
dir <- asks (parent . fst)
1034+
dir <- asks (parent . ctxFile)
10171035
dumpHI <- liftIO $ fmap C8.lines (C8.readFile dumpHIPath)
10181036
let startModuleDeps =
10191037
dropWhile (not . ("module dependencies:" `C8.isPrefixOf`)) dumpHI
@@ -1044,7 +1062,7 @@ parseDumpHI dumpHIPath = do
10441062
-- looking for unique instances of base names applied with the given
10451063
-- extensions.
10461064
resolveFiles
1047-
:: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
1065+
:: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader Ctx m)
10481066
=> [Path Abs Dir] -- ^ Directories to look in.
10491067
-> [DotCabalDescriptor] -- ^ Base names.
10501068
-> [Text] -- ^ Extensions.
@@ -1055,13 +1073,13 @@ resolveFiles dirs names exts =
10551073
-- | Find a candidate for the given module-or-filename from the list
10561074
-- of directories and given extensions.
10571075
findCandidate
1058-
:: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
1076+
:: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader Ctx m)
10591077
=> [Path Abs Dir]
10601078
-> [Text]
10611079
-> DotCabalDescriptor
10621080
-> m (Maybe DotCabalPath)
10631081
findCandidate dirs exts name = do
1064-
pkg <- asks fst >>= parsePackageNameFromFilePath
1082+
pkg <- asks ctxFile >>= parsePackageNameFromFilePath
10651083
candidates <- liftIO makeNameCandidates
10661084
case candidates of
10671085
[candidate] -> return (Just (cons candidate))
@@ -1233,15 +1251,15 @@ buildLogPath package' msuffix = do
12331251
return $ stack </> $(mkRelDir "logs") </> fp
12341252

12351253
-- Internal helper to define resolveFileOrWarn and resolveDirOrWarn
1236-
resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m)
1254+
resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader Ctx m)
12371255
=> Text
12381256
-> (Path Abs Dir -> String -> m (Maybe a))
12391257
-> FilePath.FilePath
12401258
-> m (Maybe a)
12411259
resolveOrWarn subject resolver path =
12421260
do cwd <- liftIO getCurrentDir
1243-
file <- asks fst
1244-
dir <- asks (parent . fst)
1261+
file <- asks ctxFile
1262+
dir <- asks (parent . ctxFile)
12451263
result <- resolver dir path
12461264
when (isNothing result) $
12471265
logWarn ("Warning: " <> subject <> " listed in " <>
@@ -1252,15 +1270,15 @@ resolveOrWarn subject resolver path =
12521270

12531271
-- | Resolve the file, if it can't be resolved, warn for the user
12541272
-- (purely to be helpful).
1255-
resolveFileOrWarn :: (MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m)
1273+
resolveFileOrWarn :: (MonadIO m,MonadLogger m,MonadReader Ctx m)
12561274
=> FilePath.FilePath
12571275
-> m (Maybe (Path Abs File))
12581276
resolveFileOrWarn = resolveOrWarn "File" f
12591277
where f p x = liftIO (forgivingAbsence (resolveFile p x)) >>= rejectMissingFile
12601278

12611279
-- | Resolve the directory, if it can't be resolved, warn for the user
12621280
-- (purely to be helpful).
1263-
resolveDirOrWarn :: (MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m)
1281+
resolveDirOrWarn :: (MonadIO m,MonadLogger m,MonadReader Ctx m)
12641282
=> FilePath.FilePath
12651283
-> m (Maybe (Path Abs Dir))
12661284
resolveDirOrWarn = resolveOrWarn "Directory" f

0 commit comments

Comments
 (0)