{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE NoFieldSelectors    #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

module Stack.Types.DependencyTree
  ( DependencyTree (..)
  , DotPayload (..)
  , licenseText
  , versionText
  ) where

import           Data.Aeson ( ToJSON (..), Value, (.=), object )
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text
import           Distribution.License ( License (..), licenseFromSPDX )
import qualified Distribution.SPDX.License as SPDX
import           Distribution.Text ( display )
import           Stack.Prelude hiding ( Display (..), pkgName, loadPackage )

-- | Information about a package in the dependency graph, when available.

data DotPayload = DotPayload
  { DotPayload -> Maybe Version
version :: Maybe Version
    -- ^ The package version.

  , DotPayload -> Maybe (Either License License)
license :: Maybe (Either SPDX.License License)
    -- ^ The license the package was released under.

  , DotPayload -> Maybe PackageLocation
location :: Maybe PackageLocation
    -- ^ The location of the package.

  }
  deriving (DotPayload -> DotPayload -> Bool
(DotPayload -> DotPayload -> Bool)
-> (DotPayload -> DotPayload -> Bool) -> Eq DotPayload
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DotPayload -> DotPayload -> Bool
== :: DotPayload -> DotPayload -> Bool
$c/= :: DotPayload -> DotPayload -> Bool
/= :: DotPayload -> DotPayload -> Bool
Eq, Int -> DotPayload -> ShowS
[DotPayload] -> ShowS
DotPayload -> [Char]
(Int -> DotPayload -> ShowS)
-> (DotPayload -> [Char])
-> ([DotPayload] -> ShowS)
-> Show DotPayload
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DotPayload -> ShowS
showsPrec :: Int -> DotPayload -> ShowS
$cshow :: DotPayload -> [Char]
show :: DotPayload -> [Char]
$cshowList :: [DotPayload] -> ShowS
showList :: [DotPayload] -> ShowS
Show)

data DependencyTree =
  DependencyTree (Set PackageName)
                 (Map PackageName (Set PackageName, DotPayload))

instance ToJSON DependencyTree where
  toJSON :: DependencyTree -> Value
toJSON (DependencyTree Set PackageName
_ Map PackageName (Set PackageName, DotPayload)
dependencyMap) =
    [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (PackageName -> (Set PackageName, DotPayload) -> Value)
-> Map PackageName (Set PackageName, DotPayload) -> [Value]
forall k a b. (k -> a -> b) -> Map k a -> [b]
foldToList PackageName -> (Set PackageName, DotPayload) -> Value
dependencyToJSON Map PackageName (Set PackageName, DotPayload)
dependencyMap

foldToList :: (k -> a -> b) -> Map k a -> [b]
foldToList :: forall k a b. (k -> a -> b) -> Map k a -> [b]
foldToList k -> a -> b
f = (k -> a -> [b] -> [b]) -> [b] -> Map k a -> [b]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\k
k a
a [b]
bs -> [b]
bs [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [k -> a -> b
f k
k a
a]) []

dependencyToJSON :: PackageName -> (Set PackageName, DotPayload) -> Value
dependencyToJSON :: PackageName -> (Set PackageName, DotPayload) -> Value
dependencyToJSON PackageName
pkg (Set PackageName
deps, DotPayload
payload) =
  let fieldsAlwaysPresent :: [Pair]
fieldsAlwaysPresent = [ Key
"name" Key -> [Char] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= PackageName -> [Char]
packageNameString PackageName
pkg
                            , Key
"license" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= DotPayload -> Text
licenseText DotPayload
payload
                            , Key
"version" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= DotPayload -> Text
versionText DotPayload
payload
                            , Key
"dependencies" Key -> Set [Char] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= (PackageName -> [Char]) -> Set PackageName -> Set [Char]
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PackageName -> [Char]
packageNameString Set PackageName
deps
                            ]
      loc :: [Pair]
loc = [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
              [(Key
"location" .=) (Value -> Pair)
-> (PackageLocation -> Value) -> PackageLocation -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocation -> Value
pkgLocToJSON (PackageLocation -> Pair) -> Maybe PackageLocation -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DotPayload
payload.location]
  in  [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Pair]
fieldsAlwaysPresent [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
loc

pkgLocToJSON :: PackageLocation -> Value
pkgLocToJSON :: PackageLocation -> Value
pkgLocToJSON (PLMutable (ResolvedPath RelFilePath
_ Path Abs Dir
dir)) = [Pair] -> Value
object
  [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= (Text
"project package" :: Text)
  , Key
"url" Key -> [Char] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= ([Char]
"file://" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir)
  ]
pkgLocToJSON (PLImmutable (PLIHackage PackageIdentifier
pkgid BlobKey
_ TreeKey
_)) = [Pair] -> Value
object
  [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= (Text
"hackage" :: Text)
  , Key
"url" Key -> [Char] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= ([Char]
"https://hackage.haskell.org/package/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
display PackageIdentifier
pkgid)
  ]
pkgLocToJSON (PLImmutable (PLIArchive Archive
archive PackageMetadata
_)) =
  let url :: Text
url = case Archive -> ArchiveLocation
archiveLocation Archive
archive of
              ALUrl Text
u -> Text
u
              ALFilePath (ResolvedPath RelFilePath
_ Path Abs File
path) ->
                [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"file://" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
path
  in  [Pair] -> Value
object
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= (Text
"archive" :: Text)
        , Key
"url" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
url
        , Key
"sha256" Key -> SHA256 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Archive -> SHA256
archiveHash Archive
archive
        , Key
"size" Key -> FileSize -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Archive -> FileSize
archiveSize Archive
archive
        ]
pkgLocToJSON (PLImmutable (PLIRepo Repo
repo PackageMetadata
_)) = [Pair] -> Value
object
  [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= case Repo -> RepoType
repoType Repo
repo of
                RepoType
RepoGit -> Text
"git" :: Text
                RepoType
RepoHg -> Text
"hg" :: Text
  , Key
"url" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Repo -> Text
repoUrl Repo
repo
  , Key
"commit" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Repo -> Text
repoCommit Repo
repo
  , Key
"subdir" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Repo -> Text
repoSubdir Repo
repo
  ]

licenseText :: DotPayload -> Text
licenseText :: DotPayload -> Text
licenseText DotPayload
payload =
  Text
-> (Either License License -> Text)
-> Maybe (Either License License)
-> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<unknown>" ([Char] -> Text
Text.pack ([Char] -> Text)
-> (Either License License -> [Char])
-> Either License License
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. License -> [Char]
forall a. Pretty a => a -> [Char]
display (License -> [Char])
-> (Either License License -> License)
-> Either License License
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)
                    DotPayload
payload.license

versionText :: DotPayload -> Text
versionText :: DotPayload -> Text
versionText DotPayload
payload =
  Text -> (Version -> Text) -> Maybe Version -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<unknown>" ([Char] -> Text
Text.pack ([Char] -> Text) -> (Version -> [Char]) -> Version -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Char]
forall a. Pretty a => a -> [Char]
display) DotPayload
payload.version