{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

----------------------------------------------------------------------
-- |
-- Module: Licensor
-- Description:
--
--
--
----------------------------------------------------------------------

module Licensor
  ( LiLicense(..)
  , LiPackage(..)
  , getDependencies
  , getLicenses
  , getPackage
  , orderPackagesByLicense
  , version
  )
  where

-- base
import qualified Control.Exception as Exception
import Control.Monad (unless)
import Data.Version (Version)

-- Cabal
import Distribution.License (License)
import Distribution.Package (PackageIdentifier(..), PackageName)
import Distribution.PackageDescription (PackageDescription, packageDescription)
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
import Distribution.Pretty (Pretty)
import Distribution.Simple.Utils (comparing, findPackageDesc)
import Distribution.Text (display, simpleParse)
import Distribution.Verbosity (silent)

-- containers
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set

-- directory
import System.Directory (getCurrentDirectory)

-- licensor
import qualified Paths_licensor

-- process
import System.Process (readProcess)


-- |
--
--

newtype LiLicense = LiLicense { LiLicense -> License
getLicense :: License }
  deriving (LiLicense -> LiLicense -> Bool
(LiLicense -> LiLicense -> Bool)
-> (LiLicense -> LiLicense -> Bool) -> Eq LiLicense
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LiLicense -> LiLicense -> Bool
$c/= :: LiLicense -> LiLicense -> Bool
== :: LiLicense -> LiLicense -> Bool
$c== :: LiLicense -> LiLicense -> Bool
Eq, ReadPrec [LiLicense]
ReadPrec LiLicense
Int -> ReadS LiLicense
ReadS [LiLicense]
(Int -> ReadS LiLicense)
-> ReadS [LiLicense]
-> ReadPrec LiLicense
-> ReadPrec [LiLicense]
-> Read LiLicense
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LiLicense]
$creadListPrec :: ReadPrec [LiLicense]
readPrec :: ReadPrec LiLicense
$creadPrec :: ReadPrec LiLicense
readList :: ReadS [LiLicense]
$creadList :: ReadS [LiLicense]
readsPrec :: Int -> ReadS LiLicense
$creadsPrec :: Int -> ReadS LiLicense
Read, Int -> LiLicense -> ShowS
[LiLicense] -> ShowS
LiLicense -> String
(Int -> LiLicense -> ShowS)
-> (LiLicense -> String)
-> ([LiLicense] -> ShowS)
-> Show LiLicense
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LiLicense] -> ShowS
$cshowList :: [LiLicense] -> ShowS
show :: LiLicense -> String
$cshow :: LiLicense -> String
showsPrec :: Int -> LiLicense -> ShowS
$cshowsPrec :: Int -> LiLicense -> ShowS
Show, CabalSpecVersion -> LiLicense -> Doc
LiLicense -> Doc
(LiLicense -> Doc)
-> (CabalSpecVersion -> LiLicense -> Doc) -> Pretty LiLicense
forall a. (a -> Doc) -> (CabalSpecVersion -> a -> Doc) -> Pretty a
prettyVersioned :: CabalSpecVersion -> LiLicense -> Doc
$cprettyVersioned :: CabalSpecVersion -> LiLicense -> Doc
pretty :: LiLicense -> Doc
$cpretty :: LiLicense -> Doc
Pretty)


-- |
--
--

instance Ord LiLicense where
  compare :: LiLicense -> LiLicense -> Ordering
compare =
    (LiLicense -> String) -> LiLicense -> LiLicense -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing LiLicense -> String
forall a. Pretty a => a -> String
display


-- |
--
--

data LiPackage =
  LiPackage
    { LiPackage -> PackageIdentifier
liPackageId :: PackageIdentifier
    , LiPackage -> Set LiPackage
liPackageDependencies :: Set LiPackage
    , LiPackage -> License
liPackageLicense :: License
    }


-- |
--
--

getPackage :: IO (Maybe PackageDescription)
getPackage :: IO (Maybe PackageDescription)
getPackage = do
  String
currentDirectory <- IO String
getCurrentDirectory
  (String -> IO PackageDescription)
-> Either String String -> Either String (IO PackageDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> IO PackageDescription
getPackageDescription (Either String String -> Either String (IO PackageDescription))
-> IO (Either String String)
-> IO (Either String (IO PackageDescription))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either String String)
findPackageDesc String
currentDirectory
    IO (Either String (IO PackageDescription))
-> (Either String (IO PackageDescription)
    -> IO (Maybe PackageDescription))
-> IO (Maybe PackageDescription)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO (Maybe PackageDescription))
-> (IO PackageDescription -> IO (Maybe PackageDescription))
-> Either String (IO PackageDescription)
-> IO (Maybe PackageDescription)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO (Maybe PackageDescription)
-> String -> IO (Maybe PackageDescription)
forall a b. a -> b -> a
const (Maybe PackageDescription -> IO (Maybe PackageDescription)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PackageDescription
forall a. Maybe a
Nothing)) ((PackageDescription -> Maybe PackageDescription)
-> IO PackageDescription -> IO (Maybe PackageDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageDescription -> Maybe PackageDescription
forall a. a -> Maybe a
Just)


-- |
--
--

getPackageDescription :: FilePath -> IO PackageDescription
getPackageDescription :: String -> IO PackageDescription
getPackageDescription =
  (GenericPackageDescription -> PackageDescription)
-> IO GenericPackageDescription -> IO PackageDescription
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenericPackageDescription -> PackageDescription
packageDescription (IO GenericPackageDescription -> IO PackageDescription)
-> (String -> IO GenericPackageDescription)
-> String
-> IO PackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
silent


-- |
--
--

getDependencies :: IO (Maybe (Set PackageIdentifier))
getDependencies :: IO (Maybe (Set PackageIdentifier))
getDependencies = do
  Either IOError String
eitherDeps <-
    IO String -> IO (Either IOError String)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (IO String -> IO (Either IOError String))
-> IO String -> IO (Either IOError String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO String
readProcess String
"stack" [String
"ls", String
"dependencies", String
"--separator", String
"-"] String
""

  case Either IOError String
eitherDeps of
    Left (IOError
_ :: IOError) ->
      Maybe (Set PackageIdentifier) -> IO (Maybe (Set PackageIdentifier))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Set PackageIdentifier)
forall a. Maybe a
Nothing

    Right String
deps ->
      Maybe (Set PackageIdentifier) -> IO (Maybe (Set PackageIdentifier))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Set PackageIdentifier)
 -> IO (Maybe (Set PackageIdentifier)))
-> Maybe (Set PackageIdentifier)
-> IO (Maybe (Set PackageIdentifier))
forall a b. (a -> b) -> a -> b
$ [PackageIdentifier] -> Set PackageIdentifier
forall a. Ord a => [a] -> Set a
Set.fromList ([PackageIdentifier] -> Set PackageIdentifier)
-> Maybe [PackageIdentifier] -> Maybe (Set PackageIdentifier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Maybe PackageIdentifier)
-> [String] -> Maybe [PackageIdentifier]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> Maybe PackageIdentifier
forall a. Parsec a => String -> Maybe a
simpleParse (String -> [String]
lines String
deps)


getLicenses :: IO (Maybe [(PackageName, License)])
getLicenses :: IO (Maybe [(PackageName, License)])
getLicenses = do
  Either IOError String
eitherDeps <-
    IO String -> IO (Either IOError String)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (IO String -> IO (Either IOError String))
-> IO String -> IO (Either IOError String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO String
readProcess String
"stack" [String
"ls", String
"dependencies", String
"--license"] String
""

  case Either IOError String
eitherDeps of
    Left (IOError
_ :: IOError) ->
      Maybe [(PackageName, License)]
-> IO (Maybe [(PackageName, License)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [(PackageName, License)]
forall a. Maybe a
Nothing

    Right String
deps ->
      Maybe [(PackageName, License)]
-> IO (Maybe [(PackageName, License)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [(PackageName, License)]
 -> IO (Maybe [(PackageName, License)]))
-> Maybe [(PackageName, License)]
-> IO (Maybe [(PackageName, License)])
forall a b. (a -> b) -> a -> b
$ (String -> Maybe (PackageName, License))
-> [String] -> Maybe [(PackageName, License)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> Maybe (PackageName, License)
forall a a. (Parsec a, Parsec a) => String -> Maybe (a, a)
toNameLicense (String -> [String]
lines String
deps)
  where
    toNameLicense :: String -> Maybe (a, a)
toNameLicense String
dep =
      case String -> [String]
words String
dep of
        [String
name, String
license] ->
          (,) (a -> a -> (a, a)) -> Maybe a -> Maybe (a -> (a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe a
forall a. Parsec a => String -> Maybe a
simpleParse String
name Maybe (a -> (a, a)) -> Maybe a -> Maybe (a, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe a
forall a. Parsec a => String -> Maybe a
simpleParse String
license

        [String]
_ ->
          Maybe (a, a)
forall a. Maybe a
Nothing


-- |
--
--

getPackageLicense
  :: Bool
  -> PackageIdentifier
  -> [(PackageName, License)]
  -> IO (Maybe LiLicense)
getPackageLicense :: Bool
-> PackageIdentifier
-> [(PackageName, License)]
-> IO (Maybe LiLicense)
getPackageLicense Bool
quiet PackageIdentifier
packageIdentifier [(PackageName, License)]
licenses = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet (String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
forall a. Pretty a => a -> String
display PackageIdentifier
packageIdentifier String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"...")
  case PackageName -> [(PackageName, License)] -> Maybe License
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (PackageIdentifier -> PackageName
pkgName PackageIdentifier
packageIdentifier) [(PackageName, License)]
licenses of
    Just License
license -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet (String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ License -> String
forall a. Pretty a => a -> String
display License
license)
      Maybe LiLicense -> IO (Maybe LiLicense)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LiLicense -> IO (Maybe LiLicense))
-> Maybe LiLicense -> IO (Maybe LiLicense)
forall a b. (a -> b) -> a -> b
$ LiLicense -> Maybe LiLicense
forall a. a -> Maybe a
Just (License -> LiLicense
LiLicense License
license)
    Maybe License
Nothing ->
      Maybe LiLicense -> IO (Maybe LiLicense)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LiLicense
forall a. Maybe a
Nothing


-- |
--
--

orderPackagesByLicense
  :: Bool
  -> Maybe PackageIdentifier
  -> [(PackageName, License)]
  -> Set PackageIdentifier
  -> IO (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
orderPackagesByLicense :: Bool
-> Maybe PackageIdentifier
-> [(PackageName, License)]
-> Set PackageIdentifier
-> IO
     (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
orderPackagesByLicense Bool
quiet Maybe PackageIdentifier
maybeP [(PackageName, License)]
licenses =
  let
    cond :: PackageIdentifier -> Bool
cond =
      (PackageIdentifier -> Bool)
-> (PackageIdentifier -> PackageIdentifier -> Bool)
-> Maybe PackageIdentifier
-> PackageIdentifier
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> PackageIdentifier -> Bool
forall a b. a -> b -> a
const Bool
False) PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
(==) Maybe PackageIdentifier
maybeP

    insertPackage :: PackageIdentifier
-> IO
     (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
-> IO
     (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
insertPackage PackageIdentifier
package IO (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
orderedPackages' = do
      Maybe LiLicense
maybeLicense <- Bool
-> PackageIdentifier
-> [(PackageName, License)]
-> IO (Maybe LiLicense)
getPackageLicense Bool
quiet PackageIdentifier
package [(PackageName, License)]
licenses

      (Map LiLicense (Set PackageIdentifier)
orderedPackages, Set PackageIdentifier
failed) <- IO (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
orderedPackages'
      (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
-> IO
     (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
 -> IO
      (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier))
-> (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
-> IO
     (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
forall a b. (a -> b) -> a -> b
$
        if PackageIdentifier -> Bool
cond PackageIdentifier
package
          then
            (Map LiLicense (Set PackageIdentifier)
orderedPackages, Set PackageIdentifier
failed)
          else
            case Maybe LiLicense
maybeLicense of
              Maybe LiLicense
Nothing ->
                ( Map LiLicense (Set PackageIdentifier)
orderedPackages, PackageIdentifier -> Set PackageIdentifier -> Set PackageIdentifier
forall a. Ord a => a -> Set a -> Set a
Set.insert PackageIdentifier
package Set PackageIdentifier
failed
                )

              Just LiLicense
license ->
                ( (Set PackageIdentifier
 -> Set PackageIdentifier -> Set PackageIdentifier)
-> LiLicense
-> Set PackageIdentifier
-> Map LiLicense (Set PackageIdentifier)
-> Map LiLicense (Set PackageIdentifier)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith
                    Set PackageIdentifier
-> Set PackageIdentifier -> Set PackageIdentifier
forall a. Ord a => Set a -> Set a -> Set a
Set.union
                    LiLicense
license
                    (PackageIdentifier -> Set PackageIdentifier
forall a. a -> Set a
Set.singleton PackageIdentifier
package)
                    Map LiLicense (Set PackageIdentifier)
orderedPackages
                , Set PackageIdentifier
failed
                )
  in
    (PackageIdentifier
 -> IO
      (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
 -> IO
      (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier))
-> IO
     (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
-> Set PackageIdentifier
-> IO
     (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PackageIdentifier
-> IO
     (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
-> IO
     (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
insertPackage ((Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
-> IO
     (Map LiLicense (Set PackageIdentifier), Set PackageIdentifier)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map LiLicense (Set PackageIdentifier)
forall a. Monoid a => a
mempty, Set PackageIdentifier
forall a. Monoid a => a
mempty))


-- |
--
--

version :: Version
version :: Version
version =
  Version
Paths_licensor.version