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

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

import           Data.Aeson.Types ( Value )
import           Data.Aeson.WarningParser
                   ( WithJSONWarnings, (...:), (..:?), (..!=), jsonSubWarnings
                   , jsonSubWarningsT, jsonSubWarningsTT, withObjectWarnings
                   )
import qualified Data.Set as Set
import qualified Data.Yaml as Yaml
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 =
  String
-> (Object -> WarningParser (IO ProjectAndConfigMonoid))
-> Value
-> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
forall a.
String
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings String
"ProjectAndConfigMonoid" ((Object -> WarningParser (IO ProjectAndConfigMonoid))
 -> Value -> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid)))
-> (Object -> WarningParser (IO ProjectAndConfigMonoid))
-> Value
-> Parser (WithJSONWarnings (IO ProjectAndConfigMonoid))
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    [RelFilePath]
packages <- Object
o Object -> Text -> WarningParser (Maybe [RelFilePath])
forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"packages" WarningParser (Maybe [RelFilePath])
-> [RelFilePath] -> WarningParser [RelFilePath]
forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= [Text -> RelFilePath
RelFilePath Text
"."]
    [Unresolved (NonEmpty RawPackageLocation)]
deps <- WarningParser
  (Maybe
     [WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))])
-> WarningParser (Maybe [Unresolved (NonEmpty RawPackageLocation)])
forall (t :: * -> *) (u :: * -> *) a.
(Traversable t, Traversable u) =>
WarningParser (u (t (WithJSONWarnings a)))
-> WarningParser (u (t a))
jsonSubWarningsTT (Object
o Object
-> Text
-> WarningParser
     (Maybe
        [WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))])
forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"extra-deps") WarningParser (Maybe [Unresolved (NonEmpty RawPackageLocation)])
-> [Unresolved (NonEmpty RawPackageLocation)]
-> WarningParser [Unresolved (NonEmpty RawPackageLocation)]
forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= []
    Map (CabalString PackageName) (Map (CabalString FlagName) Bool)
flags' <- Object
o Object
-> Text
-> WarningParser
     (Maybe
        (Map (CabalString PackageName) (Map (CabalString FlagName) Bool)))
forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"flags" WarningParser
  (Maybe
     (Map (CabalString PackageName) (Map (CabalString FlagName) Bool)))
-> Map (CabalString PackageName) (Map (CabalString FlagName) Bool)
-> WarningParser
     (Map (CabalString PackageName) (Map (CabalString FlagName) Bool))
forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Map (CabalString PackageName) (Map (CabalString FlagName) Bool)
forall a. Monoid a => a
mempty
    let flags :: Map PackageName (Map FlagName Bool)
flags = Map (CabalString FlagName) Bool -> Map FlagName Bool
forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap (Map (CabalString FlagName) Bool -> Map FlagName Bool)
-> Map PackageName (Map (CabalString FlagName) Bool)
-> Map PackageName (Map FlagName Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (CabalString PackageName) (Map (CabalString FlagName) Bool)
-> Map PackageName (Map (CabalString FlagName) Bool)
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 <- WarningParser (WithJSONWarnings (Unresolved RawSnapshotLocation))
-> WarningParser (Unresolved RawSnapshotLocation)
forall a. WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings (WarningParser (WithJSONWarnings (Unresolved RawSnapshotLocation))
 -> WarningParser (Unresolved RawSnapshotLocation))
-> WarningParser
     (WithJSONWarnings (Unresolved RawSnapshotLocation))
-> WarningParser (Unresolved RawSnapshotLocation)
forall a b. (a -> b) -> a -> b
$ Object
o Object
-> [Text]
-> WarningParser
     (WithJSONWarnings (Unresolved RawSnapshotLocation))
forall a. FromJSON a => Object -> [Text] -> WarningParser a
...: [Text
"snapshot", Text
"resolver"]
    Maybe WantedCompiler
mcompiler <- Object
o Object -> Text -> WarningParser (Maybe WantedCompiler)
forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"compiler"
    Maybe String
msg <- Object
o Object -> Text -> WarningParser (Maybe String)
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 Object -> Text -> WarningParser (Maybe [String])
forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"extra-package-dbs" WarningParser (Maybe [String])
-> [String] -> WarningParser [String]
forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= []
    Maybe Curator
mcurator <- WarningParser (Maybe (WithJSONWarnings Curator))
-> WarningParser (Maybe Curator)
forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT (Object
o Object -> Text -> WarningParser (Maybe (WithJSONWarnings Curator))
forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"curator")
    Set (CabalString PackageName)
drops <- Object
o Object
-> Text -> WarningParser (Maybe (Set (CabalString PackageName)))
forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"drop-packages" WarningParser (Maybe (Set (CabalString PackageName)))
-> Set (CabalString PackageName)
-> WarningParser (Set (CabalString PackageName))
forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Set (CabalString PackageName)
forall a. Monoid a => a
mempty
    IO ProjectAndConfigMonoid
-> WarningParser (IO ProjectAndConfigMonoid)
forall a. a -> WriterT WarningParserMonoid Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO ProjectAndConfigMonoid
 -> WarningParser (IO ProjectAndConfigMonoid))
-> IO ProjectAndConfigMonoid
-> WarningParser (IO ProjectAndConfigMonoid)
forall a b. (a -> b) -> a -> b
$ do
      [NonEmpty RawPackageLocation]
deps' <- (Unresolved (NonEmpty RawPackageLocation)
 -> IO (NonEmpty RawPackageLocation))
-> [Unresolved (NonEmpty RawPackageLocation)]
-> IO [NonEmpty RawPackageLocation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Maybe (Path Abs Dir)
-> Unresolved (NonEmpty RawPackageLocation)
-> IO (NonEmpty RawPackageLocation)
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (Path Abs Dir -> Maybe (Path Abs Dir)
forall a. a -> Maybe a
Just Path Abs Dir
rootDir)) [Unresolved (NonEmpty RawPackageLocation)]
deps
      RawSnapshotLocation
resolver' <- Maybe (Path Abs Dir)
-> Unresolved RawSnapshotLocation -> IO RawSnapshotLocation
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (Path Abs Dir -> Maybe (Path Abs Dir)
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 =
                (NonEmpty RawPackageLocation -> [RawPackageLocation])
-> [NonEmpty RawPackageLocation] -> [RawPackageLocation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty RawPackageLocation -> [RawPackageLocation]
forall a. NonEmpty a -> [a]
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 = (CabalString PackageName -> PackageName)
-> Set (CabalString PackageName) -> Set PackageName
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map CabalString PackageName -> PackageName
forall a. CabalString a -> a
unCabalString Set (CabalString PackageName)
drops
            }
      ProjectAndConfigMonoid -> IO ProjectAndConfigMonoid
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectAndConfigMonoid -> IO ProjectAndConfigMonoid)
-> ProjectAndConfigMonoid -> IO ProjectAndConfigMonoid
forall a b. (a -> b) -> a -> b
$ Project -> ConfigMonoid -> ProjectAndConfigMonoid
ProjectAndConfigMonoid Project
project ConfigMonoid
config