-- | Build a lookup table from package identifiers to full attribute paths in nixpkgs.
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 (minimumBy)
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 Paths_distribution_nixpkgs (getDataFileName)
import System.Process

type PackageMap = Map Identifier (Set Path)

-- | Evaluate nixpkgs at a given (nix) path and build a 'Map'
--   keeping track of all 'Path's that end in a given 'Identifier'
--   and evaluate to a derivation.
--   This can be used to find an attribute 'Path' for an arbitrary
--   package name using 'resolve'.
--
--   Note: Evaluation of nixpkgs is very expensive (takes multiple
--   seconds), so cache the result of this function if possible.
--
--   >>> readNixpkgPackageMap "<nixpkgs>" (Just "{ config = { allowAliases = false; }; }")
--   fromList [ … ]
readNixpkgPackageMap :: String
                     -- ^ Path to nixpkgs, must be a valid nix path
                     --   (absolute, relative or @NIX_PATH@ lookup)
                     -> Maybe String
                     -- ^ (Optional) argument attribute set to pass to
                     --   nixpkgs. Must be a valid nix attribute set.
                     -> IO PackageMap
readNixpkgPackageMap :: String -> Maybe String -> IO PackageMap
readNixpkgPackageMap String
nixpkgsPath Maybe String
nixpkgsArgs =
  Set [String] -> PackageMap
identifierSet2PackageMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe String -> IO (Set [String])
readNixpkgSet String
nixpkgsPath Maybe String
nixpkgsArgs

readNixpkgSet :: String -> Maybe String -> IO (Set [String])
readNixpkgSet :: String -> Maybe String -> IO (Set [String])
readNixpkgSet String
nixpkgsPath Maybe String
nixpkgsArgs = do
  String
pathsExpr <- String -> IO String
getDataFileName String
"derivation-attr-paths.nix"
  let nixInstantiate :: CreateProcess
nixInstantiate = String -> [String] -> CreateProcess
proc String
"nix-instantiate"
        [ String
"--strict"
        , String
"--json"
        , String
"--eval"
        , String
pathsExpr
        , String
"--arg", String
"nixpkgsPath", String
nixpkgsPath
        , String
"--arg", String
"nixpkgsArgs", forall a. a -> Maybe a -> a
fromMaybe String
"{}" Maybe String
nixpkgsArgs
        ]
  (Maybe Handle
_, Just Handle
h, Maybe Handle
_, ProcessHandle
_) <- -- TODO: ensure that overrides don't screw up our results
    CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
nixInstantiate { std_out :: StdStream
std_out = StdStream
CreatePipe, env :: Maybe [(String, String)]
env = forall a. Maybe a
Nothing }
  ByteString
buf <- Handle -> IO ByteString
LBS.hGetContents Handle
h
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
JSON.eitherDecode ByteString
buf

identifierSet2PackageMap :: Set [String] -> PackageMap
identifierSet2PackageMap :: Set [String] -> PackageMap
identifierSet2PackageMap = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [String] -> PackageMap -> PackageMap
insertIdentifier forall k a. Map k a
Map.empty
  where
    insertIdentifier :: [String] -> (PackageMap -> PackageMap)
    insertIdentifier :: [String] -> PackageMap -> PackageMap
insertIdentifier [String]
rawPath =
      case [String] -> Maybe (Identifier, Path)
parsePackage [String]
rawPath of
        Maybe (Identifier, Path)
Nothing -> forall a. a -> a
id
        Just (Identifier
i, Path
p) -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Ord a => Set a -> Set a -> Set a
Set.union Identifier
i forall a b. (a -> b) -> a -> b
$ forall a. a -> Set a
Set.singleton Path
p

parsePackage :: [String] -> Maybe (Identifier, Path)
parsePackage :: [String] -> Maybe (Identifier, Path)
parsePackage [String]
x
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
x = -- this case would be a bug in derivation-attr-paths.nix
      forall a. HasCallStack => String -> a
error String
"Distribution.Nixpkgs.PackageMap.parsepackage: empty path is no valid identifier"
  | Bool
otherwise =
      if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
needsQuoting [String]
x
        then forall a. Maybe a
Nothing
        else forall a. a -> Maybe a
Just (Iso' Identifier String
ident forall t b. AReview t b -> b -> t
# forall a. [a] -> a
last [String]
x, Iso' Path [Identifier]
path forall t b. AReview t b -> b -> t
# forall a b. (a -> b) -> [a] -> [b]
map (forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review Iso' Identifier String
ident) [String]
x)

-- | Finds the shortest 'Path' in a 'PackageMap' that has the
--   given 'Identifier' as its last component.
--
--   >>> resolve nixpkgs (ident # "pam")
--   Just (Bind (Identifier "pam") (Path [Identifier "pam"]))
resolve :: PackageMap -> Identifier -> Maybe Binding
resolve :: PackageMap -> Identifier -> Maybe Binding
resolve PackageMap
nixpkgs Identifier
i = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Identifier
i PackageMap
nixpkgs of
                      Maybe (Set Path)
Nothing -> forall a. Maybe a
Nothing
                      Just Set Path
ps -> let p :: Path
p = [Path] -> Path
chooseShortestPath (forall a. Set a -> [a]
Set.toList Set Path
ps)
                                 in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Iso' Binding (Identifier, Path)
binding forall t b. AReview t b -> b -> t
# (Identifier
i,Path
p)

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