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

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

--
-- * 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
$cto :: forall x. Rep PackageEnvironment x -> PackageEnvironment
$cfrom :: forall x. PackageEnvironment -> Rep PackageEnvironment x
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 :: FilePath
userPackageEnvironmentFile = FilePath
"cabal.config"

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

-- | Is there a 'cabal.config' in this directory?
classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType
classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType
classifyPackageEnvironment FilePath
pkgEnvDir = do
     Bool
isUser <- FilePath -> IO Bool
configExists FilePath
userPackageEnvironmentFile
     PackageEnvironmentType -> IO PackageEnvironmentType
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> PackageEnvironmentType
classify Bool
isUser)
  where
    configExists :: FilePath -> IO Bool
configExists FilePath
fname   = FilePath -> IO Bool
doesFileExist (FilePath
pkgEnvDir FilePath -> FilePath -> FilePath
</> FilePath
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 -> FilePath -> Maybe FilePath -> IO PackageEnvironment
userPackageEnvironment Verbosity
verbosity FilePath
pkgEnvDir Maybe FilePath
globalConfigLocation = do
    let path :: FilePath
path = FilePath
pkgEnvDir FilePath -> FilePath -> FilePath
</> FilePath
userPackageEnvironmentFile
    Maybe (ParseResult PackageEnvironment)
minp <- ConstraintSource
-> PackageEnvironment
-> FilePath
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile (FilePath -> ConstraintSource
ConstraintSourceUserConfig FilePath
path)
            PackageEnvironment
forall a. Monoid a => a
mempty FilePath
path
    case (Maybe (ParseResult PackageEnvironment)
minp, Maybe FilePath
globalConfigLocation) of
      (Just ParseResult PackageEnvironment
parseRes, Maybe FilePath
_)  -> FilePath -> ParseResult PackageEnvironment -> IO PackageEnvironment
forall b. Monoid b => FilePath -> ParseResult b -> IO b
processConfigParse FilePath
path ParseResult PackageEnvironment
parseRes
      (Maybe (ParseResult PackageEnvironment)
_, Just FilePath
globalLoc) -> do
        Maybe (ParseResult PackageEnvironment)
minp' <- ConstraintSource
-> PackageEnvironment
-> FilePath
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile (FilePath -> ConstraintSource
ConstraintSourceUserConfig FilePath
globalLoc)
                 PackageEnvironment
forall a. Monoid a => a
mempty FilePath
globalLoc
        IO PackageEnvironment
-> (ParseResult PackageEnvironment -> IO PackageEnvironment)
-> Maybe (ParseResult PackageEnvironment)
-> IO PackageEnvironment
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
"no constraints file found at " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
globalLoc)
               IO () -> IO PackageEnvironment -> IO PackageEnvironment
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PackageEnvironment -> IO PackageEnvironment
forall (m :: * -> *) a. Monad m => a -> m a
return PackageEnvironment
forall a. Monoid a => a
mempty)
          (FilePath -> ParseResult PackageEnvironment -> IO PackageEnvironment
forall b. Monoid b => FilePath -> ParseResult b -> IO b
processConfigParse FilePath
globalLoc)
          Maybe (ParseResult PackageEnvironment)
minp'
      (Maybe (ParseResult PackageEnvironment), Maybe FilePath)
_ -> do
        Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath
"no user package environment file found at " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pkgEnvDir)
        PackageEnvironment -> IO PackageEnvironment
forall (m :: * -> *) a. Monad m => a -> m a
return PackageEnvironment
forall a. Monoid a => a
mempty
  where
    processConfigParse :: FilePath -> ParseResult b -> IO b
processConfigParse FilePath
path (ParseOk [PWarning]
warns b
parseResult) = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PWarning] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warns) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        [FilePath] -> FilePath
unlines ((PWarning -> FilePath) -> [PWarning] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> PWarning -> FilePath
showPWarning FilePath
path) [PWarning]
warns)
      b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
parseResult
    processConfigParse FilePath
path (ParseFailed PError
err) = do
      let (Maybe LineNo
line, FilePath
msg) = PError -> (Maybe LineNo, FilePath)
locatedErrorMsg PError
err
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Error parsing package environment file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> (LineNo -> FilePath) -> Maybe LineNo -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (\LineNo
n -> FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ LineNo -> FilePath
forall a. Show a => a -> FilePath
show LineNo
n) Maybe LineNo
line FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg
      b -> IO b
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 -> FilePath -> Maybe FilePath -> IO SavedConfig
loadUserConfig Verbosity
verbosity FilePath
pkgEnvDir Maybe FilePath
globalConfigLocation =
    (PackageEnvironment -> SavedConfig)
-> IO PackageEnvironment -> IO SavedConfig
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 -> FilePath -> Maybe FilePath -> IO PackageEnvironment
userPackageEnvironment Verbosity
verbosity FilePath
pkgEnvDir Maybe FilePath
globalConfigLocation



-- | Descriptions of all fields in the package environment file.
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs ConstraintSource
src =
  [ FilePath
-> ((UserConstraint, ConstraintSource) -> Doc)
-> ParsecParser (UserConstraint, ConstraintSource)
-> (PackageEnvironment -> [(UserConstraint, ConstraintSource)])
-> ([(UserConstraint, ConstraintSource)]
    -> PackageEnvironment -> PackageEnvironment)
-> FieldDescr PackageEnvironment
forall a b.
FilePath
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaNewLineListFieldParsec FilePath
"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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecParser UserConstraint
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
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 :: [(UserConstraint, ConstraintSource)]
configExConstraints = [(UserConstraint, ConstraintSource)]
v }))

  , FilePath
-> (PackageVersionConstraint -> Doc)
-> ParsecParser PackageVersionConstraint
-> (PackageEnvironment -> [PackageVersionConstraint])
-> ([PackageVersionConstraint]
    -> PackageEnvironment -> PackageEnvironment)
-> FieldDescr PackageEnvironment
forall a b.
FilePath
-> (a -> Doc)
-> ParsecParser a
-> (b -> [a])
-> ([a] -> b -> b)
-> FieldDescr b
commaListFieldParsec FilePath
"preferences"
    PackageVersionConstraint -> Doc
forall a. Pretty a => a -> Doc
pretty ParsecParser PackageVersionConstraint
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
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 :: [PackageVersionConstraint]
configPreferences = [PackageVersionConstraint]
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 FilePath
name SavedConfig -> Doc
_ LineNo -> FilePath -> SavedConfig -> ParseResult SavedConfig
_) -> FilePath
name FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"preference" Bool -> Bool -> Bool
&& FilePath
name FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"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
pkgEnvSavedConfig = SavedConfig
savedConfig})
      FieldDescr SavedConfig
fieldDescr

    updateConfigureExFlags :: PackageEnvironment
                              -> (ConfigExFlags -> ConfigExFlags)
                              -> PackageEnvironment
    updateConfigureExFlags :: PackageEnvironment
-> (ConfigExFlags -> ConfigExFlags) -> PackageEnvironment
updateConfigureExFlags PackageEnvironment
pkgEnv ConfigExFlags -> ConfigExFlags
f = PackageEnvironment
pkgEnv {
      pkgEnvSavedConfig :: SavedConfig
pkgEnvSavedConfig = (PackageEnvironment -> SavedConfig
pkgEnvSavedConfig PackageEnvironment
pkgEnv) {
         savedConfigureExFlags :: ConfigExFlags
savedConfigureExFlags = ConfigExFlags -> ConfigExFlags
f (ConfigExFlags -> ConfigExFlags)
-> (PackageEnvironment -> ConfigExFlags)
-> PackageEnvironment
-> ConfigExFlags
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
                                 (PackageEnvironment -> ConfigExFlags)
-> PackageEnvironment -> ConfigExFlags
forall a b. (a -> b) -> a -> b
$ PackageEnvironment
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
-> FilePath
-> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile ConstraintSource
src PackageEnvironment
initial FilePath
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 (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) (FilePath -> IO ByteString
BS.readFile FilePath
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 (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, [(FilePath, FilePath)]
paths, [(FilePath, [FilePath])]
args) <-
    ((HaddockFlags, InstallDirs (Flag PathTemplate),
  [(FilePath, FilePath)], [(FilePath, [FilePath])])
 -> Field
 -> ParseResult
      (HaddockFlags, InstallDirs (Flag PathTemplate),
       [(FilePath, FilePath)], [(FilePath, [FilePath])]))
-> (HaddockFlags, InstallDirs (Flag PathTemplate),
    [(FilePath, FilePath)], [(FilePath, [FilePath])])
-> [Field]
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate),
      [(FilePath, FilePath)], [(FilePath, [FilePath])])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (HaddockFlags, InstallDirs (Flag PathTemplate),
 [(FilePath, FilePath)], [(FilePath, [FilePath])])
-> Field
-> ParseResult
     (HaddockFlags, InstallDirs (Flag PathTemplate),
      [(FilePath, FilePath)], [(FilePath, [FilePath])])
parseSections
    (SavedConfig -> HaddockFlags
savedHaddockFlags SavedConfig
config, InstallDirs (Flag PathTemplate)
installDirs0, [], [])
    [Field]
knownSections
  PackageEnvironment -> ParseResult PackageEnvironment
forall (m :: * -> *) a. Monad m => a -> m a
return PackageEnvironment
pkgEnv {
    pkgEnvSavedConfig :: SavedConfig
pkgEnvSavedConfig = SavedConfig
config {
       savedConfigureFlags :: ConfigFlags
savedConfigureFlags    = (SavedConfig -> ConfigFlags
savedConfigureFlags SavedConfig
config) {
          configProgramPaths :: [(FilePath, FilePath)]
configProgramPaths  = [(FilePath, FilePath)]
paths,
          configProgramArgs :: [(FilePath, [FilePath])]
configProgramArgs   = [(FilePath, [FilePath])]
args
          },
       savedHaddockFlags :: HaddockFlags
savedHaddockFlags      = HaddockFlags
haddockFlags,
       savedUserInstallDirs :: InstallDirs (Flag PathTemplate)
savedUserInstallDirs   = InstallDirs (Flag PathTemplate)
installDirs,
       savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate)
savedGlobalInstallDirs = InstallDirs (Flag PathTemplate)
installDirs
       }
    }

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