{-# 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