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

{-|
Module      : Stack.Types.ProjectAndConfigMonoid
License     : BSD-3-Clause
-}

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
    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
"."]
    deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= []
    flags' <- o ..:? "flags" ..!= mempty
    let flagsByPkg = 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))

    snapshot' <- jsonSubWarnings $ o ...: ["snapshot", "resolver"]
    compiler <- o ..:? "compiler"
    userMsg <- o ..:? "user-message"
    config <- parseConfigMonoidObject rootDir o
    extraPackageDBs <- o ..:? "extra-package-dbs" ..!= []
    curator <- jsonSubWarningsT (o ..:? "curator")
    drops <- o ..:? "drop-packages" ..!= mempty
    let dropPackages = (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
    pure $ do
      deps' <- mapM (resolvePaths (Just rootDir)) deps
      let extraDeps =
            (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])
      snapshot <- resolvePaths (Just rootDir) snapshot'
      let project = Project
            { Maybe String
userMsg :: Maybe String
userMsg :: Maybe String
userMsg
            , RawSnapshotLocation
snapshot :: RawSnapshotLocation
snapshot :: RawSnapshotLocation
snapshot
            , Maybe WantedCompiler
compiler :: Maybe WantedCompiler
compiler :: Maybe WantedCompiler
compiler -- FIXME make sure snapshot' isn't SLCompiler

            , [String]
extraPackageDBs :: [String]
extraPackageDBs :: [String]
extraPackageDBs
            , [RelFilePath]
packages :: [RelFilePath]
packages :: [RelFilePath]
packages
            , [RawPackageLocation]
extraDeps :: [RawPackageLocation]
extraDeps :: [RawPackageLocation]
extraDeps
            , Map PackageName (Map FlagName Bool)
flagsByPkg :: Map PackageName (Map FlagName Bool)
flagsByPkg :: Map PackageName (Map FlagName Bool)
flagsByPkg
            , Maybe Curator
curator :: Maybe Curator
curator :: Maybe Curator
curator
            , Set PackageName
dropPackages :: Set PackageName
dropPackages :: Set PackageName
dropPackages
            }
      pure $ ProjectAndConfigMonoid project config