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
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
import Distribution.Package
66
         ( Package(..), packageName )
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 Distribution.Text
         ( display )
78

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

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

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

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

simonmar's avatar
simonmar committed
100
101
102
-- -----------------------------------------------------------------------------
-- Registration

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

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

134
135
136
	let instConf | genPkgConf = genPkgConfigFile
                     | inplace    = inplacePkgConfigFile
		     | otherwise  = installedPkgConfigFile
137

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

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

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

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

ijones's avatar
ijones committed
157
      Hugs -> do
158
	when inplace $ die "--inplace is not supported with Hugs"
159
160
        let installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
	createDirectoryIfMissingVerbose verbosity True (libdir installDirs)
161
	copyFileVerbose verbosity installedPkgConfigFile
162
	    (libdir installDirs </> "package.conf")
163
164
165
      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
166

167
168
169
170
171
-- -----------------------------------------------------------------------------
-- The installed package config

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

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

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

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

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

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

206
207
208
209
210
211
-- -----------------------------------------------------------------------------
-- Making the InstalledPackageInfo

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

simonmar's avatar
simonmar committed
276
277
-- -----------------------------------------------------------------------------
-- Unregistration
278

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

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

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

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