{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

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

import qualified Algebra.Graph as G
import Control.Applicative ((<**>))
import Data.Aeson (FromJSON (parseJSON))
import qualified Data.Aeson as J
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import Development.Guardian.Graph.Adapter.Types
import Development.Guardian.Types (Overlayed (Overlayed, getOverlayed), PackageGraph)
import qualified Development.Guardian.Types as Guard
import Distribution.Simple (unPackageName)
import GHC.Generics (Generic)
import Options.Applicative (helper)
import qualified Options.Applicative as Opt
import Path (fromAbsDir)
import Path.IO (withCurrentDir)
import Stack.Build.Source (loadLocalPackage)
import Stack.Options.GlobalParser (globalOptsFromMonoid, globalOptsParser)
import Stack.Options.Utils (GlobalOptsContext (OuterGlobalOpts))
import Stack.Prelude (RIO, toList, view)
import qualified Stack.Prelude as Stack
import Stack.Runners (ShouldReexec (NoReexec), withConfig, withDefaultEnvConfig, withRunnerGlobal)
import Stack.Types.Build (LocalPackage)
import Stack.Types.Config (HasBuildConfig, HasSourceMap (sourceMapL))
import Stack.Types.Package (LocalPackage (..), Package (..))
import qualified Stack.Types.Package as Stack
import Stack.Types.SourceMap (SourceMap (..))

data Stack

newtype instance CustomPackageOptions Stack = StackOptions {CustomPackageOptions Stack -> [Text]
stackOptions :: [Text]}
  deriving (Int -> CustomPackageOptions Stack -> ShowS
[CustomPackageOptions Stack] -> ShowS
CustomPackageOptions Stack -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CustomPackageOptions Stack] -> ShowS
$cshowList :: [CustomPackageOptions Stack] -> ShowS
show :: CustomPackageOptions Stack -> String
$cshow :: CustomPackageOptions Stack -> String
showsPrec :: Int -> CustomPackageOptions Stack -> ShowS
$cshowsPrec :: Int -> CustomPackageOptions Stack -> ShowS
Show, CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
$c/= :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
== :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
$c== :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
Eq, Eq (CustomPackageOptions Stack)
CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
CustomPackageOptions Stack
-> CustomPackageOptions Stack -> Ordering
CustomPackageOptions Stack
-> CustomPackageOptions Stack -> CustomPackageOptions Stack
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 Stack
-> CustomPackageOptions Stack -> CustomPackageOptions Stack
$cmin :: CustomPackageOptions Stack
-> CustomPackageOptions Stack -> CustomPackageOptions Stack
max :: CustomPackageOptions Stack
-> CustomPackageOptions Stack -> CustomPackageOptions Stack
$cmax :: CustomPackageOptions Stack
-> CustomPackageOptions Stack -> CustomPackageOptions Stack
>= :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
$c>= :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
> :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
$c> :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
<= :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
$c<= :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
< :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
$c< :: CustomPackageOptions Stack -> CustomPackageOptions Stack -> Bool
compare :: CustomPackageOptions Stack
-> CustomPackageOptions Stack -> Ordering
$ccompare :: CustomPackageOptions Stack
-> CustomPackageOptions Stack -> Ordering
Ord, forall x.
Rep (CustomPackageOptions Stack) x -> CustomPackageOptions Stack
forall x.
CustomPackageOptions Stack -> Rep (CustomPackageOptions Stack) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep (CustomPackageOptions Stack) x -> CustomPackageOptions Stack
$cfrom :: forall x.
CustomPackageOptions Stack -> Rep (CustomPackageOptions Stack) x
Generic)

instance FromJSON (CustomPackageOptions Stack) where
  parseJSON :: Value -> Parser (CustomPackageOptions Stack)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"{stack: }" forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Maybe Object
stack <- Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
J..:? Key
"stack"
    case Maybe Object
stack of
      Maybe Object
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> CustomPackageOptions Stack
StackOptions []
      Just Object
dic -> [Text] -> CustomPackageOptions Stack
StackOptions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
dic forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
J..:? Key
"options" forall a. Parser (Maybe a) -> a -> Parser a
J..!= []

localPackageToPackage :: LocalPackage -> Package
localPackageToPackage :: LocalPackage -> Package
localPackageToPackage LocalPackage
lp =
  forall a. a -> Maybe a -> a
fromMaybe (LocalPackage -> Package
lpPackage LocalPackage
lp) (LocalPackage -> Maybe Package
lpTestBench LocalPackage
lp)

{- | Resolve the direct (depth 0) external dependencies of the given local packages (assumed to come from project packages)

Stolen from @stack@ and further simplified.
-}
projectPackageDependencies ::
  [LocalPackage] -> [(Stack.PackageName, Set Stack.PackageName)]
projectPackageDependencies :: [LocalPackage] -> [(PackageName, Set PackageName)]
projectPackageDependencies [LocalPackage]
locals =
  forall a b. (a -> b) -> [a] -> [b]
map
    ( \LocalPackage
lp ->
        let pkg :: Package
pkg = LocalPackage -> Package
localPackageToPackage LocalPackage
lp
         in (Package -> PackageName
Stack.packageName Package
pkg, Package -> Set PackageName
deps Package
pkg)
    )
    [LocalPackage]
locals
  where
    deps :: Package -> Set PackageName
deps Package
pkg =
      forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set PackageName
localNames (Package -> Set PackageName
packageAllDeps Package
pkg)
    localNames :: Set PackageName
localNames = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Package -> PackageName
Stack.packageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalPackage -> Package
lpPackage) [LocalPackage]
locals

buildPackageGraph :: PackageGraphOptions Stack -> IO PackageGraph
buildPackageGraph :: PackageGraphOptions Stack -> IO PackageGraph
buildPackageGraph PackageGraphOptions {customOptions :: forall backend.
PackageGraphOptions backend -> CustomPackageOptions backend
customOptions = StackOptions {[Text]
stackOptions :: [Text]
stackOptions :: CustomPackageOptions Stack -> [Text]
..}, 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
  forall (m :: * -> *) b a.
(MonadIO m, MonadMask m) =>
Path b Dir -> m a -> m a
withCurrentDir Path Abs Dir
targetPath forall a b. (a -> b) -> a -> b
$ do
    let pInfo :: ParserInfo GlobalOptsMonoid
pInfo =
          forall a. Parser a -> InfoMod a -> ParserInfo a
Opt.info
            (String
-> GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid
globalOptsParser (Path Abs Dir -> String
fromAbsDir Path Abs Dir
targetPath) GlobalOptsContext
OuterGlobalOpts forall a. Maybe a
Nothing forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
helper)
            forall a. Monoid a => a
mempty
        cliOpts :: [String]
cliOpts =
          String
"--skip-ghc-check"
            forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [String
"--test", String
"--no-run-tests"]
              | ComponentsOptions -> Bool
tests ComponentsOptions
components
              ]
              forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ [String
"--bench", String
"--no-run-benchmarks"]
                | ComponentsOptions -> Bool
benchmarks ComponentsOptions
components
                ]
            forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
stackOptions
    Just GlobalOpts
gopt <-
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
MonadIO m =>
Bool -> GlobalOptsMonoid -> m GlobalOpts
globalOptsFromMonoid Bool
False) forall a b. (a -> b) -> a -> b
$
        forall a. ParserResult a -> Maybe a
Opt.getParseResult forall a b. (a -> b) -> a -> b
$
          forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
Opt.execParserPure (PrefsMod -> ParserPrefs
Opt.prefs forall a. Monoid a => a
mempty) ParserInfo GlobalOptsMonoid
pInfo [String]
cliOpts

    forall a. GlobalOpts -> RIO Runner a -> IO a
withRunnerGlobal GlobalOpts
gopt forall a b. (a -> b) -> a -> b
$
      forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec forall a b. (a -> b) -> a -> b
$
        forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig forall env.
(HasSourceMap env, HasBuildConfig env) =>
RIO env PackageGraph
buildPackageGraphM

buildPackageGraphM ::
  (HasSourceMap env, HasBuildConfig env) =>
  RIO env PackageGraph
buildPackageGraphM :: forall env.
(HasSourceMap env, HasBuildConfig env) =>
RIO env PackageGraph
buildPackageGraphM = do
  SourceMap
sourceMap <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => Lens' env SourceMap
sourceMapL
  [LocalPackage]
locals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall env.
(HasBuildConfig env, HasSourceMap env) =>
ProjectPackage -> RIO env LocalPackage
loadLocalPackage forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap
  let gr :: [(PackageName, Set PackageName)]
gr = [LocalPackage] -> [(PackageName, Set PackageName)]
projectPackageDependencies [LocalPackage]
locals
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    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
        ( \(PackageName -> PackageName
fromStackPackageName -> PackageName
pkg, Set PackageName
deps) ->
            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
pkg forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> PackageName
fromStackPackageName) Set PackageName
deps
        )
        [(PackageName, Set PackageName)]
gr

fromStackPackageName :: Stack.PackageName -> Guard.PackageName
fromStackPackageName :: PackageName -> PackageName
fromStackPackageName = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
unPackageName