From 9f1b0b5177047e9fce98ebb3aa1157ac50eb9dcd Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Thu, 27 Aug 2015 04:13:36 +0200 Subject: Add `licenses` command Totally not stolen from https://github.com/jaspervdj/cabal-dependency-licenses, no never! --- CabalHelper/Compile.hs | 1 + CabalHelper/Data.hs | 1 + CabalHelper/Licenses.hs | 105 ++++++++++++++++++++++++++++++++++++++++++++++++ CabalHelper/Main.hs | 6 +++ CabalHelper/Types.hs | 1 + 5 files changed, 114 insertions(+) create mode 100644 CabalHelper/Licenses.hs (limited to 'CabalHelper') 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 + +-------------------------------------------------------------------------------- +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 -- cgit v1.2.3