PackageEnvironment.hs

{-# 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 {
  pkgEnvSavedConfig   :: SavedConfig
} deriving Generic

instance Monoid PackageEnvironment where
  mempty = gmempty
  mappend = (<>)

instance Semigroup PackageEnvironment where
  (<>) = gmappend

-- | Optional package environment file that can be used to customize the default
-- settings. Created by the user.
userPackageEnvironmentFile :: FilePath
userPackageEnvironmentFile = "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 pkgEnvDir = do
     isUser <- configExists userPackageEnvironmentFile
     return (classify isUser)
  where
    configExists fname   = doesFileExist (pkgEnvDir </> fname)

    classify :: Bool -> PackageEnvironmentType
    classify True    = UserPackageEnvironment
    classify False   = 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 pkgEnvDir globalConfigLocation = do
    let path = pkgEnvDir </> userPackageEnvironmentFile
    minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path)
            mempty path
    case (minp, globalConfigLocation) of
      (Just parseRes, _)  -> processConfigParse path parseRes
      (_, Just globalLoc) -> do
        minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc)
                 mempty globalLoc
        maybe (warn verbosity ("no constraints file found at " ++ globalLoc)
               >> return mempty)
          (processConfigParse globalLoc)
          minp'
      _ -> do
        debug verbosity ("no user package environment file found at " ++ pkgEnvDir)
        return mempty
  where
    processConfigParse path (ParseOk warns parseResult) = do
      unless (null warns) $ warn verbosity $
        unlines (map (showPWarning path) warns)
      return parseResult
    processConfigParse path (ParseFailed err) = do
      let (line, msg) = locatedErrorMsg err
      warn verbosity $ "Error parsing package environment file " ++ path
        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
      return mempty

-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.
loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig
loadUserConfig verbosity pkgEnvDir globalConfigLocation =
    fmap pkgEnvSavedConfig $
    userPackageEnvironment verbosity pkgEnvDir globalConfigLocation



-- | Descriptions of all fields in the package environment file.
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs src =
  [ commaNewLineListFieldParsec "constraints"
    (pretty . fst) ((\pc -> (pc, src)) `fmap` parsec)
    (sortConstraints . configExConstraints
     . savedConfigureExFlags . pkgEnvSavedConfig)
    (\v pkgEnv -> updateConfigureExFlags pkgEnv
                  (\flags -> flags { configExConstraints = v }))

  , commaListFieldParsec "preferences"
    pretty parsec
    (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig)
    (\v pkgEnv -> updateConfigureExFlags pkgEnv
                  (\flags -> flags { configPreferences = v }))
  ]
  ++ map toPkgEnv configFieldDescriptions'
  where
    configFieldDescriptions' :: [FieldDescr SavedConfig]
    configFieldDescriptions' = filter
      (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")
      (configFieldDescriptions src)

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

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

    sortConstraints = sortBy (comparing $ userConstraintPackageName . fst)

-- | Read the package environment file.
readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath
                              -> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile src initial file =
  handleNotExists $
  fmap (Just . parsePackageEnvironment src initial) (BS.readFile file)
  where
    handleNotExists action = catchIO action $ \ioe ->
      if isDoesNotExistError ioe
        then return Nothing
        else ioError ioe

-- | Parse the package environment file.
parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> BS.ByteString
                           -> ParseResult PackageEnvironment
parsePackageEnvironment src initial str = do
  fields <- readFields str
  let (knownSections, others) = partition isKnownSection fields
  pkgEnv <- parse others
  let config       = pkgEnvSavedConfig pkgEnv
      installDirs0 = savedUserInstallDirs config
  (haddockFlags, installDirs, paths, args) <-
    foldM parseSections
    (savedHaddockFlags config, installDirs0, [], [])
    knownSections
  return pkgEnv {
    pkgEnvSavedConfig = config {
       savedConfigureFlags    = (savedConfigureFlags config) {
          configProgramPaths  = paths,
          configProgramArgs   = args
          },
       savedHaddockFlags      = haddockFlags,
       savedUserInstallDirs   = installDirs,
       savedGlobalInstallDirs = installDirs
       }
    }

  where
    isKnownSection :: ParseUtils.Field -> Bool
    isKnownSection (ParseUtils.Section _ "haddock" _ _)                 = True
    isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True
    isKnownSection (ParseUtils.Section _ "program-locations" _ _)       = True
    isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True
    isKnownSection _                                                    = False

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

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

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



-- | Pretty-print the package environment.
showPackageEnvironment :: PackageEnvironment -> String
showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing 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 mdefPkgEnv pkgEnv = Disp.render $
      ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown)
               mdefPkgEnv pkgEnv
  $+$ Disp.text ""
  $+$ ppSection "install-dirs" "" installDirsFields
                (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv)
  where
    installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig