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(..), distPref,
53
                                           InstallDirs(..),
54
					   absoluteInstallDirs)
55
import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..),
56
                                     PackageDB(..))
57
58
59
import Distribution.Simple.Program (ConfiguredProgram, programPath,
                                    programArgs, rawSystemProgram,
                                    lookupProgram, ghcPkgProgram)
60
61
import Distribution.Simple.Setup (RegisterFlags(..), CopyDest(..),
                                  fromFlag, fromFlagOrDefault)
62
import Distribution.PackageDescription (setupMessage, PackageDescription(..),
63
					BuildInfo(..), Library(..), haddockName)
64
import Distribution.Package (PackageIdentifier(..), showPackageId)
65
import Distribution.Verbosity
66
67
68
69
import Distribution.InstalledPackageInfo
	(InstalledPackageInfo, showInstalledPackageInfo, 
	 emptyInstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as IPI
70
import Distribution.Simple.Utils (createDirectoryIfMissingVerbose,
71
                                  copyFileVerbose, die, info)
72
import Distribution.System
73

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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