{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

-- | A module which exports all component-level file-gathering logic. It also

-- includes utility functions for handling paths and directories.


module Stack.ComponentFile
  ( resolveOrWarn
  , libraryFiles
  , executableFiles
  , testFiles
  , benchmarkFiles
  , componentOutputDir
  , componentBuildDir
  , packageAutogenDir
  , buildDir
  , componentAutogenDir
  ) where

import           Control.Exception ( throw )
import           Data.List ( find, isPrefixOf )
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import           Distribution.ModuleName ( ModuleName )
import qualified Distribution.ModuleName as Cabal
import           Distribution.Package
                   hiding
                     ( Module, Package, PackageIdentifier, packageName
                     , packageVersion
                     )
import           Distribution.PackageDescription hiding ( FlagName )
import           Distribution.Text ( display )
import           Distribution.Utils.Path ( getSymbolicPath )
import           Distribution.Version ( mkVersion )
import qualified HiFileParser as Iface
import           Path as FL hiding ( replaceExtension )
import           Path.Extra
import           Path.IO hiding ( findFiles )
import           Stack.Constants
import           Stack.Prelude hiding ( Display (..) )
import           Stack.Types.Config
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.PackageFile
                   ( GetPackageFileContext (..), DotCabalDescriptor (..)
                   , DotCabalPath (..), PackageWarning (..)
                   )
import qualified System.Directory as D ( doesFileExist )
import qualified System.FilePath as FilePath

-- | Get all files referenced by the benchmark.

benchmarkFiles
  :: NamedComponent
  -> Benchmark
  -> RIO
       GetPackageFileContext
       (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
benchmarkFiles :: NamedComponent
-> Benchmark
-> RIO
     GetPackageFileContext
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
benchmarkFiles NamedComponent
component Benchmark
bench = do
  NamedComponent
-> BuildInfo
-> [DotCabalDescriptor]
-> RIO
     GetPackageFileContext
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles NamedComponent
component BuildInfo
build [DotCabalDescriptor]
names
 where
  names :: [DotCabalDescriptor]
names = [DotCabalDescriptor]
bnames forall a. Semigroup a => a -> a -> a
<> [DotCabalDescriptor]
exposed
  exposed :: [DotCabalDescriptor]
exposed =
    case Benchmark -> BenchmarkInterface
benchmarkInterface Benchmark
bench of
      BenchmarkExeV10 Version
_ String
fp -> [String -> DotCabalDescriptor
DotCabalMain String
fp]
      BenchmarkUnsupported BenchmarkType
_ -> []
  bnames :: [DotCabalDescriptor]
bnames = forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (BuildInfo -> [ModuleName]
otherModules BuildInfo
build)
  build :: BuildInfo
build = Benchmark -> BuildInfo
benchmarkBuildInfo Benchmark
bench

-- | Get all files referenced by the test.

testFiles
  :: NamedComponent
  -> TestSuite
  -> RIO
       GetPackageFileContext
       (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
testFiles :: NamedComponent
-> TestSuite
-> RIO
     GetPackageFileContext
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
testFiles NamedComponent
component TestSuite
test = do
  NamedComponent
-> BuildInfo
-> [DotCabalDescriptor]
-> RIO
     GetPackageFileContext
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles NamedComponent
component BuildInfo
build [DotCabalDescriptor]
names
 where
  names :: [DotCabalDescriptor]
names = [DotCabalDescriptor]
bnames forall a. Semigroup a => a -> a -> a
<> [DotCabalDescriptor]
exposed
  exposed :: [DotCabalDescriptor]
exposed =
    case TestSuite -> TestSuiteInterface
testInterface TestSuite
test of
      TestSuiteExeV10 Version
_ String
fp -> [String -> DotCabalDescriptor
DotCabalMain String
fp]
      TestSuiteLibV09 Version
_ ModuleName
mn -> [ModuleName -> DotCabalDescriptor
DotCabalModule ModuleName
mn]
      TestSuiteUnsupported TestType
_ -> []
  bnames :: [DotCabalDescriptor]
bnames = forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (BuildInfo -> [ModuleName]
otherModules BuildInfo
build)
  build :: BuildInfo
build = TestSuite -> BuildInfo
testBuildInfo TestSuite
test

-- | Get all files referenced by the executable.

executableFiles
  :: NamedComponent
  -> Executable
  -> RIO
       GetPackageFileContext
       (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
executableFiles :: NamedComponent
-> Executable
-> RIO
     GetPackageFileContext
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
executableFiles NamedComponent
component Executable
exe = do
  NamedComponent
-> BuildInfo
-> [DotCabalDescriptor]
-> RIO
     GetPackageFileContext
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles NamedComponent
component BuildInfo
build [DotCabalDescriptor]
names
 where
  build :: BuildInfo
build = Executable -> BuildInfo
buildInfo Executable
exe
  names :: [DotCabalDescriptor]
names =
    forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (BuildInfo -> [ModuleName]
otherModules BuildInfo
build) forall a. [a] -> [a] -> [a]
++
    [String -> DotCabalDescriptor
DotCabalMain (Executable -> String
modulePath Executable
exe)]

-- | Get all files referenced by the library.

libraryFiles
  :: NamedComponent
  -> Library
  -> RIO
       GetPackageFileContext
       (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
libraryFiles :: NamedComponent
-> Library
-> RIO
     GetPackageFileContext
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
libraryFiles NamedComponent
component Library
lib = do
  NamedComponent
-> BuildInfo
-> [DotCabalDescriptor]
-> RIO
     GetPackageFileContext
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles NamedComponent
component BuildInfo
build [DotCabalDescriptor]
names
 where
  build :: BuildInfo
build = Library -> BuildInfo
libBuildInfo Library
lib
  names :: [DotCabalDescriptor]
names = [DotCabalDescriptor]
bnames forall a. [a] -> [a] -> [a]
++ [DotCabalDescriptor]
exposed
  exposed :: [DotCabalDescriptor]
exposed = forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (Library -> [ModuleName]
exposedModules Library
lib)
  bnames :: [DotCabalDescriptor]
bnames = forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (BuildInfo -> [ModuleName]
otherModules BuildInfo
build)

-- | Get all files referenced by the component.

resolveComponentFiles
  :: NamedComponent
  -> BuildInfo
  -> [DotCabalDescriptor]
  -> RIO
       GetPackageFileContext
       (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles :: NamedComponent
-> BuildInfo
-> [DotCabalDescriptor]
-> RIO
     GetPackageFileContext
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles NamedComponent
component BuildInfo
build [DotCabalDescriptor]
names = do
  [Path Abs Dir]
dirs <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (String -> RIO GetPackageFileContext (Maybe (Path Abs Dir))
resolveDirOrWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall from to. SymbolicPath from to -> String
getSymbolicPath) (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
build)
  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)
  [Path Abs Dir]
agdirs <- RIO GetPackageFileContext [Path Abs Dir]
autogenDirs
  (Map ModuleName (Path Abs File)
modules,[DotCabalPath]
files,[PackageWarning]
warnings) <-
    NamedComponent
-> [Path Abs Dir]
-> [DotCabalDescriptor]
-> RIO
     GetPackageFileContext
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveFilesAndDeps
      NamedComponent
component
      ((if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
dirs then [Path Abs Dir
dir] else [Path Abs Dir]
dirs) forall a. [a] -> [a] -> [a]
++ [Path Abs Dir]
agdirs)
      [DotCabalDescriptor]
names
  [DotCabalPath]
cfiles <- BuildInfo -> RIO GetPackageFileContext [DotCabalPath]
buildOtherSources BuildInfo
build
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ModuleName (Path Abs File)
modules, [DotCabalPath]
files forall a. Semigroup a => a -> a -> a
<> [DotCabalPath]
cfiles, [PackageWarning]
warnings)
 where
  autogenDirs :: RIO GetPackageFileContext [Path Abs Dir]
autogenDirs = do
    Version
cabalVer <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks GetPackageFileContext -> Version
ctxCabalVer
    Path Abs Dir
distDir <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks GetPackageFileContext -> Path Abs Dir
ctxDistDir
    let compDir :: Path Abs Dir
compDir = Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentAutogenDir Version
cabalVer NamedComponent
component Path Abs Dir
distDir
        pkgDir :: [Path Abs Dir]
pkgDir = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ Version -> Path Abs Dir -> Maybe (Path Abs Dir)
packageAutogenDir Version
cabalVer Path Abs Dir
distDir
    forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist forall a b. (a -> b) -> a -> b
$ Path Abs Dir
compDir forall a. a -> [a] -> [a]
: [Path Abs Dir]
pkgDir

-- | Try to resolve the list of base names in the given directory by

-- looking for unique instances of base names applied with the given

-- extensions, plus find any of their module and TemplateHaskell

-- dependencies.

resolveFilesAndDeps
  :: NamedComponent       -- ^ Package component name

  -> [Path Abs Dir]       -- ^ Directories to look in.

  -> [DotCabalDescriptor] -- ^ Base names.

  -> RIO
       GetPackageFileContext
       (Map ModuleName (Path Abs File),[DotCabalPath],[PackageWarning])
resolveFilesAndDeps :: NamedComponent
-> [Path Abs Dir]
-> [DotCabalDescriptor]
-> RIO
     GetPackageFileContext
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveFilesAndDeps NamedComponent
component [Path Abs Dir]
dirs [DotCabalDescriptor]
names0 = do
  ([DotCabalPath]
dotCabalPaths, Map ModuleName (Path Abs File)
foundModules, [ModuleName]
missingModules) <- [DotCabalDescriptor]
-> Set ModuleName
-> RIO
     GetPackageFileContext
     ([DotCabalPath], Map ModuleName (Path Abs File), [ModuleName])
loop [DotCabalDescriptor]
names0 forall a. Set a
S.empty
  [PackageWarning]
warnings <-
    forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. [a] -> [a] -> [a]
(++) (forall {f :: * -> *} {b}.
Applicative f =>
Map ModuleName b -> f [PackageWarning]
warnUnlisted Map ModuleName (Path Abs File)
foundModules) (forall {f :: * -> *} {p} {a}. Applicative f => p -> f [a]
warnMissing [ModuleName]
missingModules)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ModuleName (Path Abs File)
foundModules, [DotCabalPath]
dotCabalPaths, [PackageWarning]
warnings)
 where
  loop :: [DotCabalDescriptor]
-> Set ModuleName
-> RIO
     GetPackageFileContext
     ([DotCabalPath], Map ModuleName (Path Abs File), [ModuleName])
loop [] Set ModuleName
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], forall k a. Map k a
M.empty, [])
  loop [DotCabalDescriptor]
names Set ModuleName
doneModules0 = do
    [(DotCabalDescriptor, Maybe DotCabalPath)]
resolved <- [Path Abs Dir]
-> [DotCabalDescriptor]
-> RIO
     GetPackageFileContext [(DotCabalDescriptor, Maybe DotCabalPath)]
resolveFiles [Path Abs Dir]
dirs [DotCabalDescriptor]
names
    let foundFiles :: [DotCabalPath]
foundFiles = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> b
snd [(DotCabalDescriptor, Maybe DotCabalPath)]
resolved
        foundModules :: [(ModuleName, Path Abs File)]
foundModules = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (DotCabalDescriptor, Maybe DotCabalPath)
-> Maybe (ModuleName, Path Abs File)
toResolvedModule [(DotCabalDescriptor, Maybe DotCabalPath)]
resolved
        missingModules :: [ModuleName]
missingModules = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (DotCabalDescriptor, Maybe DotCabalPath) -> Maybe ModuleName
toMissingModule [(DotCabalDescriptor, Maybe DotCabalPath)]
resolved
    [(Set ModuleName, [Path Abs File])]
pairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NamedComponent
-> [Path Abs Dir]
-> DotCabalPath
-> RIO GetPackageFileContext (Set ModuleName, [Path Abs File])
getDependencies NamedComponent
component [Path Abs Dir]
dirs) [DotCabalPath]
foundFiles
    let doneModules :: Set ModuleName
doneModules = forall a. Ord a => Set a -> Set a -> Set a
S.union
                        Set ModuleName
doneModules0
                        (forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalDescriptor -> Maybe ModuleName
dotCabalModule [DotCabalDescriptor]
names))
        moduleDeps :: Set ModuleName
moduleDeps = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Set ModuleName, [Path Abs File])]
pairs)
        thDepFiles :: [Path Abs File]
thDepFiles = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Set ModuleName, [Path Abs File])]
pairs
        modulesRemaining :: Set ModuleName
modulesRemaining = forall a. Ord a => Set a -> Set a -> Set a
S.difference Set ModuleName
moduleDeps Set ModuleName
doneModules
      -- Ignore missing modules discovered as dependencies - they may

      -- have been deleted.

    ([DotCabalPath]
resolvedFiles, Map ModuleName (Path Abs File)
resolvedModules, [ModuleName]
_) <-
      [DotCabalDescriptor]
-> Set ModuleName
-> RIO
     GetPackageFileContext
     ([DotCabalPath], Map ModuleName (Path Abs File), [ModuleName])
loop (forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (forall a. Set a -> [a]
S.toList Set ModuleName
modulesRemaining)) Set ModuleName
doneModules
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ( forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ [DotCabalPath]
foundFiles forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map Path Abs File -> DotCabalPath
DotCabalFilePath [Path Abs File]
thDepFiles forall a. Semigroup a => a -> a -> a
<> [DotCabalPath]
resolvedFiles
      , forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union
            (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(ModuleName, Path Abs File)]
foundModules)
            Map ModuleName (Path Abs File)
resolvedModules
      , [ModuleName]
missingModules
      )
  warnUnlisted :: Map ModuleName b -> f [PackageWarning]
warnUnlisted Map ModuleName b
foundModules = do
    let unlistedModules :: Map ModuleName b
unlistedModules =
          Map ModuleName b
foundModules forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference`
          forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCabalDescriptor -> Maybe ModuleName
dotCabalModule) [DotCabalDescriptor]
names0)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      if forall k a. Map k a -> Bool
M.null Map ModuleName b
unlistedModules
        then []
        else [ NamedComponent -> [ModuleName] -> PackageWarning
UnlistedModulesWarning
                   NamedComponent
component
                   (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall k a. Map k a -> [(k, a)]
M.toList Map ModuleName b
unlistedModules))
             ]
  warnMissing :: p -> f [a]
warnMissing p
_missingModules = do
    forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      -- TODO: bring this back - see

      -- https://github.com/commercialhaskell/stack/issues/2649

      {-
      cabalfp <- asks ctxFile
      pure $
          if null missingModules
             then []
             else [ MissingModulesWarning
                         cabalfp
                         component
                         missingModules]
      -}
  -- TODO: In usages of toResolvedModule / toMissingModule, some sort

  -- of map + partition would probably be better.

  toResolvedModule
    :: (DotCabalDescriptor, Maybe DotCabalPath)
    -> Maybe (ModuleName, Path Abs File)
  toResolvedModule :: (DotCabalDescriptor, Maybe DotCabalPath)
-> Maybe (ModuleName, Path Abs File)
toResolvedModule (DotCabalModule ModuleName
mn, Just (DotCabalModulePath Path Abs File
fp)) =
    forall a. a -> Maybe a
Just (ModuleName
mn, Path Abs File
fp)
  toResolvedModule (DotCabalDescriptor, Maybe DotCabalPath)
_ =
    forall a. Maybe a
Nothing
  toMissingModule
    :: (DotCabalDescriptor, Maybe DotCabalPath)
    -> Maybe ModuleName
  toMissingModule :: (DotCabalDescriptor, Maybe DotCabalPath) -> Maybe ModuleName
toMissingModule (DotCabalModule ModuleName
mn, Maybe DotCabalPath
Nothing) =
    forall a. a -> Maybe a
Just ModuleName
mn
  toMissingModule (DotCabalDescriptor, Maybe DotCabalPath)
_ =
    forall a. Maybe a
Nothing

-- | Get the dependencies of a Haskell module file.

getDependencies
  :: NamedComponent
  -> [Path Abs Dir]
  -> DotCabalPath
  -> RIO GetPackageFileContext (Set ModuleName, [Path Abs File])
getDependencies :: NamedComponent
-> [Path Abs Dir]
-> DotCabalPath
-> RIO GetPackageFileContext (Set ModuleName, [Path Abs File])
getDependencies NamedComponent
component [Path Abs Dir]
dirs DotCabalPath
dotCabalPath =
  case DotCabalPath
dotCabalPath of
    DotCabalModulePath Path Abs File
resolvedFile -> forall {t}.
Path Abs t
-> RIO GetPackageFileContext (Set ModuleName, [Path Abs File])
readResolvedHi Path Abs File
resolvedFile
    DotCabalMainPath Path Abs File
resolvedFile -> forall {t}.
Path Abs t
-> RIO GetPackageFileContext (Set ModuleName, [Path Abs File])
readResolvedHi Path Abs File
resolvedFile
    DotCabalFilePath{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Set a
S.empty, [])
    DotCabalCFilePath{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Set a
S.empty, [])
 where
  readResolvedHi :: Path Abs t
-> RIO GetPackageFileContext (Set ModuleName, [Path Abs File])
readResolvedHi Path Abs t
resolvedFile = do
    Path Abs Dir
dumpHIDir <- NamedComponent -> Path Abs Dir -> Path Abs Dir
componentOutputDir NamedComponent
component forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks GetPackageFileContext -> Path Abs Dir
ctxDistDir
    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)
    let sourceDir :: Path Abs Dir
sourceDir = forall a. a -> Maybe a -> a
fromMaybe Path Abs Dir
dir forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall b t. Path b Dir -> Path b t -> Bool
`isProperPrefixOf` Path Abs t
resolvedFile) [Path Abs Dir]
dirs
        stripSourceDir :: Path Abs Dir -> m (Path Rel t)
stripSourceDir Path Abs Dir
d = forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
d Path Abs t
resolvedFile
    case forall {m :: * -> *}.
MonadThrow m =>
Path Abs Dir -> m (Path Rel t)
stripSourceDir Path Abs Dir
sourceDir of
      Maybe (Path Rel t)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Set a
S.empty, [])
      Just Path Rel t
fileRel -> do
        let hiPath :: String
hiPath = String -> String -> String
FilePath.replaceExtension
                       (forall b t. Path b t -> String
toFilePath (Path Abs Dir
dumpHIDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel t
fileRel))
                       String
".hi"
        Bool
dumpHIExists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
D.doesFileExist String
hiPath
        if Bool
dumpHIExists
          then String
-> RIO GetPackageFileContext (Set ModuleName, [Path Abs File])
parseHI String
hiPath
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Set a
S.empty, [])

-- | Parse a .hi file into a set of modules and files.

parseHI
  :: FilePath -> RIO GetPackageFileContext (Set ModuleName, [Path Abs File])
parseHI :: String
-> RIO GetPackageFileContext (Set ModuleName, [Path Abs File])
parseHI String
hiPath = 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)
  Either String Interface
result <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(NFData a, MonadUnliftIO m) =>
m a -> (SomeException -> m a) -> m a
catchAnyDeep
      (String -> IO (Either String Interface)
Iface.fromFile String
hiPath)
      (\SomeException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (forall e. Exception e => e -> String
displayException SomeException
e)))
  case Either String Interface
result of
    Left String
msg -> do
      forall env. HasConfig env => [StyleDoc] -> RIO env ()
prettyStackDevL
        [ String -> StyleDoc
flow String
"Failed to decode module interface:"
        , Style -> StyleDoc -> StyleDoc
style Style
File forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
hiPath
        , String -> StyleDoc
flow String
"Decoding failure:"
        , Style -> StyleDoc -> StyleDoc
style Style
Error forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
msg
        ]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Set a
S.empty, [])
    Right Interface
iface -> do
      let moduleNames :: Interface -> [ModuleName]
moduleNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8Lenient forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        forall a. List a -> [a]
Iface.unList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> List (ByteString, Bool)
Iface.dmods forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Dependencies
Iface.deps
          resolveFileDependency :: String -> m (Maybe (Path Abs File))
resolveFileDependency String
file = do
            Maybe (Path Abs File)
resolved <-
              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 -> String -> m (Path Abs File)
resolveFile Path Abs Dir
dir String
file)) 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
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe (Path Abs File)
resolved) forall a b. (a -> b) -> a -> b
$
              forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
              [ String -> StyleDoc
flow String
"Dependent file listed in:"
              , Style -> StyleDoc -> StyleDoc
style Style
File forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
hiPath
              , String -> StyleDoc
flow String
"does not exist:"
              , Style -> StyleDoc -> StyleDoc
style Style
File forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
file
              ]
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
resolved
          resolveUsages :: Interface -> RIO GetPackageFileContext [Maybe (Path Abs File)]
resolveUsages = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
            (forall {m :: * -> *} {env}.
(MonadIO m, HasTerm env, MonadReader env m) =>
String -> m (Maybe (Path Abs File))
resolveFileDependency forall b c a. (b -> c) -> (a -> b) -> a -> c
. Usage -> String
Iface.unUsage) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. List a -> [a]
Iface.unList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> List Usage
Iface.usage
      [Path Abs File]
resolvedUsages <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interface -> RIO GetPackageFileContext [Maybe (Path Abs File)]
resolveUsages Interface
iface
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ Interface -> [ModuleName]
moduleNames Interface
iface, [Path Abs File]
resolvedUsages)

-- | The directory where generated files are put like .o or .hs (from .x files).

componentOutputDir :: NamedComponent -> Path Abs Dir -> Path Abs Dir
componentOutputDir :: NamedComponent -> Path Abs Dir -> Path Abs Dir
componentOutputDir NamedComponent
namedComponent Path Abs Dir
distDir =
  case NamedComponent
namedComponent of
    NamedComponent
CLib -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir
    CInternalLib Text
name -> Text -> Path Abs Dir
makeTmp Text
name
    CExe Text
name -> Text -> Path Abs Dir
makeTmp Text
name
    CTest Text
name -> Text -> Path Abs Dir
makeTmp Text
name
    CBench Text
name -> Text -> Path Abs Dir
makeTmp Text
name
 where
  makeTmp :: Text -> Path Abs Dir
makeTmp Text
name =
    Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Text -> Path Rel Dir
componentNameToDir (Text
name forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"-tmp")

-- | Try to resolve the list of base names in the given directory by

-- looking for unique instances of base names applied with the given

-- extensions.

resolveFiles
  :: [Path Abs Dir] -- ^ Directories to look in.

  -> [DotCabalDescriptor] -- ^ Base names.

  -> RIO GetPackageFileContext [(DotCabalDescriptor, Maybe DotCabalPath)]
resolveFiles :: [Path Abs Dir]
-> [DotCabalDescriptor]
-> RIO
     GetPackageFileContext [(DotCabalDescriptor, Maybe DotCabalPath)]
resolveFiles [Path Abs Dir]
dirs [DotCabalDescriptor]
names =
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DotCabalDescriptor]
names (\DotCabalDescriptor
name -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (DotCabalDescriptor
name, ) ([Path Abs Dir]
-> DotCabalDescriptor
-> RIO GetPackageFileContext (Maybe DotCabalPath)
findCandidate [Path Abs Dir]
dirs DotCabalDescriptor
name))

-- | Find a candidate for the given module-or-filename from the list

-- of directories and given extensions.

findCandidate
  :: [Path Abs Dir]
  -> DotCabalDescriptor
  -> RIO GetPackageFileContext (Maybe DotCabalPath)
findCandidate :: [Path Abs Dir]
-> DotCabalDescriptor
-> RIO GetPackageFileContext (Maybe DotCabalPath)
findCandidate [Path Abs Dir]
dirs DotCabalDescriptor
name = do
  PackageName
pkg <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks GetPackageFileContext -> Path Abs File
ctxFile forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
MonadThrow m =>
Path a File -> m PackageName
parsePackageNameFromFilePath
  [Text]
customPreprocessorExts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Config -> [Text]
configCustomPreprocessorExts
  let haskellPreprocessorExts :: [Text]
haskellPreprocessorExts =
        [Text]
haskellDefaultPreprocessorExts forall a. [a] -> [a] -> [a]
++ [Text]
customPreprocessorExts
  [Path Abs File]
candidates <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Text] -> IO [Path Abs File]
makeNameCandidates [Text]
haskellPreprocessorExts
  case [Path Abs File]
candidates of
    [Path Abs File
candidate] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (Path Abs File -> DotCabalPath
cons Path Abs File
candidate))
    [] -> do
      case DotCabalDescriptor
name of
        DotCabalModule ModuleName
mn
          | forall a. Pretty a => a -> String
display ModuleName
mn forall a. Eq a => a -> a -> Bool
/= PackageName -> String
paths_pkg PackageName
pkg -> forall env.
HasTerm env =>
[Path Abs Dir] -> ModuleName -> RIO env ()
logPossibilities [Path Abs Dir]
dirs ModuleName
mn
        DotCabalDescriptor
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    (Path Abs File
candidate:[Path Abs File]
rest) -> do
      forall b t.
DotCabalDescriptor
-> Path b t -> [Path b t] -> RIO GetPackageFileContext ()
warnMultiple DotCabalDescriptor
name Path Abs File
candidate [Path Abs File]
rest
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (Path Abs File -> DotCabalPath
cons Path Abs File
candidate))
 where
  cons :: Path Abs File -> DotCabalPath
cons =
    case DotCabalDescriptor
name of
      DotCabalModule{} -> Path Abs File -> DotCabalPath
DotCabalModulePath
      DotCabalMain{} -> Path Abs File -> DotCabalPath
DotCabalMainPath
      DotCabalFile{} -> Path Abs File -> DotCabalPath
DotCabalFilePath
      DotCabalCFile{} -> Path Abs File -> DotCabalPath
DotCabalCFilePath
  paths_pkg :: PackageName -> String
paths_pkg PackageName
pkg = String
"Paths_" forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
pkg
  makeNameCandidates :: [Text] -> IO [Path Abs File]
makeNameCandidates [Text]
haskellPreprocessorExts =
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
      (forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)
      (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Text] -> Path Abs Dir -> IO [Path Abs File]
makeDirCandidates [Text]
haskellPreprocessorExts) [Path Abs Dir]
dirs)
  makeDirCandidates :: [Text]
                    -> Path Abs Dir
                    -> IO [Path Abs File]
  makeDirCandidates :: [Text] -> Path Abs Dir -> IO [Path Abs File]
makeDirCandidates [Text]
haskellPreprocessorExts Path Abs Dir
dir =
    case DotCabalDescriptor
name of
        DotCabalMain String
fp -> forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Path Abs Dir -> String -> f [Path Abs File]
resolveCandidate Path Abs Dir
dir String
fp
        DotCabalFile String
fp -> forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Path Abs Dir -> String -> f [Path Abs File]
resolveCandidate Path Abs Dir
dir String
fp
        DotCabalCFile String
fp -> forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Path Abs Dir -> String -> f [Path Abs File]
resolveCandidate Path Abs Dir
dir String
fp
        DotCabalModule ModuleName
mn -> do
          let perExt :: Text -> f [Path Abs File]
perExt Text
ext =
                forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Path Abs Dir -> String -> f [Path Abs File]
resolveCandidate
                  Path Abs Dir
dir (ModuleName -> String
Cabal.toFilePath ModuleName
mn forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
ext)
          [[Path Abs File]]
withHaskellExts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Text -> f [Path Abs File]
perExt [Text]
haskellFileExts
          [[Path Abs File]]
withPPExts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Text -> f [Path Abs File]
perExt [Text]
haskellPreprocessorExts
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            case (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Path Abs File]]
withHaskellExts, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Path Abs File]]
withPPExts) of
              -- If we have exactly 1 Haskell extension and exactly

              -- 1 preprocessor extension, assume the former file is

              -- generated from the latter

              --

              -- See https://github.com/commercialhaskell/stack/issues/4076

              ([Path Abs File
_], [Path Abs File
y]) -> [Path Abs File
y]

              -- Otherwise, return everything

              ([Path Abs File]
xs, [Path Abs File]
ys) -> [Path Abs File]
xs forall a. [a] -> [a] -> [a]
++ [Path Abs File]
ys
  resolveCandidate :: Path Abs Dir -> String -> f [Path Abs File]
resolveCandidate Path Abs Dir
dir = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> String -> m (Maybe (Path Abs File))
resolveDirFile Path Abs Dir
dir

-- | Log that we couldn't find a candidate, but there are

-- possibilities for custom preprocessor extensions.

--

-- For example: .erb for a Ruby file might exist in one of the

-- directories.

logPossibilities
  :: HasTerm env
  => [Path Abs Dir]
  -> ModuleName
  -> RIO env ()
logPossibilities :: forall env.
HasTerm env =>
[Path Abs Dir] -> ModuleName -> RIO env ()
logPossibilities [Path Abs Dir]
dirs ModuleName
mn = do
  [Path Rel File]
possibilities <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall {m :: * -> *} {a}.
(MonadIO m, Pretty a) =>
a -> m [[Path Rel File]]
makePossibilities ModuleName
mn)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Rel File]
possibilities) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
    [ String -> StyleDoc
flow String
"Unable to find a known candidate for the Cabal entry"
    , (Style -> StyleDoc -> StyleDoc
style Style
Module forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
display ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
    , String -> StyleDoc
flow String
"but did find:"
    , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> StyleDoc
pretty [Path Rel File]
possibilities)
    , String -> StyleDoc
flow String
"If you are using a custom preprocessor for this module"
    , String -> StyleDoc
flow String
"with its own file extension, consider adding the extension"
    , String -> StyleDoc
flow String
"to the 'custom-preprocessor-extensions' field in stack.yaml."
    ]
 where
  makePossibilities :: a -> m [[Path Rel File]]
makePossibilities a
name =
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      ( \Path Abs Dir
dir -> do
           ([Path Abs Dir]
_,[Path Abs File]
files) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
           forall (f :: * -> *) a. Applicative f => a -> f a
pure
             ( forall a b. (a -> b) -> [a] -> [b]
map
                 forall b. Path b File -> Path Rel File
filename
                 ( forall a. (a -> Bool) -> [a] -> [a]
filter
                     (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (forall a. Pretty a => a -> String
display a
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b File -> Path Rel File
filename)
                     [Path Abs File]
files
                 )
             )
      )
      [Path Abs Dir]
dirs

-- | Get all C sources and extra source files in a build.

buildOtherSources :: BuildInfo -> RIO GetPackageFileContext [DotCabalPath]
buildOtherSources :: BuildInfo -> RIO GetPackageFileContext [DotCabalPath]
buildOtherSources BuildInfo
build = do
  Path Abs Dir
cwd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
  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)
  Path Abs File
file <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks GetPackageFileContext -> Path Abs File
ctxFile
  let resolveDirFiles :: [String] -> (Path Abs File -> b) -> RIO GetPackageFileContext [b]
resolveDirFiles [String]
files Path Abs File -> b
toCabalPath =
        forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM [String]
files forall a b. (a -> b) -> a -> b
$ \String
fp -> do
          Maybe (Path Abs File)
result <- forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> String -> m (Maybe (Path Abs File))
resolveDirFile Path Abs Dir
dir String
fp
          case Maybe (Path Abs File)
result of
            Maybe (Path Abs File)
Nothing -> do
              Text
-> Path Abs Dir
-> String
-> Path Abs File
-> RIO GetPackageFileContext ()
warnMissingFile Text
"File" Path Abs Dir
cwd String
fp Path Abs File
file
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just Path Abs File
p -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Path Abs File -> b
toCabalPath Path Abs File
p)
  [DotCabalPath]
csources <- forall {b}.
[String] -> (Path Abs File -> b) -> RIO GetPackageFileContext [b]
resolveDirFiles (BuildInfo -> [String]
cSources BuildInfo
build) Path Abs File -> DotCabalPath
DotCabalCFilePath
  [DotCabalPath]
jsources <- forall {b}.
[String] -> (Path Abs File -> b) -> RIO GetPackageFileContext [b]
resolveDirFiles (BuildInfo -> [String]
targetJsSources BuildInfo
build) Path Abs File -> DotCabalPath
DotCabalFilePath
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DotCabalPath]
csources forall a. Semigroup a => a -> a -> a
<> [DotCabalPath]
jsources)

-- | Get the target's JS sources.

targetJsSources :: BuildInfo -> [FilePath]
targetJsSources :: BuildInfo -> [String]
targetJsSources = BuildInfo -> [String]
jsSources

-- | Resolve file as a child of a specified directory, symlinks

-- don't get followed.

resolveDirFile
  :: (MonadIO m, MonadThrow m)
  => Path Abs Dir -> FilePath.FilePath -> m (Maybe (Path Abs File))
resolveDirFile :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> String -> m (Maybe (Path Abs File))
resolveDirFile Path Abs Dir
x String
y = do
  -- The standard canonicalizePath does not work for this case

  Path Abs File
p <- forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseCollapsedAbsFile (forall b t. Path b t -> String
toFilePath Path Abs Dir
x String -> String -> String
FilePath.</> String
y)
  Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
p
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
exists then forall a. a -> Maybe a
Just Path Abs File
p else forall a. Maybe a
Nothing

-- | Warn the user that multiple candidates are available for an

-- entry, but that we picked one anyway and continued.

warnMultiple
  :: DotCabalDescriptor
  -> Path b t
  -> [Path b t]
  -> RIO GetPackageFileContext ()
warnMultiple :: forall b t.
DotCabalDescriptor
-> Path b t -> [Path b t] -> RIO GetPackageFileContext ()
warnMultiple DotCabalDescriptor
name Path b t
candidate [Path b t]
rest =
  -- TODO: figure out how to style 'name' and the dispOne stuff

  forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
    [ String -> StyleDoc
flow String
"There were multiple candidates for the Cabal entry"
    , forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCabalDescriptor -> String
showName forall a b. (a -> b) -> a -> b
$ DotCabalDescriptor
name
    , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map forall {b} {t}. Path b t -> StyleDoc
dispOne (Path b t
candidateforall a. a -> [a] -> [a]
:[Path b t]
rest))
    , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"picking:"
    , forall {b} {t}. Path b t -> StyleDoc
dispOne Path b t
candidate
    ]
 where
  showName :: DotCabalDescriptor -> String
showName (DotCabalModule ModuleName
name') = forall a. Pretty a => a -> String
display ModuleName
name'
  showName (DotCabalMain String
fp) = String
fp
  showName (DotCabalFile String
fp) = String
fp
  showName (DotCabalCFile String
fp) = String
fp
  dispOne :: Path b t -> StyleDoc
dispOne = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath
    -- TODO: figure out why dispOne can't be just `display`

    --       (remove the .hlint.yaml exception if it can be)


-- | Parse a package name from a file path.

parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName
parsePackageNameFromFilePath :: forall (m :: * -> *) a.
MonadThrow m =>
Path a File -> m PackageName
parsePackageNameFromFilePath Path a File
fp = do
  String
base <- String -> m String
clean forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ forall b. Path b File -> Path Rel File
filename Path a File
fp
  case String -> Maybe PackageName
parsePackageName String
base of
    Maybe PackageName
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> PackageException
CabalFileNameInvalidPackageName forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path a File
fp
    Just PackageName
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageName
x
 where
  clean :: String -> m String
clean = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {f :: * -> *}. MonadThrow f => String -> f String
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  strip :: String -> f String
strip (Char
'l':Char
'a':Char
'b':Char
'a':Char
'c':Char
'.':String
xs) = forall (f :: * -> *) a. Applicative f => a -> f a
pure String
xs
  strip String
_ = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> PackageException
CabalFileNameParseFail (forall b t. Path b t -> String
toFilePath Path a File
fp))

-- | Resolve the directory, if it can't be resolved, warn for the user

-- (purely to be helpful).

resolveDirOrWarn :: FilePath.FilePath
                 -> RIO GetPackageFileContext (Maybe (Path Abs Dir))
resolveDirOrWarn :: String -> RIO GetPackageFileContext (Maybe (Path Abs Dir))
resolveDirOrWarn = forall a.
Text
-> (Path Abs Dir -> String -> RIO GetPackageFileContext (Maybe a))
-> String
-> RIO GetPackageFileContext (Maybe a)
resolveOrWarn Text
"Directory" forall {m :: * -> *}.
MonadIO m =>
Path Abs Dir -> String -> m (Maybe (Path Abs Dir))
f
 where
  f :: Path Abs Dir -> String -> m (Maybe (Path Abs Dir))
f Path Abs Dir
p String
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 -> String -> m (Path Abs Dir)
resolveDir Path Abs Dir
p String
x)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
Maybe (Path Abs Dir) -> m (Maybe (Path Abs Dir))
rejectMissingDir

-- | Make the global autogen dir if Cabal version is new enough.

packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir)
packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir)
packageAutogenDir Version
cabalVer Path Abs Dir
distDir
  | Version
cabalVer forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2, Int
0] = forall a. Maybe a
Nothing
  | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirGlobalAutogen

-- | Make the autogen dir.

componentAutogenDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentAutogenDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentAutogenDir Version
cabalVer NamedComponent
component Path Abs Dir
distDir =
  Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentBuildDir Version
cabalVer NamedComponent
component Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirAutogen

-- | Make the build dir. Note that Cabal >= 2.0 uses the

-- 'componentBuildDir' above for some things.

buildDir :: Path Abs Dir -> Path Abs Dir
buildDir :: Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir = Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBuild

-- NOTE: don't export this, only use it for valid paths based on

-- component names.

componentNameToDir :: Text -> Path Rel Dir
componentNameToDir :: Text -> Path Rel Dir
componentNameToDir Text
name =
  forall a. a -> Maybe a -> a
fromMaybe (forall a e. Exception e => e -> a
throw PackageException
ComponentNotParsedBug) (forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (Text -> String
T.unpack Text
name))

-- | See 'Distribution.Simple.LocalBuildInfo.componentBuildDir'

componentBuildDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentBuildDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentBuildDir Version
cabalVer NamedComponent
component Path Abs Dir
distDir
  | Version
cabalVer forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2, Int
0] = Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir
  | Bool
otherwise =
      case NamedComponent
component of
        NamedComponent
CLib -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir
        CInternalLib Text
name -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Text -> Path Rel Dir
componentNameToDir Text
name
        CExe Text
name -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Text -> Path Rel Dir
componentNameToDir Text
name
        CTest Text
name -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Text -> Path Rel Dir
componentNameToDir Text
name
        CBench Text
name -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Text -> Path Rel Dir
componentNameToDir Text
name

-- Internal helper to define resolveFileOrWarn and resolveDirOrWarn

resolveOrWarn :: Text
              -> (Path Abs Dir -> String -> RIO GetPackageFileContext (Maybe a))
              -> FilePath.FilePath
              -> RIO GetPackageFileContext (Maybe a)
resolveOrWarn :: forall a.
Text
-> (Path Abs Dir -> String -> RIO GetPackageFileContext (Maybe a))
-> String
-> RIO GetPackageFileContext (Maybe a)
resolveOrWarn Text
subject Path Abs Dir -> String -> RIO GetPackageFileContext (Maybe a)
resolver String
path = do
  Path Abs Dir
cwd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
  Path Abs File
file <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks GetPackageFileContext -> Path Abs File
ctxFile
  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)
  Maybe a
result <- Path Abs Dir -> String -> RIO GetPackageFileContext (Maybe a)
resolver Path Abs Dir
dir String
path
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe a
result) forall a b. (a -> b) -> a -> b
$ Text
-> Path Abs Dir
-> String
-> Path Abs File
-> RIO GetPackageFileContext ()
warnMissingFile Text
subject Path Abs Dir
cwd String
path Path Abs File
file
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
result

warnMissingFile
  :: Text
  -> Path Abs Dir
  -> FilePath
  -> Path Abs File
  -> RIO GetPackageFileContext ()
warnMissingFile :: Text
-> Path Abs Dir
-> String
-> Path Abs File
-> RIO GetPackageFileContext ()
warnMissingFile Text
subject Path Abs Dir
cwd String
path Path Abs File
fromFile =
  forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
    [ forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
subject -- TODO: needs style?

    , String -> StyleDoc
flow String
"listed in"
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fromFile) forall a. Pretty a => a -> StyleDoc
pretty (forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
cwd Path Abs File
fromFile)
    , String -> StyleDoc
flow String
"file does not exist:"
    , Style -> StyleDoc -> StyleDoc
style Style
Dir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String
path
    ]