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 (..), pathText, sourceError)

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 =
  forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> Error
NoMatch (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePattern -> [FilePattern] -> IO [FilePattern]
getDirectoryFiles (forall b t. Path b t -> FilePattern
toFilePath Path Abs Dir
dir) [FilePattern
"*.cabal"])
  let err :: Error
err = Text -> Error
PreprocError [exon|Internal error when parsing globbed paths in '#{pathText dir}': #{show matches}|]
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Error
err) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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 <- forall (m :: * -> *).
MonadThrow m =>
FilePattern -> m (Path Rel File)
parseRelFile FilePattern
f
      pure (Path Abs Dir
dir 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 (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 forall a. Eq a => a -> a -> Bool
== [absdir|/nix/store|] = ExceptT Error IO (Path Abs File, Path Rel File)
notFound
      | Path Abs Dir
dir forall a. Eq a => a -> a -> Bool
== 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [Item [Path Abs File]
cabal] -> do
          Path Rel File
sub <- forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix (forall b t. Path b t -> Path b Dir
parent Item [Path Abs File]
cabal) Path Abs File
source
          pure (Item [Path Abs File]
cabal, Path Rel File
sub)
        [] -> Path Abs Dir -> ExceptT Error IO (Path Abs File, Path Rel File)
spin (forall b t. Path b t -> Path b Dir
parent Path Abs Dir
dir)
        [Path Abs File]
_ -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> Error
PreprocError (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 =
      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 =
  forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Error
PreprocError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show)) forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Either IOError a)
tryIOError do
    Verbosity -> FilePattern -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
Cabal.verbose (forall b t. Path b t -> FilePattern
toFilePath Path Abs File
path)

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 =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall b a. Text -> Path b File -> ExceptT Error IO a
noMatch Text
"cabal component" Path Rel File
source) forall (f :: * -> *) a. Applicative f => a -> f a
pure (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)]
[Language]
[Extension]
[Dependency]
[ExeDependency]
[LegacyExeDependency]
[Mixin]
[ModuleName]
[PkgconfigDependency]
[SymbolicPath PackageDir SourceDir]
Maybe Language
PerCompilerFlavor [FilePattern]
asmOptions :: BuildInfo -> [FilePattern]
asmSources :: BuildInfo -> [FilePattern]
autogenIncludes :: BuildInfo -> [FilePattern]
autogenModules :: BuildInfo -> [ModuleName]
buildToolDepends :: BuildInfo -> [ExeDependency]
buildTools :: BuildInfo -> [LegacyExeDependency]
buildable :: BuildInfo -> Bool
cSources :: BuildInfo -> [FilePattern]
ccOptions :: BuildInfo -> [FilePattern]
cmmOptions :: BuildInfo -> [FilePattern]
cmmSources :: BuildInfo -> [FilePattern]
cppOptions :: BuildInfo -> [FilePattern]
customFieldsBI :: BuildInfo -> [(FilePattern, FilePattern)]
cxxOptions :: BuildInfo -> [FilePattern]
cxxSources :: BuildInfo -> [FilePattern]
defaultExtensions :: BuildInfo -> [Extension]
defaultLanguage :: BuildInfo -> Maybe Language
extraBundledLibs :: BuildInfo -> [FilePattern]
extraDynLibFlavours :: BuildInfo -> [FilePattern]
extraFrameworkDirs :: BuildInfo -> [FilePattern]
extraGHCiLibs :: BuildInfo -> [FilePattern]
extraLibDirs :: BuildInfo -> [FilePattern]
extraLibFlavours :: BuildInfo -> [FilePattern]
extraLibs :: BuildInfo -> [FilePattern]
frameworks :: BuildInfo -> [FilePattern]
hsSourceDirs :: BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsc2hsOptions :: BuildInfo -> [FilePattern]
includeDirs :: BuildInfo -> [FilePattern]
includes :: BuildInfo -> [FilePattern]
installIncludes :: BuildInfo -> [FilePattern]
jsSources :: BuildInfo -> [FilePattern]
ldOptions :: BuildInfo -> [FilePattern]
mixins :: BuildInfo -> [Mixin]
oldExtensions :: BuildInfo -> [Extension]
options :: BuildInfo -> PerCompilerFlavor [FilePattern]
otherExtensions :: BuildInfo -> [Extension]
otherLanguages :: BuildInfo -> [Language]
otherModules :: BuildInfo -> [ModuleName]
pkgconfigDepends :: BuildInfo -> [PkgconfigDependency]
profOptions :: BuildInfo -> PerCompilerFlavor [FilePattern]
sharedOptions :: BuildInfo -> PerCompilerFlavor [FilePattern]
staticOptions :: BuildInfo -> PerCompilerFlavor [FilePattern]
targetBuildDepends :: BuildInfo -> [Dependency]
virtualModules :: BuildInfo -> [ModuleName]
mixins :: [Mixin]
targetBuildDepends :: [Dependency]
customFieldsBI :: [(FilePattern, FilePattern)]
staticOptions :: PerCompilerFlavor [FilePattern]
sharedOptions :: PerCompilerFlavor [FilePattern]
profOptions :: PerCompilerFlavor [FilePattern]
options :: PerCompilerFlavor [FilePattern]
installIncludes :: [FilePattern]
autogenIncludes :: [FilePattern]
includes :: [FilePattern]
includeDirs :: [FilePattern]
extraLibDirs :: [FilePattern]
extraDynLibFlavours :: [FilePattern]
extraLibFlavours :: [FilePattern]
extraBundledLibs :: [FilePattern]
extraGHCiLibs :: [FilePattern]
extraLibs :: [FilePattern]
oldExtensions :: [Extension]
otherExtensions :: [Extension]
defaultExtensions :: [Extension]
otherLanguages :: [Language]
defaultLanguage :: Maybe Language
autogenModules :: [ModuleName]
virtualModules :: [ModuleName]
otherModules :: [ModuleName]
hsSourceDirs :: [SymbolicPath PackageDir SourceDir]
jsSources :: [FilePattern]
cxxSources :: [FilePattern]
cSources :: [FilePattern]
cmmSources :: [FilePattern]
asmSources :: [FilePattern]
extraFrameworkDirs :: [FilePattern]
frameworks :: [FilePattern]
pkgconfigDepends :: [PkgconfigDependency]
hsc2hsOptions :: [FilePattern]
ldOptions :: [FilePattern]
cxxOptions :: [FilePattern]
ccOptions :: [FilePattern]
cmmOptions :: [FilePattern]
asmOptions :: [FilePattern]
cppOptions :: [FilePattern]
buildToolDepends :: [ExeDependency]
buildTools :: [LegacyExeDependency]
buildable :: Bool
..} =
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePattern -> Bool
matchSourceDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall from to. SymbolicPath from to -> FilePattern
getSymbolicPath) [SymbolicPath PackageDir SourceDir]
hsSourceDirs
    matchSourceDir :: FilePattern -> Bool
matchSourceDir FilePattern
dir
      | Just Path Rel Dir
p <- forall (m :: * -> *).
MonadThrow m =>
FilePattern -> m (Path Rel Dir)
parseRelDir FilePattern
dir, 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Maybe a -> [a]
maybeToList GenericPackageDescription
pkg.condLibrary) forall a. Semigroup a => a -> a -> a
<>
      (forall a b c d.
(a -> BuildInfo) -> (b, CondTree c d a) -> BuildInfo
buildInfo Library -> BuildInfo
libBuildInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenericPackageDescription
pkg.condSubLibraries) forall a. Semigroup a => a -> a -> a
<>
      (forall a b c d.
(a -> BuildInfo) -> (b, CondTree c d a) -> BuildInfo
buildInfo Executable -> BuildInfo
Executable.buildInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenericPackageDescription
pkg.condExecutables) forall a. Semigroup a => a -> a -> a
<>
      (forall a b c d.
(a -> BuildInfo) -> (b, CondTree c d a) -> BuildInfo
buildInfo TestSuite -> BuildInfo
testBuildInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenericPackageDescription
pkg.condTestSuites) forall a. Semigroup a => a -> a -> a
<>
      (forall a b c d.
(a -> BuildInfo) -> (b, CondTree c d a) -> BuildInfo
buildInfo Benchmark -> BuildInfo
benchmarkBuildInfo 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