{-# language CPP #-}

module Hix.Cabal where

import Control.Monad.Trans.Except (ExceptT (ExceptT), throwE)
import Distribution.PackageDescription (BuildInfo (..), GenericPackageDescription (..))
import Distribution.Types.Benchmark (benchmarkBuildInfo)
import Distribution.Types.CondTree (CondTree (..))
import qualified Distribution.Types.Executable as Executable
import Distribution.Types.Library (Library (..))
import Distribution.Types.TestSuite (testBuildInfo)
import Distribution.Utils.Path (getSymbolicPath)
import qualified Distribution.Verbosity as Cabal
import Exon (exon)
import Path (
  Abs,
  Dir,
  File,
  Path,
  Rel,
  absdir,
  isProperPrefixOf,
  parent,
  parseRelDir,
  parseRelFile,
  stripProperPrefix,
  toFilePath,
  (</>),
  )
import System.FilePattern.Directory (getDirectoryFiles)
import System.IO.Error (tryIOError)

import Hix.Compat (readGenericPackageDescription)
import Hix.Data.Error (Error (..))
import Hix.Error (pathText, sourceError)

#if MIN_VERSION_Cabal(3,14,0)
import Distribution.Utils.Path (makeSymbolicPath)
#endif

noMatch :: Text -> Path b File -> ExceptT Error IO a
noMatch :: forall b a. Text -> Path b File -> ExceptT Error IO a
noMatch Text
reason Path b File
source =
  Error -> ExceptT Error IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> Error
NoMatch (Text -> Path b File -> Text
forall b t. Text -> Path b t -> Text
sourceError Text
reason Path b File
source))

cabalsInDir ::
  Path Abs Dir ->
  ExceptT Error IO [Path Abs File]
cabalsInDir :: Path Abs Dir -> ExceptT Error IO [Path Abs File]
cabalsInDir Path Abs Dir
dir = do
  [FilePattern]
matches <- IO [FilePattern] -> ExceptT Error IO [FilePattern]
forall a. IO a -> ExceptT Error IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePattern -> [FilePattern] -> IO [FilePattern]
getDirectoryFiles (Path Abs Dir -> FilePattern
forall b t. Path b t -> FilePattern
toFilePath Path Abs Dir
dir) [FilePattern
Item [FilePattern]
"*.cabal"])
  let err :: Error
err = Text -> Error
PreprocError [exon|Internal error when parsing globbed paths in '#{pathText dir}': #{show matches}|]
  ExceptT Error IO [Path Abs File]
-> ([Path Abs File] -> ExceptT Error IO [Path Abs File])
-> Maybe [Path Abs File]
-> ExceptT Error IO [Path Abs File]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Error -> ExceptT Error IO [Path Abs File]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Error
err) [Path Abs File] -> ExceptT Error IO [Path Abs File]
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FilePattern -> Maybe (Path Abs File))
-> [FilePattern] -> Maybe [Path Abs File]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse FilePattern -> Maybe (Path Abs File)
parse [FilePattern]
matches)
  where
    parse :: FilePattern -> Maybe (Path Abs File)
parse FilePattern
f = do
      Path Rel File
rel <- FilePattern -> Maybe (Path Rel File)
forall (m :: * -> *).
MonadThrow m =>
FilePattern -> m (Path Rel File)
parseRelFile FilePattern
f
      pure (Path Abs Dir
dir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
rel)

findCabal ::
  Path Abs File ->
  ExceptT Error IO (Path Abs File, Path Rel File)
findCabal :: Path Abs File -> ExceptT Error IO (Path Abs File, Path Rel File)
findCabal Path Abs File
source =
  Path Abs Dir -> ExceptT Error IO (Path Abs File, Path Rel File)
spin (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
source)
  where
    spin :: Path Abs Dir -> ExceptT Error IO (Path Abs File, Path Rel File)
spin Path Abs Dir
dir
      | Path Abs Dir
dir Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
== [absdir|/nix/store|] = ExceptT Error IO (Path Abs File, Path Rel File)
notFound
      | Path Abs Dir
dir Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs Dir
dir = ExceptT Error IO (Path Abs File, Path Rel File)
notFound
      | Bool
otherwise = Path Abs Dir -> ExceptT Error IO (Path Abs File, Path Rel File)
tryDir Path Abs Dir
dir
    tryDir :: Path Abs Dir -> ExceptT Error IO (Path Abs File, Path Rel File)
tryDir Path Abs Dir
dir =
      Path Abs Dir -> ExceptT Error IO [Path Abs File]
cabalsInDir Path Abs Dir
dir ExceptT Error IO [Path Abs File]
-> ([Path Abs File]
    -> ExceptT Error IO (Path Abs File, Path Rel File))
-> ExceptT Error IO (Path Abs File, Path Rel File)
forall a b.
ExceptT Error IO a
-> (a -> ExceptT Error IO b) -> ExceptT Error IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [Item [Path Abs File]
cabal] -> do
          Path Rel File
sub <- Path Abs Dir -> Path Abs File -> ExceptT Error IO (Path Rel File)
forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Item [Path Abs File]
Path Abs File
cabal) Path Abs File
source
          pure (Item [Path Abs File]
Path Abs File
cabal, Path Rel File
sub)
        [] -> Path Abs Dir -> ExceptT Error IO (Path Abs File, Path Rel File)
spin (Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs Dir
dir)
        [Path Abs File]
_ -> Error -> ExceptT Error IO (Path Abs File, Path Rel File)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> Error
PreprocError (Text -> Path Abs File -> Text
forall b t. Text -> Path b t -> Text
sourceError Text
"Multiple cabal files in parent dir of" Path Abs File
source))
    notFound :: ExceptT Error IO (Path Abs File, Path Rel File)
notFound =
      Text
-> Path Abs File -> ExceptT Error IO (Path Abs File, Path Rel File)
forall b a. Text -> Path b File -> ExceptT Error IO a
noMatch Text
"No cabal file found for " Path Abs File
source

parseCabal :: Path Abs File -> ExceptT Error IO GenericPackageDescription
parseCabal :: Path Abs File -> ExceptT Error IO GenericPackageDescription
parseCabal Path Abs File
path =
  IO (Either Error GenericPackageDescription)
-> ExceptT Error IO GenericPackageDescription
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Error GenericPackageDescription)
 -> ExceptT Error IO GenericPackageDescription)
-> IO (Either Error GenericPackageDescription)
-> ExceptT Error IO GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ (Either IOError GenericPackageDescription
 -> Either Error GenericPackageDescription)
-> IO (Either IOError GenericPackageDescription)
-> IO (Either Error GenericPackageDescription)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IOError -> Error)
-> Either IOError GenericPackageDescription
-> Either Error GenericPackageDescription
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Error
PreprocError (Text -> Error) -> (IOError -> Text) -> IOError -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Text
forall b a. (Show a, IsString b) => a -> b
show)) (IO (Either IOError GenericPackageDescription)
 -> IO (Either Error GenericPackageDescription))
-> IO (Either IOError GenericPackageDescription)
-> IO (Either Error GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ IO GenericPackageDescription
-> IO (Either IOError GenericPackageDescription)
forall a. IO a -> IO (Either IOError a)
tryIOError do
#if MIN_VERSION_Cabal(3,14,0)
    HasCallStack =>
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
readGenericPackageDescription Verbosity
Cabal.verbose Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing (FilePattern -> SymbolicPath Pkg 'File
forall from (to :: FileOrDir). FilePattern -> SymbolicPath from to
makeSymbolicPath (Path Abs File -> FilePattern
forall b t. Path b t -> FilePattern
toFilePath Path Abs File
path))
#else
    readGenericPackageDescription Cabal.verbose (toFilePath path)
#endif

buildInfo ::
  (a -> BuildInfo) ->
  (b, CondTree c d a) ->
  BuildInfo
buildInfo :: forall a b c d.
(a -> BuildInfo) -> (b, CondTree c d a) -> BuildInfo
buildInfo a -> BuildInfo
f (b
_, CondTree c d a
t) =
  a -> BuildInfo
f CondTree c d a
t.condTreeData

matchComponent :: GenericPackageDescription -> Path Rel File -> ExceptT Error IO BuildInfo
matchComponent :: GenericPackageDescription
-> Path Rel File -> ExceptT Error IO BuildInfo
matchComponent GenericPackageDescription
pkg Path Rel File
source =
  ExceptT Error IO BuildInfo
-> (BuildInfo -> ExceptT Error IO BuildInfo)
-> Maybe BuildInfo
-> ExceptT Error IO BuildInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Path Rel File -> ExceptT Error IO BuildInfo
forall b a. Text -> Path b File -> ExceptT Error IO a
noMatch Text
"cabal component" Path Rel File
source) BuildInfo -> ExceptT Error IO BuildInfo
forall a. a -> ExceptT Error IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((BuildInfo -> Bool) -> [BuildInfo] -> Maybe BuildInfo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find BuildInfo -> Bool
matchSource [BuildInfo]
infos)
  where
    matchSource :: BuildInfo -> Bool
matchSource BuildInfo {Bool
[FilePattern]
[(FilePattern, FilePattern)]
[ModuleName]
[Dependency]
[Extension]
[Language]
[PkgconfigDependency]
[SymbolicPath Include 'File]
[SymbolicPath Pkg 'File]
[SymbolicPath Pkg ('Dir Framework)]
[SymbolicPath Pkg ('Dir Lib)]
[SymbolicPath Pkg ('Dir Include)]
[SymbolicPath Pkg ('Dir Source)]
[RelativePath Framework 'File]
[RelativePath Include 'File]
[Mixin]
[LegacyExeDependency]
[ExeDependency]
Maybe Language
PerCompilerFlavor [FilePattern]
buildable :: Bool
buildTools :: [LegacyExeDependency]
buildToolDepends :: [ExeDependency]
cppOptions :: [FilePattern]
asmOptions :: [FilePattern]
cmmOptions :: [FilePattern]
ccOptions :: [FilePattern]
cxxOptions :: [FilePattern]
ldOptions :: [FilePattern]
hsc2hsOptions :: [FilePattern]
pkgconfigDepends :: [PkgconfigDependency]
frameworks :: [RelativePath Framework 'File]
extraFrameworkDirs :: [SymbolicPath Pkg ('Dir Framework)]
asmSources :: [SymbolicPath Pkg 'File]
cmmSources :: [SymbolicPath Pkg 'File]
cSources :: [SymbolicPath Pkg 'File]
cxxSources :: [SymbolicPath Pkg 'File]
jsSources :: [SymbolicPath Pkg 'File]
hsSourceDirs :: [SymbolicPath Pkg ('Dir Source)]
otherModules :: [ModuleName]
virtualModules :: [ModuleName]
autogenModules :: [ModuleName]
defaultLanguage :: Maybe Language
otherLanguages :: [Language]
defaultExtensions :: [Extension]
otherExtensions :: [Extension]
oldExtensions :: [Extension]
extraLibs :: [FilePattern]
extraLibsStatic :: [FilePattern]
extraGHCiLibs :: [FilePattern]
extraBundledLibs :: [FilePattern]
extraLibFlavours :: [FilePattern]
extraDynLibFlavours :: [FilePattern]
extraLibDirs :: [SymbolicPath Pkg ('Dir Lib)]
extraLibDirsStatic :: [SymbolicPath Pkg ('Dir Lib)]
includeDirs :: [SymbolicPath Pkg ('Dir Include)]
includes :: [SymbolicPath Include 'File]
autogenIncludes :: [RelativePath Include 'File]
installIncludes :: [RelativePath Include 'File]
options :: PerCompilerFlavor [FilePattern]
profOptions :: PerCompilerFlavor [FilePattern]
sharedOptions :: PerCompilerFlavor [FilePattern]
profSharedOptions :: PerCompilerFlavor [FilePattern]
staticOptions :: PerCompilerFlavor [FilePattern]
customFieldsBI :: [(FilePattern, FilePattern)]
targetBuildDepends :: [Dependency]
mixins :: [Mixin]
buildToolDepends :: BuildInfo -> [ExeDependency]
asmSources :: BuildInfo -> [SymbolicPath Pkg 'File]
cSources :: BuildInfo -> [SymbolicPath Pkg 'File]
hsSourceDirs :: BuildInfo -> [SymbolicPath Pkg ('Dir Source)]
mixins :: BuildInfo -> [Mixin]
targetBuildDepends :: BuildInfo -> [Dependency]
customFieldsBI :: BuildInfo -> [(FilePattern, FilePattern)]
staticOptions :: BuildInfo -> PerCompilerFlavor [FilePattern]
profSharedOptions :: BuildInfo -> PerCompilerFlavor [FilePattern]
sharedOptions :: BuildInfo -> PerCompilerFlavor [FilePattern]
profOptions :: BuildInfo -> PerCompilerFlavor [FilePattern]
options :: BuildInfo -> PerCompilerFlavor [FilePattern]
installIncludes :: BuildInfo -> [RelativePath Include 'File]
autogenIncludes :: BuildInfo -> [RelativePath Include 'File]
includes :: BuildInfo -> [SymbolicPath Include 'File]
includeDirs :: BuildInfo -> [SymbolicPath Pkg ('Dir Include)]
extraLibDirsStatic :: BuildInfo -> [SymbolicPath Pkg ('Dir Lib)]
extraLibDirs :: BuildInfo -> [SymbolicPath Pkg ('Dir Lib)]
extraDynLibFlavours :: BuildInfo -> [FilePattern]
extraLibFlavours :: BuildInfo -> [FilePattern]
extraBundledLibs :: BuildInfo -> [FilePattern]
extraGHCiLibs :: BuildInfo -> [FilePattern]
extraLibsStatic :: BuildInfo -> [FilePattern]
extraLibs :: BuildInfo -> [FilePattern]
oldExtensions :: BuildInfo -> [Extension]
otherExtensions :: BuildInfo -> [Extension]
defaultExtensions :: BuildInfo -> [Extension]
otherLanguages :: BuildInfo -> [Language]
defaultLanguage :: BuildInfo -> Maybe Language
autogenModules :: BuildInfo -> [ModuleName]
virtualModules :: BuildInfo -> [ModuleName]
otherModules :: BuildInfo -> [ModuleName]
jsSources :: BuildInfo -> [SymbolicPath Pkg 'File]
cxxSources :: BuildInfo -> [SymbolicPath Pkg 'File]
cmmSources :: BuildInfo -> [SymbolicPath Pkg 'File]
extraFrameworkDirs :: BuildInfo -> [SymbolicPath Pkg ('Dir Framework)]
frameworks :: BuildInfo -> [RelativePath Framework 'File]
pkgconfigDepends :: BuildInfo -> [PkgconfigDependency]
hsc2hsOptions :: BuildInfo -> [FilePattern]
ldOptions :: BuildInfo -> [FilePattern]
cxxOptions :: BuildInfo -> [FilePattern]
ccOptions :: BuildInfo -> [FilePattern]
cmmOptions :: BuildInfo -> [FilePattern]
asmOptions :: BuildInfo -> [FilePattern]
cppOptions :: BuildInfo -> [FilePattern]
buildTools :: BuildInfo -> [LegacyExeDependency]
buildable :: BuildInfo -> Bool
..} =
      (SymbolicPath Pkg ('Dir Source) -> Bool)
-> [SymbolicPath Pkg ('Dir Source)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePattern -> Bool
matchSourceDir (FilePattern -> Bool)
-> (SymbolicPath Pkg ('Dir Source) -> FilePattern)
-> SymbolicPath Pkg ('Dir Source)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg ('Dir Source) -> FilePattern
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePattern
getSymbolicPath) [SymbolicPath Pkg ('Dir Source)]
hsSourceDirs
    matchSourceDir :: FilePattern -> Bool
matchSourceDir FilePattern
dir
      | Just Path Rel Dir
p <- FilePattern -> Maybe (Path Rel Dir)
forall (m :: * -> *).
MonadThrow m =>
FilePattern -> m (Path Rel Dir)
parseRelDir FilePattern
dir, Path Rel Dir -> Path Rel File -> Bool
forall b t. Path b Dir -> Path b t -> Bool
isProperPrefixOf Path Rel Dir
p Path Rel File
source = Bool
True
      | Bool
otherwise = Bool
False
    infos :: [BuildInfo]
infos =
      ((.condTreeData.libBuildInfo) (CondTree ConfVar [Dependency] Library -> BuildInfo)
-> [CondTree ConfVar [Dependency] Library] -> [BuildInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (CondTree ConfVar [Dependency] Library)
-> [CondTree ConfVar [Dependency] Library]
forall a. Maybe a -> [a]
maybeToList GenericPackageDescription
pkg.condLibrary) [BuildInfo] -> [BuildInfo] -> [BuildInfo]
forall a. Semigroup a => a -> a -> a
<>
      ((Library -> BuildInfo)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> BuildInfo
forall a b c d.
(a -> BuildInfo) -> (b, CondTree c d a) -> BuildInfo
buildInfo Library -> BuildInfo
libBuildInfo ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
 -> BuildInfo)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [BuildInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenericPackageDescription
pkg.condSubLibraries) [BuildInfo] -> [BuildInfo] -> [BuildInfo]
forall a. Semigroup a => a -> a -> a
<>
      ((Executable -> BuildInfo)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> BuildInfo
forall a b c d.
(a -> BuildInfo) -> (b, CondTree c d a) -> BuildInfo
buildInfo Executable -> BuildInfo
Executable.buildInfo ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
 -> BuildInfo)
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [BuildInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenericPackageDescription
pkg.condExecutables) [BuildInfo] -> [BuildInfo] -> [BuildInfo]
forall a. Semigroup a => a -> a -> a
<>
      ((TestSuite -> BuildInfo)
-> (UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
-> BuildInfo
forall a b c d.
(a -> BuildInfo) -> (b, CondTree c d a) -> BuildInfo
buildInfo TestSuite -> BuildInfo
testBuildInfo ((UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)
 -> BuildInfo)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> [BuildInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenericPackageDescription
pkg.condTestSuites) [BuildInfo] -> [BuildInfo] -> [BuildInfo]
forall a. Semigroup a => a -> a -> a
<>
      ((Benchmark -> BuildInfo)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
-> BuildInfo
forall a b c d.
(a -> BuildInfo) -> (b, CondTree c d a) -> BuildInfo
buildInfo Benchmark -> BuildInfo
benchmarkBuildInfo ((UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)
 -> BuildInfo)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> [BuildInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenericPackageDescription
pkg.condBenchmarks)

buildInfoForFile :: Path Abs File -> ExceptT Error IO BuildInfo
buildInfoForFile :: Path Abs File -> ExceptT Error IO BuildInfo
buildInfoForFile Path Abs File
source = do
  (Path Abs File
cabalPath, Path Rel File
sourceRel) <- Path Abs File -> ExceptT Error IO (Path Abs File, Path Rel File)
findCabal Path Abs File
source
  GenericPackageDescription
pkg <- Path Abs File -> ExceptT Error IO GenericPackageDescription
parseCabal Path Abs File
cabalPath
  GenericPackageDescription
-> Path Rel File -> ExceptT Error IO BuildInfo
matchComponent GenericPackageDescription
pkg Path Rel File
sourceRel