aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CabalHelper/Compile.hs1
-rw-r--r--CabalHelper/Data.hs1
-rw-r--r--CabalHelper/Licenses.hs105
-rw-r--r--CabalHelper/Main.hs6
-rw-r--r--CabalHelper/Types.hs1
-rw-r--r--Distribution/Helper.hs15
6 files changed, 126 insertions, 3 deletions
diff --git a/CabalHelper/Compile.hs b/CabalHelper/Compile.hs
index 86020d6..5e72a39 100644
--- a/CabalHelper/Compile.hs
+++ b/CabalHelper/Compile.hs
@@ -174,6 +174,7 @@ compile distdir opts@Options {..} Compile {..} = do
if isNothing cCabalSourceDir
then [ "-hide-all-packages"
, "-package", "base"
+ , "-package", "containers"
, "-package", "directory"
, "-package", "filepath"
, "-package", "process"
diff --git a/CabalHelper/Data.hs b/CabalHelper/Data.hs
index 6f86ff9..2c3404a 100644
--- a/CabalHelper/Data.hs
+++ b/CabalHelper/Data.hs
@@ -41,5 +41,6 @@ sourceFiles =
[ ("Main.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Main.hs")))
, ("Common.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Common.hs")))
, ("Sandbox.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Sandbox.hs")))
+ , ("Licenses.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Licenses.hs")))
, ("Types.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Types.hs")))
]
diff --git a/CabalHelper/Licenses.hs b/CabalHelper/Licenses.hs
new file mode 100644
index 0000000..9d11f3a
--- /dev/null
+++ b/CabalHelper/Licenses.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE CPP #-}
+module CabalHelper.Licenses where
+
+-- Copyright (c) 2014, Jasper Van der Jeugt <m@jaspervdj.be>
+
+--------------------------------------------------------------------------------
+import Control.Arrow ((***), (&&&))
+import Control.Monad (forM_, unless)
+import Data.List (foldl', sort)
+import Data.Maybe (catMaybes)
+import Data.Version (Version)
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
+import qualified Distribution.License as Cabal
+import qualified Distribution.Package as Cabal
+import qualified Distribution.Simple.Configure as Cabal
+import qualified Distribution.Simple.LocalBuildInfo as Cabal
+import qualified Distribution.Simple.PackageIndex as Cabal
+import qualified Distribution.Text as Cabal
+import System.Directory (getDirectoryContents)
+import System.Exit (exitFailure)
+import System.FilePath (takeExtension)
+import System.IO (hPutStrLn, stderr)
+
+--------------------------------------------------------------------------------
+
+#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22
+type PackageIndex a = Cabal.PackageIndex (InstalledPackageInfo.InstalledPackageInfo_ a)
+#else
+type PackageIndex a = Cabal.PackageIndex
+#endif
+
+findTransitiveDependencies
+ :: PackageIndex a
+ -> Set Cabal.InstalledPackageId
+ -> Set Cabal.InstalledPackageId
+findTransitiveDependencies pkgIdx set0 = go Set.empty (Set.toList set0)
+ where
+ go set [] = set
+ go set (q : queue)
+ | q `Set.member` set = go set queue
+ | otherwise =
+ case Cabal.lookupInstalledPackageId pkgIdx q of
+ Nothing ->
+ -- Not found can mean that the package still needs to be
+ -- installed (e.g. a component of the target cabal package).
+ -- We can ignore those.
+ go set queue
+ Just ipi ->
+ go (Set.insert q set)
+ (InstalledPackageInfo.depends ipi ++ queue)
+
+
+--------------------------------------------------------------------------------
+getDependencyInstalledPackageIds
+ :: Cabal.LocalBuildInfo -> Set Cabal.InstalledPackageId
+getDependencyInstalledPackageIds lbi =
+ findTransitiveDependencies (Cabal.installedPkgs lbi) $
+ Set.fromList
+ [ installedPackageId
+ | (_, componentLbi, _) <- Cabal.componentsConfigs lbi
+ , (installedPackageId, _) <- Cabal.componentPackageDeps componentLbi
+ ]
+
+
+--------------------------------------------------------------------------------
+getDependencyInstalledPackageInfos
+ :: Cabal.LocalBuildInfo -> [InstalledPackageInfo]
+getDependencyInstalledPackageInfos lbi = catMaybes $
+ map (Cabal.lookupInstalledPackageId pkgIdx) $
+ Set.toList (getDependencyInstalledPackageIds lbi)
+ where
+ pkgIdx = Cabal.installedPkgs lbi
+
+
+--------------------------------------------------------------------------------
+groupByLicense
+ :: [InstalledPackageInfo]
+ -> [(Cabal.License, [InstalledPackageInfo])]
+groupByLicense = foldl'
+ (\assoc ipi -> insert (InstalledPackageInfo.license ipi) ipi assoc) []
+ where
+ -- 'Cabal.License' doesn't have an 'Ord' instance so we need to use an
+ -- association list instead of 'Map'. The number of licenses probably won't
+ -- exceed 100 so I think we're alright.
+ insert :: Eq k => k -> v -> [(k, [v])] -> [(k, [v])]
+ insert k v [] = [(k, [v])]
+ insert k v ((k', vs) : kvs)
+ | k == k' = (k, v : vs) : kvs
+ | otherwise = (k', vs) : insert k v kvs
+
+
+--------------------------------------------------------------------------------
+displayDependencyLicenseList
+ :: [(Cabal.License, [InstalledPackageInfo])]
+ -> [(String, [(String, Version)])]
+displayDependencyLicenseList =
+ map (Cabal.display *** map (getName &&& getVersion))
+ where
+ getName =
+ Cabal.display . Cabal.pkgName . InstalledPackageInfo.sourcePackageId
+ getVersion =
+ Cabal.pkgVersion . InstalledPackageInfo.sourcePackageId
diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs
index dec3dfd..22c6721 100644
--- a/CabalHelper/Main.hs
+++ b/CabalHelper/Main.hs
@@ -79,6 +79,7 @@ import System.IO
import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)
import Text.Printf
+import CabalHelper.Licenses
import CabalHelper.Sandbox
import CabalHelper.Common
import CabalHelper.Types hiding (Options(..))
@@ -100,6 +101,7 @@ usage = do
++" | package-db-stack\n"
++" | entrypoints\n"
++" | source-dirs\n"
+ ++" | licenses\n"
++" ) ...\n"
commands :: [String]
@@ -238,6 +240,10 @@ main = do
res <- componentsMap lbi v distdir $$ \_ _ bi -> return $ hsSourceDirs bi
return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])
+ "licenses":[] -> do
+ return $ Just $ ChResponseLicenses $
+ displayDependencyLicenseList $ groupByLicense $ getDependencyInstalledPackageInfos lbi
+
"print-lbi":flags ->
case flags of
["--human"] -> print lbi >> return Nothing
diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs
index 284f7e6..c0ad0f7 100644
--- a/CabalHelper/Types.hs
+++ b/CabalHelper/Types.hs
@@ -37,6 +37,7 @@ data ChResponse
| ChResponsePkgDbs [ChPkgDb]
| ChResponseLbi String
| ChResponseVersion String Version
+ | ChResponseLicenses [(String, [(String, Version)])]
deriving (Eq, Ord, Read, Show, Generic)
data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but
diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs
index f55e72a..648842a 100644
--- a/Distribution/Helper.hs
+++ b/Distribution/Helper.hs
@@ -36,6 +36,7 @@ module Distribution.Helper (
, ghcPkgOptions
, ghcMergedPkgOptions
, ghcLangOptions
+ , pkgLicenses
-- * Result types
, ChModuleName(..)
@@ -102,7 +103,8 @@ data SomeLocalBuildInfo = SomeLocalBuildInfo {
slbiGhcSrcOptions :: [(ChComponentName, [String])],
slbiGhcPkgOptions :: [(ChComponentName, [String])],
slbiGhcMergedPkgOptions :: [String],
- slbiGhcLangOptions :: [(ChComponentName, [String])]
+ slbiGhcLangOptions :: [(ChComponentName, [String])],
+ slbiPkgLicenses :: [(String, [(String, Version)])]
} deriving (Eq, Ord, Read, Show)
-- | Caches helper executable result so it doesn't have to be run more than once
@@ -198,6 +200,9 @@ ghcMergedPkgOptions :: MonadIO m => Query m [String]
-- | Only language related options, i.e. @-XSomeExtension@
ghcLangOptions :: MonadIO m => Query m [(ChComponentName, [String])]
+-- | Get the licenses of the packages the current project is linking against.
+pkgLicenses :: MonadIO m => Query m [(String, [(String, Version)])]
+
packageDbStack = Query $ slbiPackageDbStack `liftM` getSlbi
entrypoints = Query $ slbiEntrypoints `liftM` getSlbi
sourceDirs = Query $ slbiSourceDirs `liftM` getSlbi
@@ -206,6 +211,7 @@ ghcSrcOptions = Query $ slbiGhcSrcOptions `liftM` getSlbi
ghcPkgOptions = Query $ slbiGhcPkgOptions `liftM` getSlbi
ghcMergedPkgOptions = Query $ slbiGhcMergedPkgOptions `liftM` getSlbi
ghcLangOptions = Query $ slbiGhcLangOptions `liftM` getSlbi
+pkgLicenses = Query $ slbiPkgLicenses `liftM` getSlbi
-- | Run @cabal configure@
reconfigure :: MonadIO m
@@ -240,6 +246,7 @@ getSomeConfigState = ask >>= \(QueryEnv readProc progs projdir distdir) -> do
, "ghc-pkg-options"
, "ghc-merged-pkg-options"
, "ghc-lang-options"
+ , "licenses"
] ++ progArgs
res <- liftIO $ do
@@ -257,10 +264,12 @@ getSomeConfigState = ask >>= \(QueryEnv readProc progs projdir distdir) -> do
Just (ChResponseCompList ghcSrcOpts),
Just (ChResponseCompList ghcPkgOpts),
Just (ChResponseList ghcMergedPkgOpts),
- Just (ChResponseCompList ghcLangOpts) ] = res
+ Just (ChResponseCompList ghcLangOpts),
+ Just (ChResponseLicenses pkgLics)
+ ] = res
return $ SomeLocalBuildInfo
- pkgDbs eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcMergedPkgOpts ghcLangOpts
+ pkgDbs eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcMergedPkgOpts ghcLangOpts pkgLics
-- | Make sure the appropriate helper executable for the given project is
-- installed and ready to run queries.
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 05:03:04 +0000