module Distribution.Nixpkgs.PackageMap
  ( PackageMap, readNixpkgPackageMap
  , resolve
  ) where

import Control.Lens
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy as LBS
import Data.Function
import Data.List as List
import Data.List.Split
import Data.Map.Strict ( Map )
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Set ( Set )
import qualified Data.Set as Set
import Language.Nix
import System.Process

type PackageMap = Map Identifier (Set Path)

readNixpkgPackageMap :: [String] -> IO PackageMap
readNixpkgPackageMap :: [String] -> IO PackageMap
readNixpkgPackageMap = (Set String -> PackageMap) -> IO (Set String) -> IO PackageMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set String -> PackageMap
identifierSet2PackageMap (IO (Set String) -> IO PackageMap)
-> ([String] -> IO (Set String)) -> [String] -> IO PackageMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> IO (Set String)
readNixpkgSet

readNixpkgSet :: [String] -> IO (Set String)
readNixpkgSet :: [String] -> IO (Set String)
readNixpkgSet [String]
extraArgs = do
  (Maybe Handle
_, Just Handle
h, Maybe Handle
_, ProcessHandle
_) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> [String] -> CreateProcess
proc String
"nix-env" ([String
"-qaP", String
"--json"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extraArgs))
                       { std_out :: StdStream
std_out = StdStream
CreatePipe, env :: Maybe [(String, String)]
env = Maybe [(String, String)]
forall a. Maybe a
Nothing }  -- TODO: ensure that overrides don't screw up our results
  ByteString
buf <- Handle -> IO ByteString
LBS.hGetContents Handle
h
  let pkgmap :: Either String (Map String JSON.Object)
      pkgmap :: Either String (Map String Object)
pkgmap = ByteString -> Either String (Map String Object)
forall a. FromJSON a => ByteString -> Either String a
JSON.eitherDecode ByteString
buf
  (String -> IO (Set String))
-> (Map String Object -> IO (Set String))
-> Either String (Map String Object)
-> IO (Set String)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO (Set String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Set String -> IO (Set String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set String -> IO (Set String))
-> (Map String Object -> Set String)
-> Map String Object
-> IO (Set String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String Object -> Set String
forall k a. Map k a -> Set k
Map.keysSet) Either String (Map String Object)
pkgmap

identifierSet2PackageMap :: Set String -> PackageMap
identifierSet2PackageMap :: Set String -> PackageMap
identifierSet2PackageMap Set String
pkgset = ((Identifier, Path) -> PackageMap -> PackageMap)
-> PackageMap -> [(Identifier, Path)] -> PackageMap
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Identifier -> Path -> PackageMap -> PackageMap)
-> (Identifier, Path) -> PackageMap -> PackageMap
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Identifier -> Path -> PackageMap -> PackageMap
insertIdentifier) PackageMap
forall k a. Map k a
Map.empty [(Identifier, Path)]
pkglist
  where
    pkglist :: [(Identifier, Path)]
    pkglist :: [(Identifier, Path)]
pkglist = (String -> Maybe (Identifier, Path))
-> [String] -> [(Identifier, Path)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (Identifier, Path)
parsePackage (Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
pkgset)

    insertIdentifier :: Identifier -> Path -> PackageMap -> PackageMap
    insertIdentifier :: Identifier -> Path -> PackageMap -> PackageMap
insertIdentifier Identifier
i = (Set Path -> Set Path -> Set Path)
-> Identifier -> Set Path -> PackageMap -> PackageMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set Path -> Set Path -> Set Path
forall a. Ord a => Set a -> Set a -> Set a
Set.union Identifier
i (Set Path -> PackageMap -> PackageMap)
-> (Path -> Set Path) -> Path -> PackageMap -> PackageMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Set Path
forall a. a -> Set a
Set.singleton

parsePackage :: String -> Maybe (Identifier, Path)
parsePackage :: String -> Maybe (Identifier, Path)
parsePackage String
x | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x                 = String -> Maybe (Identifier, Path)
forall a. HasCallStack => String -> a
error String
"Distribution.Nixpkgs.PackageMap.parsepackage: empty string is no valid identifier"
               | [String]
xs <- String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." String
x    = if String -> Bool
needsQuoting ([String] -> String
forall a. [a] -> a
head [String]
xs)
                                             then Maybe (Identifier, Path)
forall a. Maybe a
Nothing
                                             else (Identifier, Path) -> Maybe (Identifier, Path)
forall a. a -> Maybe a
Just (Tagged String (Identity String)
-> Tagged Identifier (Identity Identifier)
Iso' Identifier String
ident (Tagged String (Identity String)
 -> Tagged Identifier (Identity Identifier))
-> String -> Identifier
forall t b. AReview t b -> b -> t
# [String] -> String
forall a. [a] -> a
last [String]
xs, Tagged [Identifier] (Identity [Identifier])
-> Tagged Path (Identity Path)
Iso' Path [Identifier]
path (Tagged [Identifier] (Identity [Identifier])
 -> Tagged Path (Identity Path))
-> [Identifier] -> Path
forall t b. AReview t b -> b -> t
# (String -> Identifier) -> [String] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map ((Tagged String (Identity String)
 -> Tagged Identifier (Identity Identifier))
-> String -> Identifier
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review Tagged String (Identity String)
-> Tagged Identifier (Identity Identifier)
Iso' Identifier String
ident) [String]
xs)

resolve :: PackageMap -> Identifier -> Maybe Binding
resolve :: PackageMap -> Identifier -> Maybe Binding
resolve PackageMap
nixpkgs Identifier
i = case Identifier -> PackageMap -> Maybe (Set Path)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Identifier
i PackageMap
nixpkgs of
                      Maybe (Set Path)
Nothing -> Maybe Binding
forall a. Maybe a
Nothing
                      Just Set Path
ps -> let p :: Path
p = [Path] -> Path
chooseShortestPath (Set Path -> [Path]
forall a. Set a -> [a]
Set.toList Set Path
ps)
                                 in Binding -> Maybe Binding
forall a. a -> Maybe a
Just (Binding -> Maybe Binding) -> Binding -> Maybe Binding
forall a b. (a -> b) -> a -> b
$ Tagged (Identifier, Path) (Identity (Identifier, Path))
-> Tagged Binding (Identity Binding)
Iso' Binding (Identifier, Path)
binding (Tagged (Identifier, Path) (Identity (Identifier, Path))
 -> Tagged Binding (Identity Binding))
-> (Identifier, Path) -> Binding
forall t b. AReview t b -> b -> t
# (Identifier
i,Path
p)

chooseShortestPath :: [Path] -> Path
chooseShortestPath :: [Path] -> Path
chooseShortestPath [] = String -> Path
forall a. HasCallStack => String -> a
error String
"chooseShortestPath: called with empty list argument"
chooseShortestPath [Path]
ps = (Path -> Path -> Ordering) -> [Path] -> Path
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((Int -> Int -> Ordering)
-> (Path -> Int) -> Path -> Path -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Getting Int Path Int -> Path -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (([Identifier] -> Const Int [Identifier]) -> Path -> Const Int Path
Iso' Path [Identifier]
path (([Identifier] -> Const Int [Identifier])
 -> Path -> Const Int Path)
-> ((Int -> Const Int Int)
    -> [Identifier] -> Const Int [Identifier])
-> Getting Int Path Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Identifier] -> Int)
-> (Int -> Const Int Int) -> [Identifier] -> Const Int [Identifier]
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to [Identifier] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length))) [Path]
ps