{-# LANGUAGE CPP #-}
module Distribution.Cab.Printer (
    printDeps
  , printRevDeps
  , extraInfo
  ) where

import Control.Monad
import Data.Function
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Distribution.Cab.PkgDB
import Distribution.Cab.Version
import Distribution.Cab.Utils (UnitId, installedUnitId, lookupUnitId)
import Distribution.InstalledPackageInfo (author, depends, license)
import Distribution.License (License(..))
import Distribution.Simple.PackageIndex (allPackages)

#if MIN_VERSION_Cabal(2,2,0)
import Distribution.License (licenseFromSPDX)
#endif

----------------------------------------------------------------

type RevDB = Map UnitId [UnitId]

makeRevDepDB :: PkgDB -> RevDB
makeRevDepDB :: PkgDB -> RevDB
makeRevDepDB PkgDB
db = [(UnitId, [UnitId])] -> RevDB
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(UnitId, [UnitId])]
revdeps
  where
    pkgs :: [InstalledPackageInfo]
pkgs = PkgDB -> [InstalledPackageInfo]
forall a. PackageIndex a -> [a]
allPackages PkgDB
db
    deps :: [(UnitId, [UnitId])]
deps = (InstalledPackageInfo -> (UnitId, [UnitId]))
-> [InstalledPackageInfo] -> [(UnitId, [UnitId])]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> (UnitId, [UnitId])
idDeps [InstalledPackageInfo]
pkgs
    idDeps :: InstalledPackageInfo -> (UnitId, [UnitId])
idDeps InstalledPackageInfo
pkg = (InstalledPackageInfo -> UnitId
installedUnitId InstalledPackageInfo
pkg, InstalledPackageInfo -> [UnitId]
depends InstalledPackageInfo
pkg)
    kvs :: [(UnitId, UnitId)]
kvs = [(UnitId, UnitId)] -> [(UnitId, UnitId)]
forall a. Ord a => [a] -> [a]
sort ([(UnitId, UnitId)] -> [(UnitId, UnitId)])
-> [(UnitId, UnitId)] -> [(UnitId, UnitId)]
forall a b. (a -> b) -> a -> b
$ ((UnitId, [UnitId]) -> [(UnitId, UnitId)])
-> [(UnitId, [UnitId])] -> [(UnitId, UnitId)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (UnitId, [UnitId]) -> [(UnitId, UnitId)]
forall b a. (b, [a]) -> [(a, b)]
decomp [(UnitId, [UnitId])]
deps
    decomp :: (b, [a]) -> [(a, b)]
decomp (b
k,[a]
vs) = (a -> (a, b)) -> [a] -> [(a, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
v -> (a
v,b
k)) [a]
vs
    kvss :: [[(UnitId, UnitId)]]
kvss = ((UnitId, UnitId) -> (UnitId, UnitId) -> Bool)
-> [(UnitId, UnitId)] -> [[(UnitId, UnitId)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
(==) (UnitId -> UnitId -> Bool)
-> ((UnitId, UnitId) -> UnitId)
-> (UnitId, UnitId)
-> (UnitId, UnitId)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (UnitId, UnitId) -> UnitId
forall a b. (a, b) -> a
fst) [(UnitId, UnitId)]
kvs
    comp :: [(a, b)] -> (a, [b])
comp [(a, b)]
xs = ((a, b) -> a
forall a b. (a, b) -> a
fst ([(a, b)] -> (a, b)
forall a. [a] -> a
head [(a, b)]
xs), ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd [(a, b)]
xs)
    revdeps :: [(UnitId, [UnitId])]
revdeps = ([(UnitId, UnitId)] -> (UnitId, [UnitId]))
-> [[(UnitId, UnitId)]] -> [(UnitId, [UnitId])]
forall a b. (a -> b) -> [a] -> [b]
map [(UnitId, UnitId)] -> (UnitId, [UnitId])
forall a b. [(a, b)] -> (a, [b])
comp [[(UnitId, UnitId)]]
kvss

----------------------------------------------------------------

printDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()
printDeps :: Bool -> Bool -> PkgDB -> Int -> InstalledPackageInfo -> IO ()
printDeps Bool
rec Bool
info PkgDB
db Int
n InstalledPackageInfo
pkgi = (UnitId -> IO ()) -> [UnitId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> Bool -> PkgDB -> Int -> UnitId -> IO ()
printDep Bool
rec Bool
info PkgDB
db Int
n) ([UnitId] -> IO ()) -> [UnitId] -> IO ()
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> [UnitId]
depends InstalledPackageInfo
pkgi

printDep :: Bool -> Bool -> PkgDB -> Int -> UnitId -> IO ()
printDep :: Bool -> Bool -> PkgDB -> Int -> UnitId -> IO ()
printDep Bool
rec Bool
info PkgDB
db Int
n UnitId
uid = case PkgDB -> UnitId -> Maybe InstalledPackageInfo
forall a. PackageIndex a -> UnitId -> Maybe a
lookupUnitId PkgDB
db UnitId
uid of
    Maybe InstalledPackageInfo
Nothing    -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just InstalledPackageInfo
uniti -> do
        String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ InstalledPackageInfo -> String
fullNameOfPkgInfo InstalledPackageInfo
uniti
        Bool -> InstalledPackageInfo -> IO ()
extraInfo Bool
info InstalledPackageInfo
uniti
        String -> IO ()
putStrLn String
""
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rec (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> PkgDB -> Int -> InstalledPackageInfo -> IO ()
printDeps Bool
rec Bool
info PkgDB
db (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) InstalledPackageInfo
uniti
  where
    prefix :: String
prefix = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) Char
' '

----------------------------------------------------------------

printRevDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()
printRevDeps :: Bool -> Bool -> PkgDB -> Int -> InstalledPackageInfo -> IO ()
printRevDeps Bool
rec Bool
info PkgDB
db Int
n InstalledPackageInfo
pkgi = Bool
-> Bool -> PkgDB -> RevDB -> Int -> InstalledPackageInfo -> IO ()
printRevDeps' Bool
rec Bool
info PkgDB
db RevDB
revdb Int
n InstalledPackageInfo
pkgi
  where
    revdb :: RevDB
revdb = PkgDB -> RevDB
makeRevDepDB PkgDB
db

printRevDeps' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> PkgInfo -> IO ()
printRevDeps' :: Bool
-> Bool -> PkgDB -> RevDB -> Int -> InstalledPackageInfo -> IO ()
printRevDeps' Bool
rec Bool
info PkgDB
db RevDB
revdb Int
n InstalledPackageInfo
pkgi = case UnitId -> RevDB -> Maybe [UnitId]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup UnitId
unitid RevDB
revdb of
    Maybe [UnitId]
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just [UnitId]
unitids -> (UnitId -> IO ()) -> [UnitId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> Bool -> PkgDB -> RevDB -> Int -> UnitId -> IO ()
printRevDep' Bool
rec Bool
info PkgDB
db RevDB
revdb Int
n) [UnitId]
unitids
  where
    unitid :: UnitId
unitid = InstalledPackageInfo -> UnitId
installedUnitId InstalledPackageInfo
pkgi

printRevDep' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> UnitId -> IO ()
printRevDep' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> UnitId -> IO ()
printRevDep' Bool
rec Bool
info PkgDB
db RevDB
revdb Int
n UnitId
uid = case PkgDB -> UnitId -> Maybe InstalledPackageInfo
forall a. PackageIndex a -> UnitId -> Maybe a
lookupUnitId PkgDB
db UnitId
uid of
    Maybe InstalledPackageInfo
Nothing    -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just InstalledPackageInfo
uniti -> do
        String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ InstalledPackageInfo -> String
fullNameOfPkgInfo InstalledPackageInfo
uniti
        Bool -> InstalledPackageInfo -> IO ()
extraInfo Bool
info InstalledPackageInfo
uniti
        String -> IO ()
putStrLn String
""
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rec (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool
-> Bool -> PkgDB -> RevDB -> Int -> InstalledPackageInfo -> IO ()
printRevDeps' Bool
rec Bool
info PkgDB
db RevDB
revdb (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) InstalledPackageInfo
uniti
  where
    prefix :: String
prefix = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) Char
' '

----------------------------------------------------------------

extraInfo :: Bool -> PkgInfo -> IO ()
extraInfo :: Bool -> InstalledPackageInfo -> IO ()
extraInfo Bool
False InstalledPackageInfo
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
extraInfo Bool
True InstalledPackageInfo
pkgi = String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lcns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ShortText -> String
forall a. Show a => a -> String
show ShortText
auth String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
  where
    lcns :: String
lcns = License -> String
showLicense (InstalledPackageInfo -> License
pkgInfoLicense InstalledPackageInfo
pkgi)
    auth :: ShortText
auth = InstalledPackageInfo -> ShortText
author InstalledPackageInfo
pkgi

pkgInfoLicense :: PkgInfo -> License
#if MIN_VERSION_Cabal(2,2,0)
pkgInfoLicense :: InstalledPackageInfo -> License
pkgInfoLicense = (License -> License)
-> (License -> License) -> Either License License -> License
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either License -> License
licenseFromSPDX License -> License
forall a. a -> a
id (Either License License -> License)
-> (InstalledPackageInfo -> Either License License)
-> InstalledPackageInfo
-> License
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> Either License License
license
#else
pkgInfoLicense = license
#endif

showLicense :: License -> String
showLicense :: License -> String
showLicense (GPL (Just Version
v))     = String
"GPL" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
versionToString Version
v
showLicense (GPL Maybe Version
Nothing)      = String
"GPL"
showLicense (LGPL (Just Version
v))    = String
"LGPL" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
versionToString Version
v
showLicense (LGPL Maybe Version
Nothing)     = String
"LGPL"
showLicense (UnknownLicense String
s) = String
s
showLicense License
x                  = License -> String
forall a. Show a => a -> String
show License
x