{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.PackageFile
( packageDescModulesAndFiles
) where
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import Distribution.CabalSpecVersion ( CabalSpecVersion )
import Distribution.ModuleName ( ModuleName )
import Distribution.PackageDescription hiding ( FlagName )
import Distribution.Simple.Glob ( matchDirFileGlob )
import qualified Distribution.Types.UnqualComponentName as Cabal
import Path as FL hiding ( replaceExtension )
import Path.Extra
import Path.IO hiding ( findFiles )
import Stack.ComponentFile
import Stack.Prelude hiding ( Display (..) )
import Stack.Types.NamedComponent
import Stack.Types.PackageFile
( DotCabalPath (..), GetPackageFileContext (..)
, PackageWarning (..)
)
import qualified System.FilePath as FilePath
import System.IO.Error ( isUserError )
resolveFileOrWarn :: FilePath.FilePath
-> RIO GetPackageFileContext (Maybe (Path Abs File))
resolveFileOrWarn :: FilePath -> RIO GetPackageFileContext (Maybe (Path Abs File))
resolveFileOrWarn = forall a.
Text
-> (Path Abs Dir
-> FilePath -> RIO GetPackageFileContext (Maybe a))
-> FilePath
-> RIO GetPackageFileContext (Maybe a)
resolveOrWarn Text
"File" forall {m :: * -> *}.
MonadIO m =>
Path Abs Dir -> FilePath -> m (Maybe (Path Abs File))
f
where
f :: Path Abs Dir -> FilePath -> m (Maybe (Path Abs File))
f Path Abs Dir
p FilePath
x = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> FilePath -> m (Path Abs File)
resolveFile Path Abs Dir
p FilePath
x)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
Maybe (Path Abs File) -> m (Maybe (Path Abs File))
rejectMissingFile
packageDescModulesAndFiles
:: PackageDescription
-> RIO
GetPackageFileContext
( Map NamedComponent (Map ModuleName (Path Abs File))
, Map NamedComponent [DotCabalPath]
, Set (Path Abs File)
, [PackageWarning]
)
packageDescModulesAndFiles :: PackageDescription
-> RIO
GetPackageFileContext
(Map NamedComponent (Map ModuleName (Path Abs File)),
Map NamedComponent [DotCabalPath], Set (Path Abs File),
[PackageWarning])
packageDescModulesAndFiles PackageDescription
pkg = do
(Map NamedComponent (Map ModuleName (Path Abs File))
libraryMods, Map NamedComponent [DotCabalPath]
libDotCabalFiles, [PackageWarning]
libWarnings) <-
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Map k a
M.empty, forall k a. Map k a
M.empty, []))
(forall {m :: * -> *} {t} {k} {a} {a} {c}.
Monad m =>
(t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap forall {b}. b -> NamedComponent
libComponent NamedComponent
-> Library
-> RIO
GetPackageFileContext
(Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
libraryFiles)
(PackageDescription -> Maybe Library
library PackageDescription
pkg)
(Map NamedComponent (Map ModuleName (Path Abs File))
subLibrariesMods, Map NamedComponent [DotCabalPath]
subLibDotCabalFiles, [PackageWarning]
subLibWarnings) <-
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
forall {a} {a} {a}.
[(Map NamedComponent a, Map NamedComponent a, [a])]
-> (Map NamedComponent a, Map NamedComponent a, [a])
foldTuples
( forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(forall {m :: * -> *} {t} {k} {a} {a} {c}.
Monad m =>
(t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap Library -> NamedComponent
internalLibComponent NamedComponent
-> Library
-> RIO
GetPackageFileContext
(Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
libraryFiles)
(PackageDescription -> [Library]
subLibraries PackageDescription
pkg)
)
(Map NamedComponent (Map ModuleName (Path Abs File))
executableMods, Map NamedComponent [DotCabalPath]
exeDotCabalFiles, [PackageWarning]
exeWarnings) <-
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
forall {a} {a} {a}.
[(Map NamedComponent a, Map NamedComponent a, [a])]
-> (Map NamedComponent a, Map NamedComponent a, [a])
foldTuples
( forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(forall {m :: * -> *} {t} {k} {a} {a} {c}.
Monad m =>
(t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap Executable -> NamedComponent
exeComponent NamedComponent
-> Executable
-> RIO
GetPackageFileContext
(Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
executableFiles)
(PackageDescription -> [Executable]
executables PackageDescription
pkg)
)
(Map NamedComponent (Map ModuleName (Path Abs File))
testMods, Map NamedComponent [DotCabalPath]
testDotCabalFiles, [PackageWarning]
testWarnings) <-
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
forall {a} {a} {a}.
[(Map NamedComponent a, Map NamedComponent a, [a])]
-> (Map NamedComponent a, Map NamedComponent a, [a])
foldTuples
(forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {m :: * -> *} {t} {k} {a} {a} {c}.
Monad m =>
(t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap TestSuite -> NamedComponent
testComponent NamedComponent
-> TestSuite
-> RIO
GetPackageFileContext
(Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
testFiles) (PackageDescription -> [TestSuite]
testSuites PackageDescription
pkg))
(Map NamedComponent (Map ModuleName (Path Abs File))
benchModules, Map NamedComponent [DotCabalPath]
benchDotCabalPaths, [PackageWarning]
benchWarnings) <-
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
forall {a} {a} {a}.
[(Map NamedComponent a, Map NamedComponent a, [a])]
-> (Map NamedComponent a, Map NamedComponent a, [a])
foldTuples
( forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
(forall {m :: * -> *} {t} {k} {a} {a} {c}.
Monad m =>
(t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap Benchmark -> NamedComponent
benchComponent NamedComponent
-> Benchmark
-> RIO
GetPackageFileContext
(Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
benchmarkFiles)
(PackageDescription -> [Benchmark]
benchmarks PackageDescription
pkg)
)
Set (Path Abs File)
dfiles <- CabalSpecVersion
-> [FilePath] -> RIO GetPackageFileContext (Set (Path Abs File))
resolveGlobFiles
(PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pkg)
( PackageDescription -> [FilePath]
extraSrcFiles PackageDescription
pkg
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (PackageDescription -> FilePath
dataDir PackageDescription
pkg FilePath -> FilePath -> FilePath
FilePath.</>) (PackageDescription -> [FilePath]
dataFiles PackageDescription
pkg)
)
let modules :: Map NamedComponent (Map ModuleName (Path Abs File))
modules = Map NamedComponent (Map ModuleName (Path Abs File))
libraryMods forall a. Semigroup a => a -> a -> a
<> Map NamedComponent (Map ModuleName (Path Abs File))
subLibrariesMods forall a. Semigroup a => a -> a -> a
<> Map NamedComponent (Map ModuleName (Path Abs File))
executableMods forall a. Semigroup a => a -> a -> a
<> Map NamedComponent (Map ModuleName (Path Abs File))
testMods forall a. Semigroup a => a -> a -> a
<>
Map NamedComponent (Map ModuleName (Path Abs File))
benchModules
files :: Map NamedComponent [DotCabalPath]
files = Map NamedComponent [DotCabalPath]
libDotCabalFiles forall a. Semigroup a => a -> a -> a
<> Map NamedComponent [DotCabalPath]
subLibDotCabalFiles forall a. Semigroup a => a -> a -> a
<> Map NamedComponent [DotCabalPath]
exeDotCabalFiles forall a. Semigroup a => a -> a -> a
<>
Map NamedComponent [DotCabalPath]
testDotCabalFiles forall a. Semigroup a => a -> a -> a
<> Map NamedComponent [DotCabalPath]
benchDotCabalPaths
warnings :: [PackageWarning]
warnings = [PackageWarning]
libWarnings forall a. Semigroup a => a -> a -> a
<> [PackageWarning]
subLibWarnings forall a. Semigroup a => a -> a -> a
<> [PackageWarning]
exeWarnings forall a. Semigroup a => a -> a -> a
<> [PackageWarning]
testWarnings forall a. Semigroup a => a -> a -> a
<>
[PackageWarning]
benchWarnings
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map NamedComponent (Map ModuleName (Path Abs File))
modules, Map NamedComponent [DotCabalPath]
files, Set (Path Abs File)
dfiles, [PackageWarning]
warnings)
where
libComponent :: b -> NamedComponent
libComponent = forall a b. a -> b -> a
const NamedComponent
CLib
internalLibComponent :: Library -> NamedComponent
internalLibComponent =
Text -> NamedComponent
CInternalLib forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe
FilePath
"" UnqualComponentName -> FilePath
Cabal.unUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. LibraryName -> Maybe UnqualComponentName
libraryNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> LibraryName
libName
exeComponent :: Executable -> NamedComponent
exeComponent = Text -> NamedComponent
CExe forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> FilePath
Cabal.unUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Executable -> UnqualComponentName
exeName
testComponent :: TestSuite -> NamedComponent
testComponent = Text -> NamedComponent
CTest forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> FilePath
Cabal.unUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuite -> UnqualComponentName
testName
benchComponent :: Benchmark -> NamedComponent
benchComponent = Text -> NamedComponent
CBench forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> FilePath
Cabal.unUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Benchmark -> UnqualComponentName
benchmarkName
asModuleAndFileMap :: (t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap t -> k
label k -> t -> m (a, a, c)
f t
lib = do
(a
a, a
b, c
c) <- k -> t -> m (a, a, c)
f (t -> k
label t
lib) t
lib
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. k -> a -> Map k a
M.singleton (t -> k
label t
lib) a
a, forall k a. k -> a -> Map k a
M.singleton (t -> k
label t
lib) a
b, c
c)
foldTuples :: [(Map NamedComponent a, Map NamedComponent a, [a])]
-> (Map NamedComponent a, Map NamedComponent a, [a])
foldTuples = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Semigroup a => a -> a -> a
(<>) (forall k a. Map k a
M.empty, forall k a. Map k a
M.empty, [])
resolveGlobFiles
:: CabalSpecVersion
-> [String]
-> RIO GetPackageFileContext (Set (Path Abs File))
resolveGlobFiles :: CabalSpecVersion
-> [FilePath] -> RIO GetPackageFileContext (Set (Path Abs File))
resolveGlobFiles CabalSpecVersion
cabalFileVersion =
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> RIO GetPackageFileContext [Maybe (Path Abs File)]
resolve
where
resolve :: FilePath -> RIO GetPackageFileContext [Maybe (Path Abs File)]
resolve FilePath
name =
if Char
'*' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
name
then FilePath -> RIO GetPackageFileContext [Maybe (Path Abs File)]
explode FilePath
name
else forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> RIO GetPackageFileContext (Maybe (Path Abs File))
resolveFileOrWarn FilePath
name)
explode :: FilePath -> RIO GetPackageFileContext [Maybe (Path Abs File)]
explode FilePath
name = do
Path Abs Dir
dir <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall b t. Path b t -> Path b Dir
parent forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetPackageFileContext -> Path Abs File
ctxFile)
[FilePath]
names <- forall {m :: * -> *} {env}.
(MonadUnliftIO m, HasTerm env, MonadReader env m) =>
FilePath -> FilePath -> m [FilePath]
matchDirFileGlob' (forall b t. Path b t -> FilePath
FL.toFilePath Path Abs Dir
dir) FilePath
name
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> RIO GetPackageFileContext (Maybe (Path Abs File))
resolveFileOrWarn [FilePath]
names
matchDirFileGlob' :: FilePath -> FilePath -> m [FilePath]
matchDirFileGlob' FilePath
dir FilePath
glob =
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Verbosity
-> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath]
matchDirFileGlob forall a. Bounded a => a
minBound CabalSpecVersion
cabalFileVersion FilePath
dir FilePath
glob))
( \(IOException
e :: IOException) ->
if IOException -> Bool
isUserError IOException
e
then do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ FilePath -> StyleDoc
flow FilePath
"Wildcard does not match any files:"
, Style -> StyleDoc -> StyleDoc
style Style
File forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString FilePath
glob
, StyleDoc
line forall a. Semigroup a => a -> a -> a
<> FilePath -> StyleDoc
flow FilePath
"in directory:"
, Style -> StyleDoc -> StyleDoc
style Style
Dir forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString FilePath
dir
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
else forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOException
e
)