Register.hs 14.8 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 (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, writeFileAtomic
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
112
    let distPref = fromFlag $ regDistPref regFlags
        isWindows = case buildOS of Windows -> True; _ -> False
113
114
        genScript = fromFlag (regGenScript regFlags)
        genPkgConf = isJust (fromFlag (regGenPkgConf regFlags))
115
        genPkgConfigDefault = display (packageId pkg_descr) <.> "conf"
116
        genPkgConfigFile = fromMaybe genPkgConfigDefault
117
                                     (fromFlag (regGenPkgConf regFlags))
118
        verbosity = fromFlag (regVerbosity regFlags)
119
120
        packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags)
	inplace  = fromFlag (regInPlace regFlags)
121
122
123
124
125
        message | genPkgConf = "Writing package registration file: "
                            ++ genPkgConfigFile ++ " for"
                | genScript = "Writing registration script: "
                           ++ regScriptLocation ++ " for"
                | otherwise = "Registering"
126
    setupMessage verbosity message (packageId pkg_descr)
127

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

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

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

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

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

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

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

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

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

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

189
190
191
192
removeInstalledConfig :: FilePath -> IO ()
removeInstalledConfig distPref = do
  try $ removeFile $ installedPkgConfigFile distPref
  try $ removeFile $ inplacePkgConfigFile distPref
193
194
195
196
197
198
199
  return ()

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

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

204
205
inplacePkgConfigFile :: FilePath -> FilePath
inplacePkgConfigFile distPref = distPref </> "inplace-pkg-config"
206

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

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

simonmar's avatar
simonmar committed
278
279
-- -----------------------------------------------------------------------------
-- Unregistration
280

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

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

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

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