{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Distribution.Nixpkgs.Haskell.FromCabal.Configuration
  ( Configuration(..), readConfiguration, assertConsistency
  )
  where

import Prelude hiding ( fail )

import Control.DeepSeq
import Control.Exception ( throwIO )
import Control.Lens
import Control.Monad hiding ( fail )
import Control.Monad.Fail
import Data.Aeson
import Data.Map as Map
import Data.Set as Set
import Data.Text as T
import Data.Yaml
import Distribution.Compiler
import Distribution.Nixpkgs.Haskell.Constraint
import Distribution.Package
import Distribution.System
import GHC.Generics ( Generic )
import Language.Nix.Identifier

data Configuration = Configuration
  {
  -- |Target compiler. Used by 'finalizePackageDescription' to choose
  -- appropriate flags and dependencies.
    Configuration -> CompilerInfo
compilerInfo :: CompilerInfo

  -- |Compiler core packages that are also found on Hackage.
  , Configuration -> Set PackageIdentifier
corePackages :: Set PackageIdentifier

  -- |These packages replace the latest respective version during
  -- dependency resolution.
  , Configuration -> [Constraint]
defaultPackageOverrides :: [Constraint]

  -- |These packages are added to the generated set, but the play no
  -- role during dependency resolution.
  , Configuration -> [Constraint]
extraPackages :: [Constraint]

  -- |This information is used by the @hackage2nix@ utility to determine the
  -- 'maintainers' for a given Haskell package.
  , Configuration -> Map Identifier (Set PackageName)
packageMaintainers :: Map Identifier (Set PackageName)

  -- |These packages (by design) don't support certain platforms.
  , Configuration -> Map PackageName (Set Platform)
unsupportedPlatforms :: Map PackageName (Set Platform)

  -- |These packages cannot be distributed by Hydra, i.e. because they have an
  -- unfree license or depend on other tools that cannot be distributed for
  -- some reason.
  , Configuration -> Set PackageName
dontDistributePackages :: Set PackageName

  -- |We know that these packages won't compile, so we mark them as broken and
  -- also disable their meta.hydraPlatforms attribute to avoid cluttering our
  -- Hydra job with lots of failure messages.
  , Configuration -> [Constraint]
brokenPackages :: [Constraint]
  }
  deriving (Int -> Configuration -> ShowS
[Configuration] -> ShowS
Configuration -> String
(Int -> Configuration -> ShowS)
-> (Configuration -> String)
-> ([Configuration] -> ShowS)
-> Show Configuration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Configuration] -> ShowS
$cshowList :: [Configuration] -> ShowS
show :: Configuration -> String
$cshow :: Configuration -> String
showsPrec :: Int -> Configuration -> ShowS
$cshowsPrec :: Int -> Configuration -> ShowS
Show, (forall x. Configuration -> Rep Configuration x)
-> (forall x. Rep Configuration x -> Configuration)
-> Generic Configuration
forall x. Rep Configuration x -> Configuration
forall x. Configuration -> Rep Configuration x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Configuration x -> Configuration
$cfrom :: forall x. Configuration -> Rep Configuration x
Generic)

instance NFData Configuration

instance FromJSON Configuration where
  parseJSON :: Value -> Parser Configuration
parseJSON (Object Object
o) = CompilerInfo
-> Set PackageIdentifier
-> [Constraint]
-> [Constraint]
-> Map Identifier (Set PackageName)
-> Map PackageName (Set Platform)
-> Set PackageName
-> [Constraint]
-> Configuration
Configuration
        (CompilerInfo
 -> Set PackageIdentifier
 -> [Constraint]
 -> [Constraint]
 -> Map Identifier (Set PackageName)
 -> Map PackageName (Set Platform)
 -> Set PackageName
 -> [Constraint]
 -> Configuration)
-> Parser CompilerInfo
-> Parser
     (Set PackageIdentifier
      -> [Constraint]
      -> [Constraint]
      -> Map Identifier (Set PackageName)
      -> Map PackageName (Set Platform)
      -> Set PackageName
      -> [Constraint]
      -> Configuration)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Maybe CompilerInfo)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"compiler" Parser (Maybe CompilerInfo) -> CompilerInfo -> Parser CompilerInfo
forall a. Parser (Maybe a) -> a -> Parser a
.!= CompilerId -> AbiTag -> CompilerInfo
unknownCompilerInfo CompilerId
buildCompilerId AbiTag
NoAbiTag
        Parser
  (Set PackageIdentifier
   -> [Constraint]
   -> [Constraint]
   -> Map Identifier (Set PackageName)
   -> Map PackageName (Set Platform)
   -> Set PackageName
   -> [Constraint]
   -> Configuration)
-> Parser (Set PackageIdentifier)
-> Parser
     ([Constraint]
      -> [Constraint]
      -> Map Identifier (Set PackageName)
      -> Map PackageName (Set Platform)
      -> Set PackageName
      -> [Constraint]
      -> Configuration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe (Set PackageIdentifier))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"core-packages" Parser (Maybe (Set PackageIdentifier))
-> Set PackageIdentifier -> Parser (Set PackageIdentifier)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Set PackageIdentifier
forall a. Monoid a => a
mempty
        Parser
  ([Constraint]
   -> [Constraint]
   -> Map Identifier (Set PackageName)
   -> Map PackageName (Set Platform)
   -> Set PackageName
   -> [Constraint]
   -> Configuration)
-> Parser [Constraint]
-> Parser
     ([Constraint]
      -> Map Identifier (Set PackageName)
      -> Map PackageName (Set Platform)
      -> Set PackageName
      -> [Constraint]
      -> Configuration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe [Constraint])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"default-package-overrides" Parser (Maybe [Constraint]) -> [Constraint] -> Parser [Constraint]
forall a. Parser (Maybe a) -> a -> Parser a
.!= [Constraint]
forall a. Monoid a => a
mempty
        Parser
  ([Constraint]
   -> Map Identifier (Set PackageName)
   -> Map PackageName (Set Platform)
   -> Set PackageName
   -> [Constraint]
   -> Configuration)
-> Parser [Constraint]
-> Parser
     (Map Identifier (Set PackageName)
      -> Map PackageName (Set Platform)
      -> Set PackageName
      -> [Constraint]
      -> Configuration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe [Constraint])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"extra-packages" Parser (Maybe [Constraint]) -> [Constraint] -> Parser [Constraint]
forall a. Parser (Maybe a) -> a -> Parser a
.!= [Constraint]
forall a. Monoid a => a
mempty
        Parser
  (Map Identifier (Set PackageName)
   -> Map PackageName (Set Platform)
   -> Set PackageName
   -> [Constraint]
   -> Configuration)
-> Parser (Map Identifier (Set PackageName))
-> Parser
     (Map PackageName (Set Platform)
      -> Set PackageName -> [Constraint] -> Configuration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe (Map Identifier (Set PackageName)))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"package-maintainers" Parser (Maybe (Map Identifier (Set PackageName)))
-> Map Identifier (Set PackageName)
-> Parser (Map Identifier (Set PackageName))
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map Identifier (Set PackageName)
forall a. Monoid a => a
mempty
        Parser
  (Map PackageName (Set Platform)
   -> Set PackageName -> [Constraint] -> Configuration)
-> Parser (Map PackageName (Set Platform))
-> Parser (Set PackageName -> [Constraint] -> Configuration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe (Map PackageName (Set Platform)))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"unsupported-platforms" Parser (Maybe (Map PackageName (Set Platform)))
-> Map PackageName (Set Platform)
-> Parser (Map PackageName (Set Platform))
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map PackageName (Set Platform)
forall a. Monoid a => a
mempty
        Parser (Set PackageName -> [Constraint] -> Configuration)
-> Parser (Set PackageName)
-> Parser ([Constraint] -> Configuration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe (Set PackageName))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"dont-distribute-packages" Parser (Maybe (Set PackageName))
-> Set PackageName -> Parser (Set PackageName)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Set PackageName
forall a. Monoid a => a
mempty
        Parser ([Constraint] -> Configuration)
-> Parser [Constraint] -> Parser Configuration
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe [Constraint])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"broken-packages" Parser (Maybe [Constraint]) -> [Constraint] -> Parser [Constraint]
forall a. Parser (Maybe a) -> a -> Parser a
.!= [Constraint]
forall a. Monoid a => a
mempty
  parseJSON Value
_ = String -> Parser Configuration
forall a. HasCallStack => String -> a
error String
"invalid Configuration"

instance FromJSON Identifier where
  parseJSON :: Value -> Parser Identifier
parseJSON (String Text
s) = Identifier -> Parser Identifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AReview Identifier String -> String -> Identifier
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview Identifier String
Iso' Identifier String
ident (Text -> String
T.unpack Text
s))
  parseJSON Value
s = String -> Parser Identifier
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"parseJSON: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not a valid Nix identifier")

instance FromJSONKey Identifier where
  fromJSONKey :: FromJSONKeyFunction Identifier
fromJSONKey = (Text -> Identifier) -> FromJSONKeyFunction Identifier
forall a. (Text -> a) -> FromJSONKeyFunction a
FromJSONKeyText Text -> Identifier
forall k. FromJSON k => Text -> k
parseKey

instance FromJSONKey PackageName where
  fromJSONKey :: FromJSONKeyFunction PackageName
fromJSONKey = (Text -> PackageName) -> FromJSONKeyFunction PackageName
forall a. (Text -> a) -> FromJSONKeyFunction a
FromJSONKeyText Text -> PackageName
forall k. FromJSON k => Text -> k
parseKey

parseKey :: FromJSON k => Text -> k
parseKey :: Text -> k
parseKey Text
s = (String -> k) -> (k -> k) -> Either String k -> k
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> k
forall a. HasCallStack => String -> a
error k -> k
forall a. a -> a
id ((Value -> Parser k) -> Value -> Either String k
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser k
forall a. FromJSON a => Value -> Parser a
parseJSON (Text -> Value
String Text
s))

readConfiguration :: FilePath -> IO Configuration
readConfiguration :: String -> IO Configuration
readConfiguration String
path = String -> IO (Either ParseException Configuration)
forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
path IO (Either ParseException Configuration)
-> (Either ParseException Configuration -> IO Configuration)
-> IO Configuration
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ParseException -> IO Configuration)
-> (Configuration -> IO Configuration)
-> Either ParseException Configuration
-> IO Configuration
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseException -> IO Configuration
forall e a. Exception e => e -> IO a
throwIO Configuration -> IO Configuration
forall (m :: * -> *).
MonadFail m =>
Configuration -> m Configuration
assertConsistency

assertConsistency :: MonadFail m => Configuration -> m Configuration
assertConsistency :: Configuration -> m Configuration
assertConsistency cfg :: Configuration
cfg@Configuration {[Constraint]
CompilerInfo
Set PackageIdentifier
Set PackageName
Map PackageName (Set Platform)
Map Identifier (Set PackageName)
brokenPackages :: [Constraint]
dontDistributePackages :: Set PackageName
unsupportedPlatforms :: Map PackageName (Set Platform)
packageMaintainers :: Map Identifier (Set PackageName)
extraPackages :: [Constraint]
defaultPackageOverrides :: [Constraint]
corePackages :: Set PackageIdentifier
compilerInfo :: CompilerInfo
brokenPackages :: Configuration -> [Constraint]
dontDistributePackages :: Configuration -> Set PackageName
unsupportedPlatforms :: Configuration -> Map PackageName (Set Platform)
packageMaintainers :: Configuration -> Map Identifier (Set PackageName)
extraPackages :: Configuration -> [Constraint]
defaultPackageOverrides :: Configuration -> [Constraint]
corePackages :: Configuration -> Set PackageIdentifier
compilerInfo :: Configuration -> CompilerInfo
..} = do
  let report :: String -> m a
report String
msg = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"*** configuration error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg)
      maintainedPackages :: Set PackageName
maintainedPackages = [Set PackageName] -> Set PackageName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Map Identifier (Set PackageName) -> [Set PackageName]
forall k a. Map k a -> [a]
Map.elems Map Identifier (Set PackageName)
packageMaintainers)
      disabledPackages :: Set PackageName
disabledPackages = Set PackageName
dontDistributePackages Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList (Constraint -> PackageName
depPkgName (Constraint -> PackageName) -> [Constraint] -> [PackageName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Constraint]
brokenPackages)
      disabledMaintainedPackages :: Set PackageName
disabledMaintainedPackages = Set PackageName
maintainedPackages Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set PackageName
disabledPackages
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
disabledMaintainedPackages) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
report (String
"disabled packages that have a maintainer: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set PackageName -> String
forall a. Show a => a -> String
show Set PackageName
disabledMaintainedPackages)

  Configuration -> m Configuration
forall (m :: * -> *) a. Monad m => a -> m a
return Configuration
cfg