Add `licenses` command

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

5 files changed, 114 insertions, 0 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