Register.hs 14.8 KB
Newer Older
1
{-# OPTIONS -cpp #-}
2
3
-----------------------------------------------------------------------------
-- |
ijones's avatar
ijones committed
4
-- Module      :  Distribution.Simple.Register
5
6
7
8
-- Copyright   :  Isaac Jones 2003-2004
-- 
-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>
-- Stability   :  alpha
ijones's avatar
ijones committed
9
-- Portability :  portable
10
--
ijones's avatar
ijones committed
11
12
-- Explanation: Perform the \"@.\/setup register@\" action.
-- Uses a drop-file for HC-PKG.  See also "Distribution.InstalledPackageInfo".
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
44

{- 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. -}

45
46
47
module Distribution.Simple.Register (
	register,
	unregister,
48
        writeInstalledConfig,
49
	removeInstalledConfig,
50
        removeRegScripts,
ijones's avatar
ijones committed
51
#ifdef DEBUG
52
        hunitTests, installedPkgConfigFile
ijones's avatar
ijones committed
53
#endif
54
  ) where
55

ijones's avatar
ijones committed
56
#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 604
ijones's avatar
ijones committed
57
58
59
60
61
62
63
#if __GLASGOW_HASKELL__ < 603
#include "config.h"
#else
#include "ghcconfig.h"
#endif
#endif

64
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), distPref,
65
                                           InstallDirs(..),
66
					   absoluteInstallDirs)
67
import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..),
68
                                     PackageDB(..))
69
70
71
import Distribution.Simple.Program (ConfiguredProgram, programPath,
                                    programArgs, rawSystemProgram,
                                    lookupProgram, ghcPkgProgram)
72
73
import Distribution.Simple.Setup (RegisterFlags(..), CopyDest(..),
                                  fromFlag, fromFlagOrDefault)
74
import Distribution.PackageDescription (setupMessage, PackageDescription(..),
75
					BuildInfo(..), Library(..), haddockName)
76
import Distribution.Package (PackageIdentifier(..), showPackageId)
77
import Distribution.Verbosity
78
79
80
81
import Distribution.InstalledPackageInfo
	(InstalledPackageInfo, showInstalledPackageInfo, 
	 emptyInstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as IPI
82
import Distribution.Simple.Utils (createDirectoryIfMissingVerbose,
83
                                  copyFileVerbose, die, info)
84
import Distribution.System
85

86
import System.FilePath ((</>), (<.>), isAbsolute)
87
88
89
90
import System.Directory (removeFile, getCurrentDirectory,
                         removeDirectoryRecursive,
                         setPermissions, getPermissions,
			 Permissions(executable))
91
import System.IO.Error (try)
ijones's avatar
ijones committed
92

93
import Control.Monad (when)
94
import Data.Maybe (isNothing, isJust, fromJust, fromMaybe)
95
import Data.List (partition)
simonmar's avatar
simonmar committed
96

ijones's avatar
ijones committed
97
#ifdef DEBUG
98
import Test.HUnit (Test)
ijones's avatar
ijones committed
99
100
#endif

101
regScriptLocation :: FilePath
102
103
104
regScriptLocation = case os of
                        Windows _ -> "register.bat"
                        _         -> "register.sh"
105
106

unregScriptLocation :: FilePath
107
108
109
unregScriptLocation = case os of
                          Windows _ -> "unregister.bat"
                          _         -> "unregister.sh"
110

simonmar's avatar
simonmar committed
111
112
113
-- -----------------------------------------------------------------------------
-- Registration

ijones's avatar
ijones committed
114
register :: PackageDescription -> LocalBuildInfo
ijones's avatar
ijones committed
115
         -> RegisterFlags -- ^Install in the user's database?; verbose
ijones's avatar
ijones committed
116
         -> IO ()
117
register pkg_descr lbi regFlags
ijones's avatar
ijones committed
118
  | isNothing (library pkg_descr) = do
119
    setupMessage (fromFlag $ regVerbose regFlags) "No package to register" pkg_descr
ijones's avatar
ijones committed
120
121
    return ()
  | otherwise = do
122
    let isWindows = case os of Windows _ -> True; _ -> False
123
124
        genScript = fromFlag (regGenScript regFlags)
        genPkgConf = isJust (fromFlag (regGenPkgConf regFlags))
125
126
        genPkgConfigDefault = showPackageId (package pkg_descr) <.> "conf"
        genPkgConfigFile = fromMaybe genPkgConfigDefault
127
128
129
130
                                     (fromFlag (regGenPkgConf regFlags))
        verbosity = fromFlag (regVerbose regFlags)
        packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags)
	inplace  = fromFlag (regInPlace regFlags)
131
132
133
134
135
        message | genPkgConf = "Writing package registration file: "
                            ++ genPkgConfigFile ++ " for"
                | genScript = "Writing registration script: "
                           ++ regScriptLocation ++ " for"
                | otherwise = "Registering"
136
    setupMessage verbosity message pkg_descr
137

138
    case compilerFlavor (compiler lbi) of
ijones's avatar
ijones committed
139
      GHC -> do 
140
	config_flags <- case packageDB of
141
142
143
          GlobalPackageDB      -> return []
          UserPackageDB        -> return ["--user"]
          SpecificPackageDB db -> return ["-package-conf", db]
144

145
146
147
	let instConf | genPkgConf = genPkgConfigFile
                     | inplace    = inplacePkgConfigFile
		     | otherwise  = installedPkgConfigFile
148

149
        when (genPkgConf || not genScript) $ do
150
          info verbosity ("create " ++ instConf)
151
          writeInstalledConfig pkg_descr lbi inplace (Just instConf)
152

153
        let register_flags   = let conf = if genScript && not isWindows
Duncan Coutts's avatar
Duncan Coutts committed
154
155
		                             then ["-"]
		                             else [instConf]
156
157
                                in "update" : conf

Duncan Coutts's avatar
Duncan Coutts committed
158
        let allFlags = config_flags ++ register_flags
159
        let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi)
160

161
162
163
164
        case () of
          _ | genPkgConf -> return ()
            | genScript ->
              do cfg <- showInstalledConfig pkg_descr lbi inplace
165
166
                 rawSystemPipe pkgTool regScriptLocation cfg allFlags
          _ -> rawSystemProgram verbosity pkgTool allFlags
167

ijones's avatar
ijones committed
168
      Hugs -> do
169
	when inplace $ die "--inplace is not supported with Hugs"
170
171
        let installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
	createDirectoryIfMissingVerbose verbosity True (libdir installDirs)
172
	copyFileVerbose verbosity installedPkgConfigFile
173
	    (libdir installDirs </> "package.conf")
174
175
      JHC -> when (verbosity >= normal) $ putStrLn "registering for JHC (nothing to do)"
      NHC -> when (verbosity >= normal) $ putStrLn "registering nhc98 (nothing to do)"
176
      _   -> die ("only registering with GHC/Hugs/jhc/nhc98 is implemented")
simonmar's avatar
simonmar committed
177

178
179
180
181
182
-- -----------------------------------------------------------------------------
-- The installed package config

-- |Register doesn't drop the register info file, it must be done in a
-- separate step.
183
184
185
writeInstalledConfig :: PackageDescription -> LocalBuildInfo -> Bool
                     -> Maybe FilePath -> IO ()
writeInstalledConfig pkg_descr lbi inplace instConfOverride = do
186
  pkg_config <- showInstalledConfig pkg_descr lbi inplace
187
188
189
190
  let instConfDefault | inplace   = inplacePkgConfigFile
                      | otherwise = installedPkgConfigFile
      instConf = fromMaybe instConfDefault instConfOverride
  writeFile instConf (pkg_config ++ "\n")
191

192
-- |Create a string suitable for writing out to the package config file
193
194
195
196
197
showInstalledConfig :: PackageDescription -> LocalBuildInfo -> Bool
  -> IO String
showInstalledConfig pkg_descr lbi inplace
    = do cfg <- mkInstalledPackageInfo pkg_descr lbi inplace
         return (showInstalledPackageInfo cfg)
198

199
removeInstalledConfig :: IO ()
200
removeInstalledConfig = do
201
202
203
204
205
206
207
208
209
  try $ removeFile installedPkgConfigFile
  try $ removeFile inplacePkgConfigFile
  return ()

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

Ross Paterson's avatar
Ross Paterson committed
211
212
installedPkgConfigFile :: FilePath
installedPkgConfigFile = distPref </> "installed-pkg-config"
simonmar's avatar
simonmar committed
213

Ross Paterson's avatar
Ross Paterson committed
214
215
inplacePkgConfigFile :: FilePath
inplacePkgConfigFile = distPref </> "inplace-pkg-config"
216

217
218
219
220
221
222
-- -----------------------------------------------------------------------------
-- Making the InstalledPackageInfo

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

simonmar's avatar
simonmar committed
287
288
-- -----------------------------------------------------------------------------
-- Unregistration
289

ijones's avatar
ijones committed
290
unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
291
unregister pkg_descr lbi regFlags = do
292
  let genScript = fromFlag (regGenScript regFlags)
293
294
      verbosity = fromFlag (regVerbose regFlags)
      packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags)
295
      installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
296
  setupMessage verbosity "Unregistering" pkg_descr
297
  case compilerFlavor (compiler lbi) of
298
    GHC -> do
299
	config_flags <- case packageDB of
300
301
302
303
304
          GlobalPackageDB      -> return []
          UserPackageDB        -> return ["--user"]
          SpecificPackageDB db -> return ["-package-conf", db]

        let removeCmd = ["unregister",showPackageId (package pkg_descr)]
305
306
307
308
309
        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
310
    Hugs -> do
311
        try $ removeDirectoryRecursive (libdir installDirs)
312
313
	return ()
    NHC -> do
314
        try $ removeDirectoryRecursive (libdir installDirs)
ijones's avatar
ijones committed
315
316
317
	return ()
    _ ->
	die ("only unregistering with GHC and Hugs is implemented")
ijones's avatar
ijones committed
318

319
320
321
322
-- |Like rawSystemProgram, but emits to a script instead of exiting.
-- FIX: chmod +x?
rawSystemEmit :: ConfiguredProgram  -- ^Program to run
              -> FilePath  -- ^Script name
323
              -> [String]  -- ^Args
324
              -> IO ()
325
rawSystemEmit prog scriptName extraArgs
326
327
328
329
330
331
332
333
 = case os of
       Windows _ ->
           writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
       _ -> do writeFile scriptName ("#!/bin/sh\n\n"
                                  ++ (path ++ concatMap (' ':) args)
                                  ++ "\n")
               p <- getPermissions scriptName
               setPermissions scriptName p{executable=True}
334
335
  where args = programArgs prog ++ extraArgs
        path = programPath prog
336

337
-- |Like rawSystemEmit, except it has string for pipeFrom. FIX: chmod +x
338
339
rawSystemPipe :: ConfiguredProgram
              -> FilePath  -- ^Script location
340
341
              -> String    -- ^where to pipe from
              -> [String]  -- ^Args
342
              -> IO ()
343
rawSystemPipe prog scriptName pipeFrom extraArgs
344
345
346
347
348
349
350
351
352
353
 = case os of
       Windows _ ->
           writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
       _ -> do writeFile scriptName ("#!/bin/sh\n\n"
                                  ++ "echo '" ++ escapeForShell pipeFrom
                                  ++ "' | "
                                  ++ (path ++ concatMap (' ':) args)
                                  ++ "\n")
               p <- getPermissions scriptName
               setPermissions scriptName p{executable=True}
354
  where escapeForShell [] = []
355
356
        escapeForShell ('\'':cs) = "'\\''" ++ escapeForShell cs
        escapeForShell (c   :cs) = c        : escapeForShell cs
357
358
        args = programArgs prog ++ extraArgs
        path = programPath prog
359

ijones's avatar
ijones committed
360
361
362
363
364
365
366
367
-- ------------------------------------------------------------
-- * Testing
-- ------------------------------------------------------------

#ifdef DEBUG
hunitTests :: [Test]
hunitTests = []
#endif