Add `licenses` command

Totally not stolen from
https://github.com/jaspervdj/cabal-dependency-licenses, no never!

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.