{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

module Stack.Types.ProjectAndConfigMonoid
  ( ProjectAndConfigMonoid (..)
  , parseProjectAndConfigMonoid
  ) where

import qualified Data.Set as Set
import qualified Data.Yaml as Yaml
import           Pantry.Internal.AesonExtended
                   ( WithJSONWarnings, Value, (...:), (..:?), (..!=)
                   , jsonSubWarnings, jsonSubWarningsT, jsonSubWarningsTT
                   , withObjectWarnings )
import           Stack.Prelude
import           Stack.Types.ConfigMonoid
                   ( ConfigMonoid, parseConfigMonoidObject )
import           Stack.Types.Project ( Project (..) )

data ProjectAndConfigMonoid
  = ProjectAndConfigMonoid !Project !ConfigMonoid

parseProjectAndConfigMonoid ::
     Path Abs Dir
  -> Value
  -> Yaml.Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid :: Path Abs Dir
-> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
parseProjectAndConfigMonoid Path Abs Dir
rootDir =
  forall a.
String
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings String
"ProjectAndConfigMonoid" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    [RelFilePath]
packages <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"packages" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= [Text -> RelFilePath
RelFilePath Text
"."]
    [Unresolved (NonEmpty RawPackageLocation)]
deps <- forall (t :: * -> *) (u :: * -> *) a.
(Traversable t, Traversable u) =>
WarningParser (u (t (WithJSONWarnings a)))
-> WarningParser (u (t a))
jsonSubWarningsTT (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"extra-deps") forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= []
    Map (CabalString PackageName) (Map (CabalString FlagName) Bool)
flags' <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"flags" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall a. Monoid a => a
mempty
    let flags :: Map PackageName (Map FlagName Bool)
flags = forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap
                (Map (CabalString PackageName) (Map (CabalString FlagName) Bool)
flags' :: Map (CabalString PackageName) (Map (CabalString FlagName) Bool))

    Unresolved RawSnapshotLocation
resolver <- forall a. WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings forall a b. (a -> b) -> a -> b
$ Object
o forall a. FromJSON a => Object -> [Text] -> WarningParser a
...: [Text
"snapshot", Text
"resolver"]
    Maybe WantedCompiler
mcompiler <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"compiler"
    Maybe String
msg <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"user-message"
    ConfigMonoid
config <- Path Abs Dir -> Object -> WarningParser ConfigMonoid
parseConfigMonoidObject Path Abs Dir
rootDir Object
o
    [String]
extraPackageDBs <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"extra-package-dbs" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= []
    Maybe Curator
mcurator <- forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"curator")
    Set (CabalString PackageName)
drops <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"drop-packages" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall a. Monoid a => a
mempty
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
      [NonEmpty RawPackageLocation]
deps' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (forall a. a -> Maybe a
Just Path Abs Dir
rootDir)) [Unresolved (NonEmpty RawPackageLocation)]
deps
      RawSnapshotLocation
resolver' <- forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (forall a. a -> Maybe a
Just Path Abs Dir
rootDir) Unresolved RawSnapshotLocation
resolver
      let project :: Project
project = Project
            { projectUserMsg :: Maybe String
projectUserMsg = Maybe String
msg
            , projectResolver :: RawSnapshotLocation
projectResolver = RawSnapshotLocation
resolver'
            , projectCompiler :: Maybe WantedCompiler
projectCompiler = Maybe WantedCompiler
mcompiler -- FIXME make sure resolver' isn't SLCompiler

            , projectExtraPackageDBs :: [String]
projectExtraPackageDBs = [String]
extraPackageDBs
            , projectPackages :: [RelFilePath]
projectPackages = [RelFilePath]
packages
            , projectDependencies :: [RawPackageLocation]
projectDependencies =
                forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ([NonEmpty RawPackageLocation]
deps' :: [NonEmpty RawPackageLocation])
            , projectFlags :: Map PackageName (Map FlagName Bool)
projectFlags = Map PackageName (Map FlagName Bool)
flags
            , projectCurator :: Maybe Curator
projectCurator = Maybe Curator
mcurator
            , projectDropPackages :: Set PackageName
projectDropPackages = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a. CabalString a -> a
unCabalString Set (CabalString PackageName)
drops
            }
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Project -> ConfigMonoid -> ProjectAndConfigMonoid
ProjectAndConfigMonoid Project
project ConfigMonoid
config