{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Client.Sandbox.PackageEnvironment
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Utilities for working with the package environment file. Patterned after
-- Distribution.Client.Config.
module Distribution.Client.Sandbox.PackageEnvironment
  ( PackageEnvironment (..)
  , PackageEnvironmentType (..)
  , classifyPackageEnvironment
  , readPackageEnvironmentFile
  , showPackageEnvironment
  , showPackageEnvironmentWithComments
  , loadUserConfig
  , userPackageEnvironmentFile
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.Config
  ( SavedConfig (..)
  , configFieldDescriptions
  , haddockFlagsFields
  , installDirsFields
  , withProgramOptionsFields
  , withProgramsFields
  )
import Distribution.Client.ParseUtils (parseFields, ppFields, ppSection)
import Distribution.Client.Setup
  ( ConfigExFlags (..)
  )
import Distribution.Client.Targets (userConstraintPackageName)
import Distribution.Deprecated.ParseUtils
  ( FieldDescr (..)
  , ParseResult (..)
  , commaListFieldParsec
  , commaNewLineListFieldParsec
  , liftField
  , lineNo
  , locatedErrorMsg
  , readFields
  , showPWarning
  , syntaxError
  , warning
  )
import Distribution.Simple.InstallDirs (InstallDirs (..), PathTemplate)
import Distribution.Simple.Setup
  ( ConfigFlags (..)
  , Flag (..)
  , HaddockFlags (..)
  )
import Distribution.Simple.Utils (debug, warn)
import Distribution.Solver.Types.ConstraintSource
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import System.IO.Error (isDoesNotExistError)
import Text.PrettyPrint (($+$))

import qualified Data.ByteString as BS
import qualified Distribution.Deprecated.ParseUtils as ParseUtils (Field (..))
import qualified Text.PrettyPrint as Disp

--

-- * Configuration saved in the package environment file

--

-- TODO: would be nice to remove duplication between
-- D.C.Sandbox.PackageEnvironment and D.C.Config.
data PackageEnvironment = PackageEnvironment
  { PackageEnvironment -> SavedConfig
pkgEnvSavedConfig :: SavedConfig
  }
  deriving ((forall x. PackageEnvironment -> Rep PackageEnvironment x)
-> (forall x. Rep PackageEnvironment x -> PackageEnvironment)
-> Generic PackageEnvironment
forall x. Rep PackageEnvironment x -> PackageEnvironment
forall x. PackageEnvironment -> Rep PackageEnvironment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PackageEnvironment -> Rep PackageEnvironment x
from :: forall x. PackageEnvironment -> Rep PackageEnvironment x
$cto :: forall x. Rep PackageEnvironment x -> PackageEnvironment
to :: forall x. Rep PackageEnvironment x -> PackageEnvironment
Generic)

instance Monoid PackageEnvironment where
  mempty :: PackageEnvironment
mempty = PackageEnvironment
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
  mappend :: PackageEnvironment -> PackageEnvironment -> PackageEnvironment
mappend = PackageEnvironment -> PackageEnvironment -> PackageEnvironment
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup PackageEnvironment where
  <> :: PackageEnvironment -> PackageEnvironment -> PackageEnvironment
(<>) = PackageEnvironment -> PackageEnvironment -> PackageEnvironment
forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend

-- | Optional package environment file that can be used to customize the default
-- settings. Created by the user.
userPackageEnvironmentFile :: FilePath
userPackageEnvironmentFile :: String
userPackageEnvironmentFile = String
"cabal.config"

-- | Type of the current package environment.
data PackageEnvironmentType
  = -- | './cabal.config'
    UserPackageEnvironment
  | -- | '~/.config/cabal/config'
    AmbientPackageEnvironment

-- | Is there a 'cabal.config' in this directory?
classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType
classifyPackageEnvironment :: String -> IO PackageEnvironmentType
classifyPackageEnvironment String
pkgEnvDir = do
  Bool
isUser <- String -> IO Bool
configExists String
userPackageEnvironmentFile
  PackageEnvironmentType -> IO PackageEnvironmentType
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> PackageEnvironmentType
classify Bool
isUser)
  where
    configExists :: String -> IO Bool
configExists String
fname = String -> IO Bool
doesFileExist (String
pkgEnvDir String -> String -> String
</> String
fname)

    classify :: Bool -> PackageEnvironmentType
    classify :: Bool -> PackageEnvironmentType
classify Bool
True = PackageEnvironmentType
UserPackageEnvironment
    classify Bool
False = PackageEnvironmentType
AmbientPackageEnvironment

-- | Load the user package environment if it exists (the optional "cabal.config"
-- file). If it does not exist locally, attempt to load an optional global one.
userPackageEnvironment
  :: Verbosity
  -> FilePath
  -> Maybe FilePath
  -> IO PackageEnvironment
userPackageEnvironment :: Verbosity -> String -> Maybe String -> IO PackageEnvironment
userPackageEnvironment Verbosity
verbosity String
pkgEnvDir Maybe String
globalConfigLocation = do
  let path :: String
path = String
pkgEnvDir String -> String -> String
</> String
userPackageEnvironmentFile
  Maybe (ParseResult PackageEnvironment)
minp <-
    ConstraintSource
-> PackageEnvironment
-> String
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile
      (String -> ConstraintSource
ConstraintSourceUserConfig String
path)
      PackageEnvironment
forall a. Monoid a => a
mempty
      String
path
  case (Maybe (ParseResult PackageEnvironment)
minp, Maybe String
globalConfigLocation) of
    (Just ParseResult PackageEnvironment
parseRes, Maybe String
_) -> String -> ParseResult PackageEnvironment -> IO PackageEnvironment
forall {b}. Monoid b => String -> ParseResult b -> IO b
processConfigParse String
path ParseResult PackageEnvironment
parseRes
    (Maybe (ParseResult PackageEnvironment)
_, Just String
globalLoc) -> do
      Maybe (ParseResult PackageEnvironment)
minp' <-
        ConstraintSource
-> PackageEnvironment
-> String
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile
          (String -> ConstraintSource
ConstraintSourceUserConfig String
globalLoc)
          PackageEnvironment
forall a. Monoid a => a
mempty
          String
globalLoc
      IO PackageEnvironment
-> (ParseResult PackageEnvironment -> IO PackageEnvironment)
-> Maybe (ParseResult PackageEnvironment)
-> IO PackageEnvironment
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        ( Verbosity -> String -> IO ()
warn Verbosity
verbosity (String
"no constraints file found at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
globalLoc)
            IO () -> IO PackageEnvironment -> IO PackageEnvironment
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PackageEnvironment -> IO PackageEnvironment
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PackageEnvironment
forall a. Monoid a => a
mempty
        )
        (String -> ParseResult PackageEnvironment -> IO PackageEnvironment
forall {b}. Monoid b => String -> ParseResult b -> IO b
processConfigParse String
globalLoc)
        Maybe (ParseResult PackageEnvironment)
minp'
    (Maybe (ParseResult PackageEnvironment), Maybe String)
_ -> do
      Verbosity -> String -> IO ()
debug Verbosity
verbosity (String
"no user package environment file found at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkgEnvDir)
      PackageEnvironment -> IO PackageEnvironment
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PackageEnvironment
forall a. Monoid a => a
mempty
  where
    processConfigParse :: String -> ParseResult b -> IO b
processConfigParse String
path (ParseOk [PWarning]
warns b
parseResult) = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PWarning] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warns) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unlines ((PWarning -> String) -> [PWarning] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PWarning -> String
showPWarning String
path) [PWarning]
warns)
      b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
parseResult
    processConfigParse String
path (ParseFailed PError
err) = do
      let (Maybe LineNo
line, String
msg) = PError -> (Maybe LineNo, String)
locatedErrorMsg PError
err
      Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"Error parsing package environment file "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (LineNo -> String) -> Maybe LineNo -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\LineNo
n -> String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ LineNo -> String
forall a. Show a => a -> String
show LineNo
n) Maybe LineNo
line
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
      b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
forall a. Monoid a => a
mempty

-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.
loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig
loadUserConfig :: Verbosity -> String -> Maybe String -> IO SavedConfig
loadUserConfig Verbosity
verbosity String
pkgEnvDir Maybe String
globalConfigLocation =
  (PackageEnvironment -> SavedConfig)
-> IO PackageEnvironment -> IO SavedConfig
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageEnvironment -> SavedConfig
pkgEnvSavedConfig (IO PackageEnvironment -> IO SavedConfig)
-> IO PackageEnvironment -> IO SavedConfig
forall a b. (a -> b) -> a -> b
$
    Verbosity -> String -> Maybe String -> IO PackageEnvironment
userPackageEnvironment Verbosity
verbosity String
pkgEnvDir Maybe String
globalConfigLocation

-- | Descriptions of all fields in the package environment file.
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs ConstraintSource
src =
  [ String
-> ((UserConstraint, ConstraintSource) -> Doc)
-> ParsecParser (UserConstraint, ConstraintSource)
-> (PackageEnvironment -> [(UserConstraint, ConstraintSource)])
-> ([(UserConstraint, ConstraintSource)]
    -> PackageEnvironment -> PackageEnvironment)
-> FieldDescr PackageEnvironment
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaNewLineListFieldParsec
      String
"constraints"
      (UserConstraint -> Doc
forall a. Pretty a => a -> Doc
pretty (UserConstraint -> Doc)
-> ((UserConstraint, ConstraintSource) -> UserConstraint)
-> (UserConstraint, ConstraintSource)
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserConstraint, ConstraintSource) -> UserConstraint
forall a b. (a, b) -> a
fst)
      ((\UserConstraint
pc -> (UserConstraint
pc, ConstraintSource
src)) (UserConstraint -> (UserConstraint, ConstraintSource))
-> ParsecParser UserConstraint
-> ParsecParser (UserConstraint, ConstraintSource)
forall a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecParser UserConstraint
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m UserConstraint
parsec)
      ( [(UserConstraint, ConstraintSource)]
-> [(UserConstraint, ConstraintSource)]
forall {b}. [(UserConstraint, b)] -> [(UserConstraint, b)]
sortConstraints
          ([(UserConstraint, ConstraintSource)]
 -> [(UserConstraint, ConstraintSource)])
-> (PackageEnvironment -> [(UserConstraint, ConstraintSource)])
-> PackageEnvironment
-> [(UserConstraint, ConstraintSource)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigExFlags -> [(UserConstraint, ConstraintSource)]
configExConstraints
          (ConfigExFlags -> [(UserConstraint, ConstraintSource)])
-> (PackageEnvironment -> ConfigExFlags)
-> PackageEnvironment
-> [(UserConstraint, ConstraintSource)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigExFlags
savedConfigureExFlags
          (SavedConfig -> ConfigExFlags)
-> (PackageEnvironment -> SavedConfig)
-> PackageEnvironment
-> ConfigExFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageEnvironment -> SavedConfig
pkgEnvSavedConfig
      )
      ( \[(UserConstraint, ConstraintSource)]
v PackageEnvironment
pkgEnv ->
          PackageEnvironment
-> (ConfigExFlags -> ConfigExFlags) -> PackageEnvironment
updateConfigureExFlags
            PackageEnvironment
pkgEnv
            (\ConfigExFlags
flags -> ConfigExFlags
flags{configExConstraints = v})
      )
  , String
-> (PackageVersionConstraint -> Doc)
-> ParsecParser PackageVersionConstraint
-> (PackageEnvironment -> [PackageVersionConstraint])
-> ([PackageVersionConstraint]
    -> PackageEnvironment -> PackageEnvironment)
-> FieldDescr PackageEnvironment
forall a b.
String
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldParsec
      String
"preferences"
      PackageVersionConstraint -> Doc
forall a. Pretty a => a -> Doc
pretty
      ParsecParser PackageVersionConstraint
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m PackageVersionConstraint
parsec
      (ConfigExFlags -> [PackageVersionConstraint]
configPreferences (ConfigExFlags -> [PackageVersionConstraint])
-> (PackageEnvironment -> ConfigExFlags)
-> PackageEnvironment
-> [PackageVersionConstraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SavedConfig -> ConfigExFlags
savedConfigureExFlags (SavedConfig -> ConfigExFlags)
-> (PackageEnvironment -> SavedConfig)
-> PackageEnvironment
-> ConfigExFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageEnvironment -> SavedConfig
pkgEnvSavedConfig)
      ( \[PackageVersionConstraint]
v PackageEnvironment
pkgEnv ->
          PackageEnvironment
-> (ConfigExFlags -> ConfigExFlags) -> PackageEnvironment
updateConfigureExFlags
            PackageEnvironment
pkgEnv
            (\ConfigExFlags
flags -> ConfigExFlags
flags{configPreferences = v})
      )
  ]
    [FieldDescr PackageEnvironment]
-> [FieldDescr PackageEnvironment]
-> [FieldDescr PackageEnvironment]
forall a. [a] -> [a] -> [a]
++ (FieldDescr SavedConfig -> FieldDescr PackageEnvironment)
-> [FieldDescr SavedConfig] -> [FieldDescr PackageEnvironment]
forall a b. (a -> b) -> [a] -> [b]
map FieldDescr SavedConfig -> FieldDescr PackageEnvironment
toPkgEnv [FieldDescr SavedConfig]
configFieldDescriptions'
  where
    configFieldDescriptions' :: [FieldDescr SavedConfig]
    configFieldDescriptions' :: [FieldDescr SavedConfig]
configFieldDescriptions' =
      (FieldDescr SavedConfig -> Bool)
-> [FieldDescr SavedConfig] -> [FieldDescr SavedConfig]
forall a. (a -> Bool) -> [a] -> [a]
filter
        (\(FieldDescr String
name SavedConfig -> Doc
_ LineNo -> String -> SavedConfig -> ParseResult SavedConfig
_) -> String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"preference" Bool -> Bool -> Bool
&& String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"constraint")
        (ConstraintSource -> [FieldDescr SavedConfig]
configFieldDescriptions ConstraintSource
src)

    toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment
    toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment
toPkgEnv FieldDescr SavedConfig
fieldDescr =
      (PackageEnvironment -> SavedConfig)
-> (SavedConfig -> PackageEnvironment -> PackageEnvironment)
-> FieldDescr SavedConfig
-> FieldDescr PackageEnvironment
forall b a.
(b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField
        PackageEnvironment -> SavedConfig
pkgEnvSavedConfig
        (\SavedConfig
savedConfig PackageEnvironment
pkgEnv -> PackageEnvironment
pkgEnv{pkgEnvSavedConfig = savedConfig})
        FieldDescr SavedConfig
fieldDescr

    updateConfigureExFlags
      :: PackageEnvironment
      -> (ConfigExFlags -> ConfigExFlags)
      -> PackageEnvironment
    updateConfigureExFlags :: PackageEnvironment
-> (ConfigExFlags -> ConfigExFlags) -> PackageEnvironment
updateConfigureExFlags PackageEnvironment
pkgEnv ConfigExFlags -> ConfigExFlags
f =
      PackageEnvironment
pkgEnv
        { pkgEnvSavedConfig =
            (pkgEnvSavedConfig pkgEnv)
              { savedConfigureExFlags =
                  f . savedConfigureExFlags . pkgEnvSavedConfig $
                    pkgEnv
              }
        }

    sortConstraints :: [(UserConstraint, b)] -> [(UserConstraint, b)]
sortConstraints = ((UserConstraint, b) -> (UserConstraint, b) -> Ordering)
-> [(UserConstraint, b)] -> [(UserConstraint, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((UserConstraint, b) -> PackageName)
-> (UserConstraint, b) -> (UserConstraint, b) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (((UserConstraint, b) -> PackageName)
 -> (UserConstraint, b) -> (UserConstraint, b) -> Ordering)
-> ((UserConstraint, b) -> PackageName)
-> (UserConstraint, b)
-> (UserConstraint, b)
-> Ordering
forall a b. (a -> b) -> a -> b
$ UserConstraint -> PackageName
userConstraintPackageName (UserConstraint -> PackageName)
-> ((UserConstraint, b) -> UserConstraint)
-> (UserConstraint, b)
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserConstraint, b) -> UserConstraint
forall a b. (a, b) -> a
fst)

-- | Read the package environment file.
readPackageEnvironmentFile
  :: ConstraintSource
  -> PackageEnvironment
  -> FilePath
  -> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile :: ConstraintSource
-> PackageEnvironment
-> String
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile ConstraintSource
src PackageEnvironment
initial String
file =
  IO (Maybe (ParseResult PackageEnvironment))
-> IO (Maybe (ParseResult PackageEnvironment))
forall {a}. IO (Maybe a) -> IO (Maybe a)
handleNotExists (IO (Maybe (ParseResult PackageEnvironment))
 -> IO (Maybe (ParseResult PackageEnvironment)))
-> IO (Maybe (ParseResult PackageEnvironment))
-> IO (Maybe (ParseResult PackageEnvironment))
forall a b. (a -> b) -> a -> b
$
    (ByteString -> Maybe (ParseResult PackageEnvironment))
-> IO ByteString -> IO (Maybe (ParseResult PackageEnvironment))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParseResult PackageEnvironment
-> Maybe (ParseResult PackageEnvironment)
forall a. a -> Maybe a
Just (ParseResult PackageEnvironment
 -> Maybe (ParseResult PackageEnvironment))
-> (ByteString -> ParseResult PackageEnvironment)
-> ByteString
-> Maybe (ParseResult PackageEnvironment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintSource
-> PackageEnvironment
-> ByteString
-> ParseResult PackageEnvironment
parsePackageEnvironment ConstraintSource
src PackageEnvironment
initial) (String -> IO ByteString
BS.readFile String
file)
  where
    handleNotExists :: IO (Maybe a) -> IO (Maybe a)
handleNotExists IO (Maybe a)
action = IO (Maybe a) -> (IOException -> IO (Maybe a)) -> IO (Maybe a)
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO (Maybe a)
action ((IOException -> IO (Maybe a)) -> IO (Maybe a))
-> (IOException -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \IOException
ioe ->
      if IOException -> Bool
isDoesNotExistError IOException
ioe
        then Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        else IOException -> IO (Maybe a)
forall a. IOException -> IO a
ioError IOException
ioe

-- | Parse the package environment file.
parsePackageEnvironment
  :: ConstraintSource
  -> PackageEnvironment
  -> BS.ByteString
  -> ParseResult PackageEnvironment
parsePackageEnvironment :: ConstraintSource
-> PackageEnvironment
-> ByteString
-> ParseResult PackageEnvironment
parsePackageEnvironment ConstraintSource
src PackageEnvironment
initial ByteString
str = do
  [Field]
fields <- ByteString -> ParseResult [Field]
readFields ByteString
str
  let ([Field]
knownSections, [Field]
others) = (Field -> Bool) -> [Field] -> ([Field], [Field])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Field -> Bool
isKnownSection [Field]
fields
  PackageEnvironment
pkgEnv <- [Field] -> ParseResult PackageEnvironment
parse [Field]
others
  let config :: SavedConfig
config = PackageEnvironment -> SavedConfig
pkgEnvSavedConfig PackageEnvironment
pkgEnv
      installDirs0 :: InstallDirs (Flag PathTemplate)
installDirs0 = SavedConfig -> InstallDirs (Flag PathTemplate)
savedUserInstallDirs SavedConfig
config
  (HaddockFlags
haddockFlags, InstallDirs (Flag PathTemplate)
installDirs, [(String, String)]
paths, [(String, [String])]
args) <-
    ((HaddockFlags, InstallDirs (Flag PathTemplate),
  [(String, String)], [(String, [String])])
 -> Field
 -> ParseResult
      (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
       [(String, [String])]))
-> (HaddockFlags, InstallDirs (Flag PathTemplate),
    [(String, String)], [(String, [String])])
-> [Field]
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
      (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> Field
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
parseSections
      (SavedConfig -> HaddockFlags
savedHaddockFlags SavedConfig
config, InstallDirs (Flag PathTemplate)
installDirs0, [], [])
      [Field]
knownSections
  PackageEnvironment -> ParseResult PackageEnvironment
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return
    PackageEnvironment
pkgEnv
      { pkgEnvSavedConfig =
          config
            { savedConfigureFlags =
                (savedConfigureFlags config)
                  { configProgramPaths = paths
                  , configProgramArgs = args
                  }
            , savedHaddockFlags = haddockFlags
            , savedUserInstallDirs = installDirs
            , savedGlobalInstallDirs = installDirs
            }
      }
  where
    isKnownSection :: ParseUtils.Field -> Bool
    isKnownSection :: Field -> Bool
isKnownSection (ParseUtils.Section LineNo
_ String
"haddock" String
_ [Field]
_) = Bool
True
    isKnownSection (ParseUtils.Section LineNo
_ String
"install-dirs" String
_ [Field]
_) = Bool
True
    isKnownSection (ParseUtils.Section LineNo
_ String
"program-locations" String
_ [Field]
_) = Bool
True
    isKnownSection (ParseUtils.Section LineNo
_ String
"program-default-options" String
_ [Field]
_) = Bool
True
    isKnownSection Field
_ = Bool
False

    parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment
    parse :: [Field] -> ParseResult PackageEnvironment
parse = [FieldDescr PackageEnvironment]
-> PackageEnvironment -> [Field] -> ParseResult PackageEnvironment
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields (ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs ConstraintSource
src) PackageEnvironment
initial

    parseSections
      :: SectionsAccum
      -> ParseUtils.Field
      -> ParseResult SectionsAccum
    parseSections :: (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> Field
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
parseSections
      accum :: (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum@(HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(String, String)]
p, [(String, [String])]
a)
      (ParseUtils.Section LineNo
_ String
"haddock" String
name [Field]
fs)
        | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do
            HaddockFlags
h' <- [FieldDescr HaddockFlags]
-> HaddockFlags -> [Field] -> ParseResult HaddockFlags
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr HaddockFlags]
haddockFlagsFields HaddockFlags
h [Field]
fs
            (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h', InstallDirs (Flag PathTemplate)
d, [(String, String)]
p, [(String, [String])]
a)
        | Bool
otherwise = do
            String -> ParseResult ()
warning String
"The 'haddock' section should be unnamed"
            (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum
    parseSections
      (HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(String, String)]
p, [(String, [String])]
a)
      (ParseUtils.Section LineNo
line String
"install-dirs" String
name [Field]
fs)
        | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do
            InstallDirs (Flag PathTemplate)
d' <- [FieldDescr (InstallDirs (Flag PathTemplate))]
-> InstallDirs (Flag PathTemplate)
-> [Field]
-> ParseResult (InstallDirs (Flag PathTemplate))
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields InstallDirs (Flag PathTemplate)
d [Field]
fs
            (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h, InstallDirs (Flag PathTemplate)
d', [(String, String)]
p, [(String, [String])]
a)
        | Bool
otherwise =
            LineNo
-> String
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
forall a. LineNo -> String -> ParseResult a
syntaxError LineNo
line (String
 -> ParseResult
      (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
       [(String, [String])]))
-> String
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
forall a b. (a -> b) -> a -> b
$
              String
"Named 'install-dirs' section: '"
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'. Note that named 'install-dirs' sections are not allowed in the '"
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
userPackageEnvironmentFile
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' file."
    parseSections
      accum :: (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum@(HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(String, String)]
p, [(String, [String])]
a)
      (ParseUtils.Section LineNo
_ String
"program-locations" String
name [Field]
fs)
        | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do
            [(String, String)]
p' <- [FieldDescr [(String, String)]]
-> [(String, String)] -> [Field] -> ParseResult [(String, String)]
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr [(String, String)]]
withProgramsFields [(String, String)]
p [Field]
fs
            (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(String, String)]
p', [(String, [String])]
a)
        | Bool
otherwise = do
            String -> ParseResult ()
warning String
"The 'program-locations' section should be unnamed"
            (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum
    parseSections
      accum :: (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum@(HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(String, String)]
p, [(String, [String])]
a)
      (ParseUtils.Section LineNo
_ String
"program-default-options" String
name [Field]
fs)
        | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do
            [(String, [String])]
a' <- [FieldDescr [(String, [String])]]
-> [(String, [String])]
-> [Field]
-> ParseResult [(String, [String])]
forall a. [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields [FieldDescr [(String, [String])]]
withProgramOptionsFields [(String, [String])]
a [Field]
fs
            (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags
h, InstallDirs (Flag PathTemplate)
d, [(String, String)]
p, [(String, [String])]
a')
        | Bool
otherwise = do
            String -> ParseResult ()
warning String
"The 'program-default-options' section should be unnamed"
            (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum
    parseSections (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum Field
f = do
      String -> ParseResult ()
warning (String -> ParseResult ()) -> String -> ParseResult ()
forall a b. (a -> b) -> a -> b
$ String
"Unrecognized stanza on line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ LineNo -> String
forall a. Show a => a -> String
show (Field -> LineNo
lineNo Field
f)
      (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
      [(String, [String])])
forall a. a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaddockFlags, InstallDirs (Flag PathTemplate), [(String, String)],
 [(String, [String])])
accum

-- | Accumulator type for 'parseSections'.
type SectionsAccum =
  ( HaddockFlags
  , InstallDirs (Flag PathTemplate)
  , [(String, FilePath)]
  , [(String, [String])]
  )

-- | Pretty-print the package environment.
showPackageEnvironment :: PackageEnvironment -> String
showPackageEnvironment :: PackageEnvironment -> String
showPackageEnvironment PackageEnvironment
pkgEnv = Maybe PackageEnvironment -> PackageEnvironment -> String
showPackageEnvironmentWithComments Maybe PackageEnvironment
forall a. Maybe a
Nothing PackageEnvironment
pkgEnv

-- | Pretty-print the package environment with default values for empty fields
-- commented out (just like the default Cabal config file).
showPackageEnvironmentWithComments
  :: (Maybe PackageEnvironment)
  -> PackageEnvironment
  -> String
showPackageEnvironmentWithComments :: Maybe PackageEnvironment -> PackageEnvironment -> String
showPackageEnvironmentWithComments Maybe PackageEnvironment
mdefPkgEnv PackageEnvironment
pkgEnv =
  Doc -> String
Disp.render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
    [FieldDescr PackageEnvironment]
-> Maybe PackageEnvironment -> PackageEnvironment -> Doc
forall a. [FieldDescr a] -> Maybe a -> a -> Doc
ppFields
      (ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs ConstraintSource
ConstraintSourceUnknown)
      Maybe PackageEnvironment
mdefPkgEnv
      PackageEnvironment
pkgEnv
      Doc -> Doc -> Doc
$+$ String -> Doc
Disp.text String
""
      Doc -> Doc -> Doc
$+$ String
-> String
-> [FieldDescr (InstallDirs (Flag PathTemplate))]
-> Maybe (InstallDirs (Flag PathTemplate))
-> InstallDirs (Flag PathTemplate)
-> Doc
forall a. String -> String -> [FieldDescr a] -> Maybe a -> a -> Doc
ppSection
        String
"install-dirs"
        String
""
        [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields
        ((PackageEnvironment -> InstallDirs (Flag PathTemplate))
-> Maybe PackageEnvironment
-> Maybe (InstallDirs (Flag PathTemplate))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageEnvironment -> InstallDirs (Flag PathTemplate)
installDirsSection Maybe PackageEnvironment
mdefPkgEnv)
        (PackageEnvironment -> InstallDirs (Flag PathTemplate)
installDirsSection PackageEnvironment
pkgEnv)
  where
    installDirsSection :: PackageEnvironment -> InstallDirs (Flag PathTemplate)
installDirsSection = SavedConfig -> InstallDirs (Flag PathTemplate)
savedUserInstallDirs (SavedConfig -> InstallDirs (Flag PathTemplate))
-> (PackageEnvironment -> SavedConfig)
-> PackageEnvironment
-> InstallDirs (Flag PathTemplate)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageEnvironment -> SavedConfig
pkgEnvSavedConfig