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
import Distribution.Simple.Utils (createDirectoryIfMissingVerbose,
72
                                  copyFileVerbose, die, info, setupMessage)
73
import Distribution.System
74

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

304
305
306
307
-- |Like rawSystemProgram, but emits to a script instead of exiting.
-- FIX: chmod +x?
rawSystemEmit :: ConfiguredProgram  -- ^Program to run
              -> FilePath  -- ^Script name
308
              -> [String]  -- ^Args
309
              -> IO ()
310
rawSystemEmit prog scriptName extraArgs
311
312
313
314
315
316
317
318
 = 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}
319
320
  where args = programArgs prog ++ extraArgs
        path = programPath prog
321

322
-- |Like rawSystemEmit, except it has string for pipeFrom. FIX: chmod +x
323
324
rawSystemPipe :: ConfiguredProgram
              -> FilePath  -- ^Script location
325
326
              -> String    -- ^where to pipe from
              -> [String]  -- ^Args
327
              -> IO ()
328
rawSystemPipe prog scriptName pipeFrom extraArgs
329
330
331
332
333
334
335
336
337
338
 = 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}
339
  where escapeForShell [] = []
340
341
        escapeForShell ('\'':cs) = "'\\''" ++ escapeForShell cs
        escapeForShell (c   :cs) = c        : escapeForShell cs
342
343
        args = programArgs prog ++ extraArgs
        path = programPath prog