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 =
  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
    Verbosity -> FilePattern -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
Cabal.verbose (Path Abs File -> FilePattern
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 =
  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]
[SymbolicPath PackageDir SourceDir]
[PkgconfigDependency]
[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 :: [FilePattern]
extraFrameworkDirs :: [FilePattern]
asmSources :: [FilePattern]
cmmSources :: [FilePattern]
cSources :: [FilePattern]
cxxSources :: [FilePattern]
jsSources :: [FilePattern]
hsSourceDirs :: [SymbolicPath PackageDir SourceDir]
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 :: [FilePattern]
extraLibDirsStatic :: [FilePattern]
includeDirs :: [FilePattern]
includes :: [FilePattern]
autogenIncludes :: [FilePattern]
installIncludes :: [FilePattern]
options :: PerCompilerFlavor [FilePattern]
profOptions :: PerCompilerFlavor [FilePattern]
sharedOptions :: PerCompilerFlavor [FilePattern]
staticOptions :: PerCompilerFlavor [FilePattern]
customFieldsBI :: [(FilePattern, FilePattern)]
targetBuildDepends :: [Dependency]
mixins :: [Mixin]
buildToolDepends :: BuildInfo -> [ExeDependency]
hsSourceDirs :: BuildInfo -> [SymbolicPath PackageDir SourceDir]
buildable :: BuildInfo -> Bool
buildTools :: BuildInfo -> [LegacyExeDependency]
cppOptions :: BuildInfo -> [FilePattern]
asmOptions :: BuildInfo -> [FilePattern]
cmmOptions :: BuildInfo -> [FilePattern]
ccOptions :: BuildInfo -> [FilePattern]
cxxOptions :: BuildInfo -> [FilePattern]
ldOptions :: BuildInfo -> [FilePattern]
hsc2hsOptions :: BuildInfo -> [FilePattern]
pkgconfigDepends :: BuildInfo -> [PkgconfigDependency]
frameworks :: BuildInfo -> [FilePattern]
extraFrameworkDirs :: BuildInfo -> [FilePattern]
asmSources :: BuildInfo -> [FilePattern]
cmmSources :: BuildInfo -> [FilePattern]
cSources :: BuildInfo -> [FilePattern]
cxxSources :: BuildInfo -> [FilePattern]
jsSources :: BuildInfo -> [FilePattern]
otherModules :: BuildInfo -> [ModuleName]
virtualModules :: BuildInfo -> [ModuleName]
autogenModules :: BuildInfo -> [ModuleName]
defaultLanguage :: BuildInfo -> Maybe Language
otherLanguages :: BuildInfo -> [Language]
defaultExtensions :: BuildInfo -> [Extension]
otherExtensions :: BuildInfo -> [Extension]
oldExtensions :: BuildInfo -> [Extension]
extraLibs :: BuildInfo -> [FilePattern]
extraLibsStatic :: BuildInfo -> [FilePattern]
extraGHCiLibs :: BuildInfo -> [FilePattern]
extraBundledLibs :: BuildInfo -> [FilePattern]
extraLibFlavours :: BuildInfo -> [FilePattern]
extraDynLibFlavours :: BuildInfo -> [FilePattern]
extraLibDirs :: BuildInfo -> [FilePattern]
extraLibDirsStatic :: BuildInfo -> [FilePattern]
includeDirs :: BuildInfo -> [FilePattern]
includes :: BuildInfo -> [FilePattern]
autogenIncludes :: BuildInfo -> [FilePattern]
installIncludes :: BuildInfo -> [FilePattern]
options :: BuildInfo -> PerCompilerFlavor [FilePattern]
profOptions :: BuildInfo -> PerCompilerFlavor [FilePattern]
sharedOptions :: BuildInfo -> PerCompilerFlavor [FilePattern]
staticOptions :: BuildInfo -> PerCompilerFlavor [FilePattern]
customFieldsBI :: BuildInfo -> [(FilePattern, FilePattern)]
targetBuildDepends :: BuildInfo -> [Dependency]
mixins :: BuildInfo -> [Mixin]
..} =
      (SymbolicPath PackageDir SourceDir -> Bool)
-> [SymbolicPath PackageDir SourceDir] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePattern -> Bool
matchSourceDir (FilePattern -> Bool)
-> (SymbolicPath PackageDir SourceDir -> FilePattern)
-> SymbolicPath PackageDir SourceDir
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath PackageDir SourceDir -> FilePattern
forall from to. SymbolicPath from to -> FilePattern
getSymbolicPath) [SymbolicPath PackageDir SourceDir]
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