{-# 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)
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