PackageEnvironment.hs 12.9 KB
Newer Older
1
2
-----------------------------------------------------------------------------
-- |
3
-- Module      :  Distribution.Client.PackageEnvironment
4
5
6
7
8
9
10
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Utilities for working with the package environment file. Patterned after
-- Distribution.Client.Config.
-----------------------------------------------------------------------------

11
module Distribution.Client.PackageEnvironment (
12
13
    PackageEnvironment(..),
    loadPackageEnvironment,
14
    showPackageEnvironment,
15
16
17
18
19
    showPackageEnvironmentWithComments,

    basePackageEnvironment,
    initialPackageEnvironment,
    commentPackageEnvironment
refold's avatar
refold committed
20
  ) where
21

22
23
24
25
import Distribution.Client.Config      ( SavedConfig(..), commentSavedConfig,
                                         initialSavedConfig, loadConfig,
                                         configFieldDescriptions,
                                         installDirsFields, defaultCompiler )
26
import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection )
27
28
import Distribution.Client.Setup       ( GlobalFlags(..), ConfigExFlags(..)
                                       , InstallFlags(..) )
29
30
31
32
33
import Distribution.Simple.Compiler    ( PackageDB(..) )
import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate,
                                         toPathTemplate )
import Distribution.Simple.Setup       ( Flag(..), ConfigFlags(..),
                                         fromFlagOrDefault, toFlag )
34
35
import Distribution.Simple.Utils       ( notice, warn, lowercase )
import Distribution.ParseUtils         ( FieldDescr(..), ParseResult(..),
36
                                         commaListField,
refold's avatar
refold committed
37
                                         liftField, lineNo, locatedErrorMsg,
38
39
                                         parseFilePathQ, readFields,
                                         showPWarning, simpleField, warning )
40
import Distribution.Verbosity          ( Verbosity, normal )
41
42
43
44
import Control.Monad                   ( foldM, when )
import Data.List                       ( partition )
import Data.Monoid                     ( Monoid(..) )
import Distribution.Compat.Exception   ( catchIO )
45
46
import System.Directory                ( renameFile )
import System.FilePath                 ( (<.>), (</>) )
47
48
import System.IO.Error                 ( isDoesNotExistError )
import Text.PrettyPrint                ( ($+$) )
49
50
51

import qualified Text.PrettyPrint          as Disp
import qualified Distribution.Compat.ReadP as Parse
52
import qualified Distribution.ParseUtils   as ParseUtils ( Field(..) )
53
import qualified Distribution.Text         as Text
refold's avatar
refold committed
54

55
56
57
58
--
-- * Configuration saved in the package environment file
--

59
60
-- TODO: would be nice to remove duplication between D.C.PackageEnvironment and
-- D.C.Config.
61
data PackageEnvironment = PackageEnvironment {
62
63
  pkgEnvInherit       :: Flag FilePath,
  pkgEnvSavedConfig   :: SavedConfig
64
65
}

66
67
instance Monoid PackageEnvironment where
  mempty = PackageEnvironment {
68
69
    pkgEnvInherit       = mempty,
    pkgEnvSavedConfig   = mempty
70
71
    }

72
  mappend a b = PackageEnvironment {
73
74
    pkgEnvInherit       = combine pkgEnvInherit,
    pkgEnvSavedConfig   = combine pkgEnvSavedConfig
75
76
77
78
    }
    where
      combine f = f a `mappend` f b

79
80
defaultPackageEnvironmentFileName :: FilePath
defaultPackageEnvironmentFileName = "pkgenv"
81
82
83

-- | Defaults common to 'initialPackageEnvironment' and
-- 'commentPackageEnvironment'.
refold's avatar
refold committed
84
85
commonPackageEnvironmentConfig :: FilePath -> SavedConfig
commonPackageEnvironmentConfig pkgEnvDir =
86
87
  mempty {
    savedConfigureFlags = mempty {
88
89
       configUserInstall = toFlag False,
       configInstallDirs = sandboxInstallDirs
90
       },
91
92
    savedUserInstallDirs   = sandboxInstallDirs,
    savedGlobalInstallDirs = sandboxInstallDirs,
93
94
    savedGlobalFlags = mempty {
      globalLogsDir = toFlag $ pkgEnvDir </> "logs",
refold's avatar
refold committed
95
      -- Is this right? cabal-dev uses the global world file.
96
97
98
      globalWorldFile = toFlag $ pkgEnvDir </> "world"
      }
    }
99
100
  where
    sandboxInstallDirs = mempty { prefix = toFlag (toPathTemplate pkgEnvDir) }
101
102
103
104
105

-- | These are the absolute basic defaults, the fields that must be
-- initialised. When we load the package environment from the file we layer the
-- loaded values over these ones.
basePackageEnvironment :: FilePath -> PackageEnvironment
106
basePackageEnvironment pkgEnvDir = do
refold's avatar
refold committed
107
  let baseConf = commonPackageEnvironmentConfig pkgEnvDir in
108
109
110
111
112
113
    mempty {
      pkgEnvSavedConfig = baseConf {
         savedConfigureFlags = (savedConfigureFlags baseConf) {
            configHcFlavor    = toFlag defaultCompiler,
            configVerbosity   = toFlag normal
            }
refold's avatar
refold committed
114
         }
115
      }
refold's avatar
refold committed
116
117
118
119

-- | Initial configuration that we write out to the package environment file if
-- it does not exist. When the package environment gets loaded it gets layered
-- on top of 'basePackageEnvironment'.
120
initialPackageEnvironment :: FilePath -> IO PackageEnvironment
121
initialPackageEnvironment pkgEnvDir = do
122
  initialConf' <- initialSavedConfig
refold's avatar
refold committed
123
  let baseConf =  commonPackageEnvironmentConfig pkgEnvDir
124
  let initialConf = initialConf' `mappend` baseConf
125
  return $ mempty {
126
127
    pkgEnvSavedConfig = initialConf {
       savedGlobalFlags = (savedGlobalFlags initialConf) {
refold's avatar
refold committed
128
129
          globalLocalRepos = [pkgEnvDir </> "packages"]
          },
130
       savedConfigureFlags = (savedConfigureFlags initialConf) {
refold's avatar
refold committed
131
132
133
         -- TODO: This should include comp. flavor and version
         configPackageDBs = [Just (SpecificPackageDB $ pkgEnvDir
                                   </> "packages.conf.d")]
134
         },
135
       savedInstallFlags = (savedInstallFlags initialConf) {
refold's avatar
refold committed
136
137
138
139
         installSummaryFile = [toPathTemplate (pkgEnvDir </>
                                               "logs" </> "build.log")]
         }
       }
140
    }
refold's avatar
refold committed
141
142
143

-- | Default values that get used if no value is given. Used here to include in
-- comments when we write out the initial package environment.
144
commentPackageEnvironment :: FilePath -> IO PackageEnvironment
145
commentPackageEnvironment pkgEnvDir = do
146
  commentConf  <- commentSavedConfig
refold's avatar
refold committed
147
  let baseConf =  commonPackageEnvironmentConfig pkgEnvDir
refold's avatar
refold committed
148
149
150
  return $ mempty {
    pkgEnvSavedConfig = commentConf `mappend` baseConf
    }
151

152
153
-- | Load the package environment file, creating it if doesn't exist. Note that
-- the path parameter should be a name of an existing directory.
154
loadPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment
155
156
157
loadPackageEnvironment verbosity pkgEnvDir = do
  let path = pkgEnvDir </> defaultPackageEnvironmentFileName
  addBasePkgEnv $ do
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
    minp <- readPackageEnvironmentFile mempty path
    case minp of
      Nothing -> do
        notice verbosity $ "Writing default package environment to " ++ path
        commentPkgEnv <- commentPackageEnvironment pkgEnvDir
        initialPkgEnv <- initialPackageEnvironment pkgEnvDir
        writePackageEnvironmentFile path commentPkgEnv initialPkgEnv
        return initialPkgEnv
      Just (ParseOk warns pkgEnv) -> do
        when (not $ null warns) $ warn verbosity $
          unlines (map (showPWarning path) warns)
        return pkgEnv
      Just (ParseFailed err) -> do
        let (line, msg) = locatedErrorMsg err
        warn verbosity $
          "Error parsing package environment file " ++ path
          ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
        warn verbosity $ "Using default package environment."
        initialPackageEnvironment pkgEnvDir
refold's avatar
refold committed
177
  where
178
179
    addBasePkgEnv :: IO PackageEnvironment -> IO PackageEnvironment
    addBasePkgEnv body = do
180
181
      let base  = basePackageEnvironment pkgEnvDir
      extra    <- body
refold's avatar
refold committed
182
183
184
185
186
187
188
      case pkgEnvInherit extra of
        NoFlag          ->
          return $ base `mappend` extra
        (Flag confPath) -> do
          conf <- loadConfig verbosity (Flag confPath) (Flag False)
          let conf' = base `mappend` conf `mappend` (pkgEnvSavedConfig extra)
          return $ extra { pkgEnvSavedConfig = conf' }
189
190

-- | Descriptions of all fields in the package environment file.
191
pkgEnvFieldDescrs :: [FieldDescr PackageEnvironment]
192
193
pkgEnvFieldDescrs = [
  simpleField "inherit"
194
    (fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ)
195
    pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v })
196
197
198
199
200
201
202
203
204
205
206
207
208

    -- FIXME: Should we make these fields part of ~/.cabal/config ?
  , commaListField "constraints"
    Text.disp Text.parse
    (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)
    (\v pkgEnv -> updateConfigureExFlags pkgEnv
                  (\flags -> flags { configExConstraints = v }))

  , commaListField "preferences"
    Text.disp Text.parse
    (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig)
    (\v pkgEnv -> updateConfigureExFlags pkgEnv
                  (\flags -> flags { configPreferences = v }))
209
  ]
210
  ++ map toPkgEnv configFieldDescriptions'
211
212
213
  where
    optional = Parse.option mempty . fmap toFlag

214
215
216
217
218
    configFieldDescriptions' :: [FieldDescr SavedConfig]
    configFieldDescriptions' = filter
      (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")
      configFieldDescriptions

219
    toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment
220
221
222
223
224
    toPkgEnv fieldDescr =
      liftField pkgEnvSavedConfig
      (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig})
      fieldDescr

225
226
227
228
229
230
231
232
233
234
    updateConfigureExFlags :: PackageEnvironment
                              -> (ConfigExFlags -> ConfigExFlags)
                              -> PackageEnvironment
    updateConfigureExFlags pkgEnv f = pkgEnv {
      pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) {
         savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig
                                 $ pkgEnv
         }
      }

235
-- | Read the package environment file.
236
237
238
239
240
readPackageEnvironmentFile :: PackageEnvironment -> FilePath
                              -> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile initial file =
  handleNotExists $
  fmap (Just . parsePackageEnvironment initial) (readFile file)
241
242
243
244
245
246
247
  where
    handleNotExists action = catchIO action $ \ioe ->
      if isDoesNotExistError ioe
        then return Nothing
        else ioError ioe

-- | Parse the package environment file.
248
249
250
parsePackageEnvironment :: PackageEnvironment -> String
                           -> ParseResult PackageEnvironment
parsePackageEnvironment initial str = do
251
252
253
254
255
  fields <- readFields str
  let (knownSections, others) = partition isKnownSection fields
  pkgEnv <- parse others
  let config       = pkgEnvSavedConfig pkgEnv
      installDirs0 = savedUserInstallDirs config
refold's avatar
refold committed
256
  -- 'install-dirs' is the only section that we care about.
257
258
259
260
261
262
263
264
265
266
267
268
269
  installDirs <- foldM parseSection installDirs0 knownSections
  return pkgEnv {
    pkgEnvSavedConfig = config {
       savedUserInstallDirs   = installDirs,
       savedGlobalInstallDirs = installDirs
       }
    }

  where
    isKnownSection :: ParseUtils.Field -> Bool
    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
    isKnownSection _                                         = False

270
    parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment
271
272
273
274
275
276
277
278
279
280
281
282
283
284
    parse = parseFields pkgEnvFieldDescrs initial

    parseSection :: InstallDirs (Flag PathTemplate)
                    -> ParseUtils.Field
                    -> ParseResult (InstallDirs (Flag PathTemplate))
    parseSection accum (ParseUtils.Section _ "install-dirs" name fs)
      | name' == "" = do accum' <- parseFields installDirsFields accum fs
                         return accum'
      | otherwise   = do warning "The install-dirs section should be unnamed"
                         return accum
      where name' = lowercase name
    parseSection accum f = do
      warning $ "Unrecognized stanza on line " ++ show (lineNo f)
      return accum
285
286

-- | Write out the package environment file.
287
288
289
writePackageEnvironmentFile :: FilePath -> PackageEnvironment
                               -> PackageEnvironment -> IO ()
writePackageEnvironmentFile path comments pkgEnv = do
290
  let tmpPath = (path <.> "tmp")
291
292
  writeFile tmpPath $ explanation
    ++ showPackageEnvironmentWithComments comments pkgEnv ++ "\n"
293
  renameFile tmpPath path
refold's avatar
refold committed
294
295
296
297
298
299
300
301
302
303
304
305
  where
    explanation = unlines
      ["-- This is a Cabal package environment file."
      ,""
      ,"-- The available configuration options are listed below."
      ,"-- Some of them have default values listed."
      ,""
      ,"-- Lines (like this one) beginning with '--' are comments."
      ,"-- Be careful with spaces and indentation because they are"
      ,"-- used to indicate layout for nested sections."
      ,"",""
      ]
306
307

-- | Pretty-print the package environment data.
308
309
showPackageEnvironment :: PackageEnvironment -> String
showPackageEnvironment = showPackageEnvironmentWithComments mempty
310

311
312
313
showPackageEnvironmentWithComments :: PackageEnvironment -> PackageEnvironment
                                      -> String
showPackageEnvironmentWithComments defPkgEnv pkgEnv = Disp.render $
314
315
316
317
318
319
      ppFields pkgEnvFieldDescrs defPkgEnv pkgEnv
  $+$ Disp.text ""
  $+$ ppSection "install-dirs" "" installDirsFields
                (field defPkgEnv) (field pkgEnv)
  where
    field = savedUserInstallDirs . pkgEnvSavedConfig