Register.hs 14.4 KB
Newer Older
1
2
-----------------------------------------------------------------------------
-- |
ijones's avatar
ijones committed
3
-- Module      :  Distribution.Simple.Register
4
5
6
7
-- Copyright   :  Isaac Jones 2003-2004
-- 
-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>
-- Stability   :  alpha
ijones's avatar
ijones committed
8
-- Portability :  portable
9
--
ijones's avatar
ijones committed
10
11
-- Explanation: Perform the \"@.\/setup register@\" action.
-- Uses a drop-file for HC-PKG.  See also "Distribution.InstalledPackageInfo".
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

{- Copyright (c) 2003-2004, Isaac Jones
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

44
45
46
module Distribution.Simple.Register (
	register,
	unregister,
47
        writeInstalledConfig,
48
	removeInstalledConfig,
49
        removeRegScripts,
50
  ) where
51

52
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..),
53
                                           InstallDirs(..),
54
					   absoluteInstallDirs)
55
import Distribution.Simple.BuildPaths (distPref, haddockName)
56
57
import Distribution.Simple.Compiler
         ( CompilerFlavor(..), compilerFlavor, PackageDB(..) )
58
59
60
import Distribution.Simple.Program (ConfiguredProgram, programPath,
                                    programArgs, rawSystemProgram,
                                    lookupProgram, ghcPkgProgram)
61
62
import Distribution.Simple.Setup (RegisterFlags(..), CopyDest(..),
                                  fromFlag, fromFlagOrDefault)
63
64
import Distribution.PackageDescription (PackageDescription(..),
                                              BuildInfo(..), Library(..))
65
66
import Distribution.Package
         ( packageName, showPackageId, Package(..) )
67
68
69
70
import Distribution.InstalledPackageInfo
	(InstalledPackageInfo, showInstalledPackageInfo, 
	 emptyInstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as IPI
71
import Distribution.Simple.Utils
72
         ( createDirectoryIfMissingVerbose, copyFileVerbose
Duncan Coutts's avatar
Duncan Coutts committed
73
         , die, info, notice, setupMessage )
74
import Distribution.System
75
         ( OS(..), buildOS )
76

77
import System.FilePath ((</>), (<.>), isAbsolute)
78
79
80
81
import System.Directory (removeFile, getCurrentDirectory,
                         removeDirectoryRecursive,
                         setPermissions, getPermissions,
			 Permissions(executable))
82
import System.IO.Error (try)
ijones's avatar
ijones committed
83

84
import Control.Monad (when)
85
import Data.Maybe (isNothing, isJust, fromJust, fromMaybe)
86
import Data.List (partition)
simonmar's avatar
simonmar committed
87

88
regScriptLocation :: FilePath
89
90
91
regScriptLocation = case buildOS of
                        Windows -> "register.bat"
                        _       -> "register.sh"
92
93

unregScriptLocation :: FilePath
94
95
96
unregScriptLocation = case buildOS of
                          Windows -> "unregister.bat"
                          _       -> "unregister.sh"
97

simonmar's avatar
simonmar committed
98
99
100
-- -----------------------------------------------------------------------------
-- Registration

ijones's avatar
ijones committed
101
register :: PackageDescription -> LocalBuildInfo
ijones's avatar
ijones committed
102
         -> RegisterFlags -- ^Install in the user's database?; verbose
ijones's avatar
ijones committed
103
         -> IO ()
104
register pkg_descr lbi regFlags
ijones's avatar
ijones committed
105
  | isNothing (library pkg_descr) = do
106
    setupMessage (fromFlag $ regVerbose regFlags) "No package to register" (packageId pkg_descr)
ijones's avatar
ijones committed
107
108
    return ()
  | otherwise = do
109
    let isWindows = case buildOS of Windows -> True; _ -> False
110
111
        genScript = fromFlag (regGenScript regFlags)
        genPkgConf = isJust (fromFlag (regGenPkgConf regFlags))
112
        genPkgConfigDefault = showPackageId (packageId pkg_descr) <.> "conf"
113
        genPkgConfigFile = fromMaybe genPkgConfigDefault
114
115
116
117
                                     (fromFlag (regGenPkgConf regFlags))
        verbosity = fromFlag (regVerbose regFlags)
        packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags)
	inplace  = fromFlag (regInPlace regFlags)
118
119
120
121
122
        message | genPkgConf = "Writing package registration file: "
                            ++ genPkgConfigFile ++ " for"
                | genScript = "Writing registration script: "
                           ++ regScriptLocation ++ " for"
                | otherwise = "Registering"
123
    setupMessage verbosity message (packageId pkg_descr)
124

125
    case compilerFlavor (compiler lbi) of
ijones's avatar
ijones committed
126
      GHC -> do 
127
	config_flags <- case packageDB of
128
129
          GlobalPackageDB      -> return []
          UserPackageDB        -> return ["--user"]
130
          SpecificPackageDB db -> return ["--package-conf=" ++ db]
131

132
133
134
	let instConf | genPkgConf = genPkgConfigFile
                     | inplace    = inplacePkgConfigFile
		     | otherwise  = installedPkgConfigFile
135

136
        when (genPkgConf || not genScript) $ do
137
          info verbosity ("create " ++ instConf)
138
          writeInstalledConfig pkg_descr lbi inplace (Just instConf)
139

140
        let register_flags   = let conf = if genScript && not isWindows
Duncan Coutts's avatar
Duncan Coutts committed
141
142
		                             then ["-"]
		                             else [instConf]
143
144
                                in "update" : conf

Duncan Coutts's avatar
Duncan Coutts committed
145
        let allFlags = config_flags ++ register_flags
146
        let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi)
147

148
149
150
151
        case () of
          _ | genPkgConf -> return ()
            | genScript ->
              do cfg <- showInstalledConfig pkg_descr lbi inplace
152
153
                 rawSystemPipe pkgTool regScriptLocation cfg allFlags
          _ -> rawSystemProgram verbosity pkgTool allFlags
154

ijones's avatar
ijones committed
155
      Hugs -> do
156
	when inplace $ die "--inplace is not supported with Hugs"
157
158
        let installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
	createDirectoryIfMissingVerbose verbosity True (libdir installDirs)
159
	copyFileVerbose verbosity installedPkgConfigFile
160
	    (libdir installDirs </> "package.conf")
161
162
163
      JHC -> notice verbosity "registering for JHC (nothing to do)"
      NHC -> notice verbosity "registering nhc98 (nothing to do)"
      _   -> die "only registering with GHC/Hugs/jhc/nhc98 is implemented"
simonmar's avatar
simonmar committed
164

165
166
167
168
169
-- -----------------------------------------------------------------------------
-- The installed package config

-- |Register doesn't drop the register info file, it must be done in a
-- separate step.
170
171
172
writeInstalledConfig :: PackageDescription -> LocalBuildInfo -> Bool
                     -> Maybe FilePath -> IO ()
writeInstalledConfig pkg_descr lbi inplace instConfOverride = do
173
  pkg_config <- showInstalledConfig pkg_descr lbi inplace
174
175
176
  let instConfDefault | inplace   = inplacePkgConfigFile
                      | otherwise = installedPkgConfigFile
      instConf = fromMaybe instConfDefault instConfOverride
177
  writeFile instConf (pkg_config ++ "\n")
178

179
-- |Create a string suitable for writing out to the package config file
180
181
182
183
184
showInstalledConfig :: PackageDescription -> LocalBuildInfo -> Bool
  -> IO String
showInstalledConfig pkg_descr lbi inplace
    = do cfg <- mkInstalledPackageInfo pkg_descr lbi inplace
         return (showInstalledPackageInfo cfg)
185

186
removeInstalledConfig :: IO ()
187
removeInstalledConfig = do
188
189
190
191
192
193
194
195
196
  try $ removeFile installedPkgConfigFile
  try $ removeFile inplacePkgConfigFile
  return ()

removeRegScripts :: IO ()
removeRegScripts = do
  try $ removeFile regScriptLocation
  try $ removeFile unregScriptLocation
  return ()
197

Ross Paterson's avatar
Ross Paterson committed
198
199
installedPkgConfigFile :: FilePath
installedPkgConfigFile = distPref </> "installed-pkg-config"
simonmar's avatar
simonmar committed
200

Ross Paterson's avatar
Ross Paterson committed
201
202
inplacePkgConfigFile :: FilePath
inplacePkgConfigFile = distPref </> "inplace-pkg-config"
203

204
205
206
207
208
209
-- -----------------------------------------------------------------------------
-- Making the InstalledPackageInfo

mkInstalledPackageInfo
	:: PackageDescription
	-> LocalBuildInfo
210
211
212
213
214
	-> Bool
	-> IO InstalledPackageInfo
mkInstalledPackageInfo pkg_descr lbi inplace = do 
  pwd <- getCurrentDirectory
  let 
215
	lib = fromJust (library pkg_descr) -- checked for Nothing earlier
216
        bi = libBuildInfo lib
217
	build_dir = pwd </> buildDir lbi
218
        installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
219
220
221
222
223
224
225
226
227
	inplaceDirs = (absoluteInstallDirs pkg_descr lbi NoCopyDest) {
                        datadir    = pwd,
                        datasubdir = distPref,
                        docdir     = inplaceDocdir,
                        htmldir    = inplaceHtmldir,
                        haddockdir = inplaceHtmldir
                      }
	  where inplaceDocdir  = pwd </> distPref </> "doc"
	        inplaceHtmldir = inplaceDocdir </> "html"
228
		                               </> packageName pkg_descr
229
230
231
232
        (absinc,relinc) = partition isAbsolute (includeDirs bi)
        installIncludeDir | null (installIncludes bi) = []
                          | otherwise = [includedir installDirs]
        haddockInterfaceDir
233
234
235
236
237
         | inplace   = haddockdir inplaceDirs
         | otherwise = haddockdir installDirs
        haddockHtmlDir
         | inplace   = htmldir inplaceDirs
         | otherwise = htmldir installDirs
238
239
240
        libraryDir
         | inplace   = build_dir
         | otherwise = libdir installDirs
241
    in
242
    return emptyInstalledPackageInfo{
243
        IPI.package           = packageId pkg_descr,
244
245
246
247
248
249
250
251
252
253
254
        IPI.license           = license pkg_descr,
        IPI.copyright         = copyright pkg_descr,
        IPI.maintainer        = maintainer pkg_descr,
	IPI.author	      = author pkg_descr,
        IPI.stability         = stability pkg_descr,
	IPI.homepage	      = homepage pkg_descr,
	IPI.pkgUrl	      = pkgUrl pkg_descr,
	IPI.description	      = description pkg_descr,
	IPI.category	      = category pkg_descr,
        IPI.exposed           = True,
	IPI.exposedModules    = exposedModules lib,
ijones's avatar
ijones committed
255
	IPI.hiddenModules     = otherModules bi,
256
257
        IPI.importDirs        = [libraryDir],
        IPI.libraryDirs       = libraryDir : extraLibDirs bi,
258
        IPI.hsLibraries       = ["HS" ++ showPackageId (packageId pkg_descr)],
259
        IPI.extraLibraries    = extraLibs bi,
260
261
        IPI.includeDirs       = absinc ++ if inplace
                                            then map (pwd </>) relinc
262
                                            else installIncludeDir,
263
        IPI.includes	      = includes bi,
264
        IPI.depends           = packageDeps lbi,
ijones's avatar
ijones committed
265
266
267
        IPI.hugsOptions       = concat [opts | (Hugs,opts) <- options bi],
        IPI.ccOptions         = ccOptions bi,
        IPI.ldOptions         = ldOptions bi,
268
        IPI.frameworkDirs     = [],
ijones's avatar
ijones committed
269
        IPI.frameworks        = frameworks bi,
270
	IPI.haddockInterfaces = [haddockInterfaceDir </> haddockName pkg_descr],
271
	IPI.haddockHTMLs      = [haddockHtmlDir]
272
        }
273

simonmar's avatar
simonmar committed
274
275
-- -----------------------------------------------------------------------------
-- Unregistration
276

ijones's avatar
ijones committed
277
unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
278
unregister pkg_descr lbi regFlags = do
279
  let genScript = fromFlag (regGenScript regFlags)
280
281
      verbosity = fromFlag (regVerbose regFlags)
      packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags)
282
      installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
283
  setupMessage verbosity "Unregistering" (packageId pkg_descr)
284
  case compilerFlavor (compiler lbi) of
285
    GHC -> do
286
	config_flags <- case packageDB of
287
288
          GlobalPackageDB      -> return []
          UserPackageDB        -> return ["--user"]
289
          SpecificPackageDB db -> return ["--package-conf=" ++ db]
290

291
        let removeCmd = ["unregister",showPackageId (packageId pkg_descr)]
292
293
294
295
296
        let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi)
            allArgs      = removeCmd ++ config_flags
	if genScript
          then rawSystemEmit pkgTool unregScriptLocation allArgs
          else rawSystemProgram verbosity pkgTool allArgs
ijones's avatar
ijones committed
297
    Hugs -> do
298
        try $ removeDirectoryRecursive (libdir installDirs)
299
300
	return ()
    NHC -> do
301
        try $ removeDirectoryRecursive (libdir installDirs)
ijones's avatar
ijones committed
302
303
304
	return ()
    _ ->
	die ("only unregistering with GHC and Hugs is implemented")
ijones's avatar
ijones committed
305

306
307
308
309
-- |Like rawSystemProgram, but emits to a script instead of exiting.
-- FIX: chmod +x?
rawSystemEmit :: ConfiguredProgram  -- ^Program to run
              -> FilePath  -- ^Script name
310
              -> [String]  -- ^Args
311
              -> IO ()
312
rawSystemEmit prog scriptName extraArgs
313
314
 = case buildOS of
       Windows ->
315
316
           writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
       _ -> do writeFile scriptName ("#!/bin/sh\n\n"
317
318
319
320
                                  ++ (path ++ concatMap (' ':) args)
                                  ++ "\n")
               p <- getPermissions scriptName
               setPermissions scriptName p{executable=True}
321
322
  where args = programArgs prog ++ extraArgs
        path = programPath prog
323

324
-- |Like rawSystemEmit, except it has string for pipeFrom. FIX: chmod +x
325
326
rawSystemPipe :: ConfiguredProgram
              -> FilePath  -- ^Script location
327
328
              -> String    -- ^where to pipe from
              -> [String]  -- ^Args
329
              -> IO ()
330
rawSystemPipe prog scriptName pipeFrom extraArgs
331
332
 = case buildOS of
       Windows ->
333
334
           writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
       _ -> do writeFile scriptName ("#!/bin/sh\n\n"
335
336
337
338
339
340
                                  ++ "echo '" ++ escapeForShell pipeFrom
                                  ++ "' | "
                                  ++ (path ++ concatMap (' ':) args)
                                  ++ "\n")
               p <- getPermissions scriptName
               setPermissions scriptName p{executable=True}
341
  where escapeForShell [] = []
342
343
        escapeForShell ('\'':cs) = "'\\''" ++ escapeForShell cs
        escapeForShell (c   :cs) = c        : escapeForShell cs
344
345
        args = programArgs prog ++ extraArgs
        path = programPath prog