{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

module Development.Guardian.Graph.Adapter.Cabal (
  buildPackageGraph,
  CustomPackageOptions (..),
  Cabal,
) where

import qualified Algebra.Graph as G
import Control.Applicative (optional, (<|>))
import Control.Monad (when)
import Data.Aeson (FromJSON, withObject, (.:))
import qualified Data.Aeson.KeyMap as AKM
import Data.Aeson.Types (FromJSON (..))
import Data.Either (fromLeft)
import Data.Generics.Labels ()
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.String (fromString)
import Development.Guardian.Graph.Adapter.Types (ComponentsOptions (..), CustomPackageOptions, PackageGraphOptions (..))
import Development.Guardian.Types (Overlayed (..), PackageGraph)
import qualified Development.Guardian.Types as Guard
import Distribution.Client.CmdUpdate (updateAction)
import Distribution.Client.InstallPlan (GenericPlanPackage (..), depends)
import qualified Distribution.Client.InstallPlan as Plan
import Distribution.Client.NixStyleOptions (defaultNixStyleFlags)
import Distribution.Client.ProjectConfig (ProjectRoot (..))
import Distribution.Client.ProjectOrchestration (CurrentCommand (..), ProjectBaseContext (..), establishProjectBaseContextWithRoot, withInstallPlan)
import Distribution.Client.ProjectPlanning (ElaboratedConfiguredPackage (..), elabLocalToProject)
import Distribution.Package (Package (..), packageName, unPackageName)
import Distribution.Simple.Flag (Flag (..))
import Distribution.Verbosity (silent)
import GHC.Generics (Generic)
import Lens.Micro
import Path

data Cabal deriving (forall x. Rep Cabal x -> Cabal
forall x. Cabal -> Rep Cabal x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Cabal x -> Cabal
$cfrom :: forall x. Cabal -> Rep Cabal x
Generic)

data instance CustomPackageOptions Cabal = CabalOptions {CustomPackageOptions Cabal -> Maybe (Path Rel File)
projectFile :: Maybe (Path Rel File), CustomPackageOptions Cabal -> Maybe (Either Bool String)
update :: Maybe (Either Bool String)}
  deriving (Int -> CustomPackageOptions Cabal -> ShowS
[CustomPackageOptions Cabal] -> ShowS
CustomPackageOptions Cabal -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CustomPackageOptions Cabal] -> ShowS
$cshowList :: [CustomPackageOptions Cabal] -> ShowS
show :: CustomPackageOptions Cabal -> String
$cshow :: CustomPackageOptions Cabal -> String
showsPrec :: Int -> CustomPackageOptions Cabal -> ShowS
$cshowsPrec :: Int -> CustomPackageOptions Cabal -> ShowS
Show, CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
$c/= :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
== :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
$c== :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
Eq, Eq (CustomPackageOptions Cabal)
CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
CustomPackageOptions Cabal
-> CustomPackageOptions Cabal -> Ordering
CustomPackageOptions Cabal
-> CustomPackageOptions Cabal -> CustomPackageOptions Cabal
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CustomPackageOptions Cabal
-> CustomPackageOptions Cabal -> CustomPackageOptions Cabal
$cmin :: CustomPackageOptions Cabal
-> CustomPackageOptions Cabal -> CustomPackageOptions Cabal
max :: CustomPackageOptions Cabal
-> CustomPackageOptions Cabal -> CustomPackageOptions Cabal
$cmax :: CustomPackageOptions Cabal
-> CustomPackageOptions Cabal -> CustomPackageOptions Cabal
>= :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
$c>= :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
> :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
$c> :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
<= :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
$c<= :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
< :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
$c< :: CustomPackageOptions Cabal -> CustomPackageOptions Cabal -> Bool
compare :: CustomPackageOptions Cabal
-> CustomPackageOptions Cabal -> Ordering
$ccompare :: CustomPackageOptions Cabal
-> CustomPackageOptions Cabal -> Ordering
Ord, forall x.
Rep (CustomPackageOptions Cabal) x -> CustomPackageOptions Cabal
forall x.
CustomPackageOptions Cabal -> Rep (CustomPackageOptions Cabal) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep (CustomPackageOptions Cabal) x -> CustomPackageOptions Cabal
$cfrom :: forall x.
CustomPackageOptions Cabal -> Rep (CustomPackageOptions Cabal) x
Generic)

instance FromJSON (CustomPackageOptions Cabal) where
  parseJSON :: Value -> Parser (CustomPackageOptions Cabal)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"{cabal: ...}" forall a b. (a -> b) -> a -> b
$ \Object
obj ->
    if forall a. Key -> KeyMap a -> Bool
AKM.member Key
"cabal" Object
obj
      then do
        Object
dic <- Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"cabal"
        Maybe (Path Rel File)
projectFile <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ Object
dic forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"projectFile"
        Maybe (Either Bool String)
update <-
          if forall a. Key -> KeyMap a -> Bool
AKM.member Key
"update" Object
dic
            then
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
dic forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"update")
                  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
dic forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"update")
            else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        forall (f :: * -> *) a. Applicative f => a -> f a
pure CabalOptions {Maybe (Either Bool String)
Maybe (Path Rel File)
update :: Maybe (Either Bool String)
projectFile :: Maybe (Path Rel File)
update :: Maybe (Either Bool String)
projectFile :: Maybe (Path Rel File)
..}
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Rel File)
-> Maybe (Either Bool String) -> CustomPackageOptions Cabal
CabalOptions forall a. Maybe a
Nothing forall a. Maybe a
Nothing)

buildPackageGraph :: PackageGraphOptions Cabal -> IO PackageGraph
buildPackageGraph :: PackageGraphOptions Cabal -> IO (Graph PackageName)
buildPackageGraph PackageGraphOptions {customOptions :: forall backend.
PackageGraphOptions backend -> CustomPackageOptions backend
customOptions = CabalOptions {Maybe (Either Bool String)
Maybe (Path Rel File)
update :: Maybe (Either Bool String)
projectFile :: Maybe (Path Rel File)
update :: CustomPackageOptions Cabal -> Maybe (Either Bool String)
projectFile :: CustomPackageOptions Cabal -> Maybe (Path Rel File)
..}, Path Abs Dir
ComponentsOptions
components :: forall backend. PackageGraphOptions backend -> ComponentsOptions
targetPath :: forall backend. PackageGraphOptions backend -> Path Abs Dir
components :: ComponentsOptions
targetPath :: Path Abs Dir
..} = do
  let target :: String
target = Path Abs Dir -> String
fromAbsDir Path Abs Dir
targetPath
      mproj :: Maybe String
mproj = Path Abs File -> String
fromAbsFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs Dir
targetPath forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Path Rel File)
projectFile
      root :: ProjectRoot
root = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ProjectRoot
ProjectRootImplicit String
target) (String -> String -> ProjectRoot
ProjectRootExplicit String
target) Maybe String
mproj
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a b. a -> Either a b -> a
fromLeft Bool
True) Maybe (Either Bool String)
update) forall a b. (a -> b) -> a -> b
$ do
    let targets :: [String]
targets
          | Just (Right String
idx) <- Maybe (Either Bool String)
update = [String
idx]
          | Bool
otherwise = []
    NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
updateAction (forall a. a -> NixStyleFlags a
defaultNixStyleFlags ()) [String]
targets forall a. Monoid a => a
mempty

  ProjectBaseContext
ctx0 <- Verbosity
-> ProjectConfig
-> ProjectRoot
-> CurrentCommand
-> IO ProjectBaseContext
establishProjectBaseContextWithRoot Verbosity
silent forall a. Monoid a => a
mempty ProjectRoot
root CurrentCommand
OtherCommand
  let pjCfg' :: ProjectConfig
pjCfg' =
        ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
ctx0
          forall a b. a -> (a -> b) -> b
& forall a. IsLabel "projectConfigLocalPackages" a => a
#projectConfigLocalPackages forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsLabel "packageConfigTests" a => a
#packageConfigTests
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Flag a
Flag (ComponentsOptions -> Bool
tests ComponentsOptions
components)
          forall a b. a -> (a -> b) -> b
& forall a. IsLabel "projectConfigLocalPackages" a => a
#projectConfigLocalPackages forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsLabel "packageConfigBenchmarks" a => a
#packageConfigBenchmarks
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Flag a
Flag (ComponentsOptions -> Bool
benchmarks ComponentsOptions
components)
      -- ProjectBaseContext has no Generic instance...
      ctx :: ProjectBaseContext
ctx = ProjectBaseContext
ctx0 {projectConfig :: ProjectConfig
projectConfig = ProjectConfig
pjCfg'}

  forall a.
Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
-> IO a
withInstallPlan Verbosity
silent ProjectBaseContext
ctx forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
iplan ElaboratedSharedConfig
_scfg -> do
    let localPkgDic :: Map UnitId ElaboratedConfiguredPackage
localPkgDic =
          forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe
            ( \case
                Configured ElaboratedConfiguredPackage
pkg
                  | ElaboratedConfiguredPackage -> Bool
elabLocalToProject ElaboratedConfiguredPackage
pkg -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ElaboratedConfiguredPackage
pkg
                Installed ElaboratedConfiguredPackage
pkg
                  | ElaboratedConfiguredPackage -> Bool
elabLocalToProject ElaboratedConfiguredPackage
pkg -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ElaboratedConfiguredPackage
pkg
                GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
_ -> forall a. Maybe a
Nothing
            )
            forall a b. (a -> b) -> a -> b
$ forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
Plan.toMap ElaboratedInstallPlan
iplan
        localUnitIds :: Set UnitId
localUnitIds = forall k a. Map k a -> Set k
Map.keysSet Map UnitId ElaboratedConfiguredPackage
localPkgDic
        gr :: Graph PackageName
gr =
          forall gr. Overlayed gr -> gr
getOverlayed forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
              ( \ElaboratedConfiguredPackage
pkg ->
                  let srcPkg :: PackageName
srcPkg = forall pkg. Package pkg => pkg -> PackageName
packageName' ElaboratedConfiguredPackage
pkg
                      deps :: [PackageName]
deps =
                        forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= PackageName
srcPkg)
                          forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                            (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall pkg. Package pkg => pkg -> PackageName
packageName' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map UnitId ElaboratedConfiguredPackage
localPkgDic))
                          forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
localUnitIds)
                          forall a b. (a -> b) -> a -> b
$ forall a. IsUnit a => a -> [UnitId]
depends ElaboratedConfiguredPackage
pkg
                   in forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall gr. gr -> Overlayed gr
Overlayed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a -> Graph a
G.edge PackageName
srcPkg) [PackageName]
deps
              )
              Map UnitId ElaboratedConfiguredPackage
localPkgDic
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Graph PackageName
gr

packageName' :: Package pkg => pkg -> Guard.PackageName
packageName' :: forall pkg. Package pkg => pkg -> PackageName
packageName' = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
unPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. Package pkg => pkg -> PackageName
packageName