Register.hs 14.5 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
import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..),
57
                                     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
import Distribution.Package (PackageIdentifier(..), showPackageId, Package(..))
66
import Distribution.Verbosity
67
68
69
70
import Distribution.InstalledPackageInfo
	(InstalledPackageInfo, showInstalledPackageInfo, 
	 emptyInstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as IPI
71
72
73
import Distribution.Simple.Utils
         ( createDirectoryIfMissingVerbose, copyFileVerbose, writeFileAtomic
         , die, info, setupMessage )
74
import Distribution.System
75

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

290
        let removeCmd = ["unregister",showPackageId (packageId pkg_descr)]
291
292
293
294
295
        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
296
    Hugs -> do
297
        try $ removeDirectoryRecursive (libdir installDirs)
298
299
	return ()
    NHC -> do
300
        try $ removeDirectoryRecursive (libdir installDirs)
ijones's avatar
ijones committed
301
302
303
	return ()
    _ ->
	die ("only unregistering with GHC and Hugs is implemented")
ijones's avatar
ijones committed
304

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

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