Register.hs 23.5 KB
Newer Older
1 2 3
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

4 5
-----------------------------------------------------------------------------
-- |
ijones's avatar
ijones committed
6
-- Module      :  Distribution.Simple.Register
7
-- Copyright   :  Isaac Jones 2003-2004
8
-- License     :  BSD3
9
--
Duncan Coutts's avatar
Duncan Coutts committed
10
-- Maintainer  :  cabal-devel@haskell.org
ijones's avatar
ijones committed
11
-- Portability :  portable
12
--
Duncan Coutts's avatar
Duncan Coutts committed
13 14 15 16 17 18 19 20
-- This module deals with registering and unregistering packages. There are a
-- couple ways it can do this, one is to do it directly. Another is to generate
-- a script that can be run later to do it. The idea here being that the user
-- is shielded from the details of what command to use for package registration
-- for a particular compiler. In practice this aspect was not especially
-- popular so we also provide a way to simply generate the package registration
-- file which then must be manually passed to @ghc-pkg@. It is possible to
-- generate registration information for where the package is to be installed,
Ian D. Bollinger's avatar
Ian D. Bollinger committed
21
-- or alternatively to register the package in place in the build tree. The
Duncan Coutts's avatar
Duncan Coutts committed
22 23 24 25 26 27
-- latter is occasionally handy, and will become more important when we try to
-- build multi-package systems.
--
-- This module does not delegate anything to the per-compiler modules but just
-- mixes it all in in this module, which is rather unsatisfactory. The script
-- generation and the unregister feature are not well used or tested.
28

29
module Distribution.Simple.Register (
Duncan Coutts's avatar
Duncan Coutts committed
30 31 32
    register,
    unregister,

33 34
    internalPackageDBPath,

35
    initPackageDB,
36 37 38 39
    doesPackageDBExist,
    createPackageDB,
    deletePackageDB,

refold's avatar
refold committed
40
    invokeHcPkg,
Duncan Coutts's avatar
Duncan Coutts committed
41
    registerPackage,
42
    generateRegistrationInfo,
Duncan Coutts's avatar
Duncan Coutts committed
43 44 45
    inplaceInstalledPackageInfo,
    absoluteInstalledPackageInfo,
    generalInstalledPackageInfo,
46
  ) where
47

48 49 50
import Prelude ()
import Distribution.Compat.Prelude

51 52
import Distribution.Types.TargetInfo
import Distribution.Types.LocalBuildInfo
53
import Distribution.Types.ComponentLocalBuildInfo
54

55
import Distribution.Simple.LocalBuildInfo
56
import Distribution.Simple.BuildPaths
57
import Distribution.Simple.BuildTarget
58 59 60 61 62

import qualified Distribution.Simple.GHC   as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
import qualified Distribution.Simple.LHC   as LHC
import qualified Distribution.Simple.UHC   as UHC
63
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
64
import qualified Distribution.Simple.PackageIndex as Index
65

66
import Distribution.Simple.Compiler
Duncan Coutts's avatar
Duncan Coutts committed
67 68 69
import Distribution.Simple.Program
import Distribution.Simple.Program.Script
import qualified Distribution.Simple.Program.HcPkg as HcPkg
70
import Distribution.Simple.Setup
Duncan Coutts's avatar
Duncan Coutts committed
71
import Distribution.PackageDescription
72
import Distribution.Package
73
import qualified Distribution.InstalledPackageInfo as IPI
74
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
75
import Distribution.Simple.Utils
76
import Distribution.Utils.MapAccum
77
import Distribution.System
78
import Distribution.Text
Duncan Coutts's avatar
Duncan Coutts committed
79
import Distribution.Verbosity as Verbosity
80
import Distribution.Version
81
import Distribution.Compat.Graph (IsNode(nodeKey))
82

83
import System.FilePath ((</>), (<.>), isAbsolute)
Duncan Coutts's avatar
Duncan Coutts committed
84
import System.Directory
ijones's avatar
ijones committed
85

86
import Data.List (partition)
87
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
88

simonmar's avatar
simonmar committed
89 90 91
-- -----------------------------------------------------------------------------
-- Registration

ijones's avatar
ijones committed
92
register :: PackageDescription -> LocalBuildInfo
ijones's avatar
ijones committed
93
         -> RegisterFlags -- ^Install in the user's database?; verbose
ijones's avatar
ijones committed
94
         -> IO ()
95
register pkg_descr lbi0 flags =
96 97 98 99 100
   -- Duncan originally asked for us to not register/install files
   -- when there was no public library.  But with per-component
   -- configure, we legitimately need to install internal libraries
   -- so that we can get them.  So just unconditionally install.
   doRegister
101 102
 where
  doRegister = do
103
    targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags)
104 105 106

    -- It's important to register in build order, because ghc-pkg
    -- will complain if a dependency is not registered.
107 108 109 110 111 112 113 114 115 116 117 118 119 120
    let componentsToRegister
            = neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets)

    (_, ipi_mbs) <-
        mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt ->
            case targetComponent tgt of
                CLib lib -> do
                    let clbi = targetCLBI tgt
                        lbi = lbi0 { installedPkgs = index }
                    ipi <- generateOne pkg_descr lib lbi clbi flags
                    return (Index.insert ipi index, Just ipi)
                _   -> return (index, Nothing)

    registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs)
121 122
   where
    verbosity = fromFlag (regVerbosity flags)
123 124 125 126 127

generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo
            -> RegisterFlags
            -> IO InstalledPackageInfo
generateOne pkg lib lbi clbi regFlags
128
  = do
129
    absPackageDBs    <- absolutePackageDBPaths packageDbs
130
    installedPkgInfo <- generateRegistrationInfo
131
                           verbosity pkg lib lbi clbi inplace reloc distPref
132
                           (registrationPackageDB absPackageDBs)
133
    info verbosity (IPI.showInstalledPackageInfo installedPkgInfo)
134 135 136 137 138 139 140 141 142 143 144
    return installedPkgInfo
  where
    inplace   = fromFlag (regInPlace regFlags)
    reloc     = relocatable lbi
    -- FIXME: there's really no guarantee this will work.
    -- registering into a totally different db stack can
    -- fail if dependencies cannot be satisfied.
    packageDbs = nub $ withPackageDB lbi
                    ++ maybeToList (flagToMaybe  (regPackageDB regFlags))
    distPref  = fromFlag (regDistPref regFlags)
    verbosity = fromFlag (regVerbosity regFlags)
145

146 147 148 149 150
registerAll :: PackageDescription -> LocalBuildInfo -> RegisterFlags
            -> [InstalledPackageInfo]
            -> IO ()
registerAll pkg lbi regFlags ipis
  = do
151
    when (fromFlag (regPrintId regFlags)) $ do
152
      for_ ipis $ \installedPkgInfo ->
153 154 155
        -- Only print the public library's IPI
        when (IPI.sourcePackageId installedPkgInfo == packageId pkg) $
          putStrLn (display (IPI.installedUnitId installedPkgInfo))
156

157 158
     -- Three different modes:
    case () of
159 160
     _ | modeGenerateRegFile   -> writeRegistrationFileOrDirectory
       | modeGenerateRegScript -> writeRegisterScript
161 162
       | otherwise             -> do
           setupMessage verbosity "Registering" (packageId pkg)
163
           for_ ipis $ \installedPkgInfo ->
164 165
               registerPackage verbosity (compiler lbi) (withPrograms lbi)
                               HcPkg.NoMultiInstance packageDbs installedPkgInfo
Duncan Coutts's avatar
Duncan Coutts committed
166 167 168 169 170 171 172 173

  where
    modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))
    regFile             = fromMaybe (display (packageId pkg) <.> "conf")
                                    (fromFlag (regGenPkgConf regFlags))

    modeGenerateRegScript = fromFlag (regGenScript regFlags)

Duncan Coutts's avatar
Duncan Coutts committed
174 175 176 177 178
    -- FIXME: there's really no guarantee this will work.
    -- registering into a totally different db stack can
    -- fail if dependencies cannot be satisfied.
    packageDbs = nub $ withPackageDB lbi
                    ++ maybeToList (flagToMaybe  (regPackageDB regFlags))
Duncan Coutts's avatar
Duncan Coutts committed
179 180
    verbosity = fromFlag (regVerbosity regFlags)

181 182 183 184 185
    writeRegistrationFileOrDirectory = do
      -- Handles overwriting both directory and file
      deletePackageDB regFile
      case ipis of
        [installedPkgInfo] -> do
186
          info verbosity ("Creating package registration file: " ++ regFile)
187 188
          writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo)
        _ -> do
189
          info verbosity ("Creating package registration directory: " ++ regFile)
190 191 192 193 194
          createDirectory regFile
          let num_ipis = length ipis
              lpad m xs = replicate (m - length ys) '0' ++ ys
                  where ys = take m xs
              number i = lpad (length (show num_ipis)) (show i)
195
          for_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) ->
196 197 198 199
            writeUTF8File (regFile </> (number i ++ "-" ++ display (IPI.installedUnitId installedPkgInfo)))
                          (IPI.showInstalledPackageInfo installedPkgInfo)

    writeRegisterScript =
Duncan Coutts's avatar
Duncan Coutts committed
200
      case compilerFlavor (compiler lbi) of
201 202 203 204 205
        JHC -> notice verbosity "Registration scripts not needed for jhc"
        UHC -> notice verbosity "Registration scripts not needed for uhc"
        _   -> withHcPkg
               "Registration scripts are not implemented for this compiler"
               (compiler lbi) (withPrograms lbi)
206
               (writeHcPkgRegisterScript verbosity ipis packageDbs)
Duncan Coutts's avatar
Duncan Coutts committed
207 208


209 210
generateRegistrationInfo :: Verbosity
                         -> PackageDescription
Duncan Coutts's avatar
Duncan Coutts committed
211 212 213 214
                         -> Library
                         -> LocalBuildInfo
                         -> ComponentLocalBuildInfo
                         -> Bool
215
                         -> Bool
Duncan Coutts's avatar
Duncan Coutts committed
216
                         -> FilePath
217
                         -> PackageDB
Duncan Coutts's avatar
Duncan Coutts committed
218
                         -> IO InstalledPackageInfo
219
generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do
Duncan Coutts's avatar
Duncan Coutts committed
220 221
  --TODO: eliminate pwd!
  pwd <- getCurrentDirectory
222

223
  --TODO: the method of setting the UnitId is compiler specific
224
  --      this aspect should be delegated to a per-compiler helper.
225
  let comp = compiler lbi
226 227 228 229
      lbi' = lbi {
                withPackageDB = withPackageDB lbi
                    ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)]
             }
230
  abi_hash <-
231
    case compilerFlavor comp of
232
     GHC | compilerVersion comp >= mkVersion [6,11] -> do
233
            fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi
234
     GHCJS -> do
235 236
            fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi
     _ -> return (mkAbiHash "")
237

Christiaan Baaij's avatar
Christiaan Baaij committed
238 239 240
  installedPkgInfo <-
    if inplace
      then return (inplaceInstalledPackageInfo pwd distPref
241
                     pkg abi_hash lib lbi clbi)
Christiaan Baaij's avatar
Christiaan Baaij committed
242 243
    else if reloc
      then relocRegistrationInfo verbosity
244
                     pkg lib lbi clbi abi_hash packageDb
Christiaan Baaij's avatar
Christiaan Baaij committed
245
      else return (absoluteInstalledPackageInfo
246
                     pkg abi_hash lib lbi clbi)
247

248

249
  return installedPkgInfo{ IPI.abiHash = abi_hash }
250

251 252 253 254 255
relocRegistrationInfo :: Verbosity
                      -> PackageDescription
                      -> Library
                      -> LocalBuildInfo
                      -> ComponentLocalBuildInfo
256
                      -> AbiHash
257 258
                      -> PackageDB
                      -> IO InstalledPackageInfo
259
relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb =
260
  case (compilerFlavor (compiler lbi)) of
261 262
    GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb
              return (relocatableInstalledPackageInfo
263
                        pkg abi_hash lib lbi clbi fs)
264 265
    _   -> die "Distribution.Simple.Register.relocRegistrationInfo: \
               \not implemented for this compiler"
266

267
initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO ()
268
initPackageDB verbosity comp progdb dbPath =
269
    createPackageDB verbosity comp progdb False dbPath
270

271
-- | Create an empty package DB at the specified location.
272
createPackageDB :: Verbosity -> Compiler -> ProgramDb -> Bool
273 274 275 276 277 278 279 280 281 282 283
                -> FilePath -> IO ()
createPackageDB verbosity comp progdb preferCompat dbPath =
    case compilerFlavor comp of
      GHC   -> HcPkg.init (GHC.hcPkgInfo   progdb) verbosity preferCompat dbPath
      GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath
      LHC   -> HcPkg.init (LHC.hcPkgInfo   progdb) verbosity False dbPath
      UHC   -> return ()
      HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath
      _              -> die $ "Distribution.Simple.Register.createPackageDB: "
                           ++ "not implemented for this compiler"

284
doesPackageDBExist :: FilePath -> NoCallStackIO Bool
285 286 287 288 289 290 291
doesPackageDBExist dbPath = do
    -- currently one impl for all compiler flavours, but could change if needed
    dir_exists <- doesDirectoryExist dbPath
    if dir_exists
        then return True
        else doesFileExist dbPath

292
deletePackageDB :: FilePath -> NoCallStackIO ()
293 294 295 296 297 298 299
deletePackageDB dbPath = do
    -- currently one impl for all compiler flavours, but could change if needed
    dir_exists <- doesDirectoryExist dbPath
    if dir_exists
        then removeDirectoryRecursive dbPath
        else do file_exists <- doesFileExist dbPath
                when file_exists $ removeFile dbPath
refold's avatar
refold committed
300 301 302

-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
303
invokeHcPkg :: Verbosity -> Compiler -> ProgramDb -> PackageDBStack
refold's avatar
refold committed
304
                -> [String] -> IO ()
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
305 306
invokeHcPkg verbosity comp progdb dbStack extraArgs =
  withHcPkg "invokeHcPkg" comp progdb
307 308
    (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs)

309
withHcPkg :: String -> Compiler -> ProgramDb
310
          -> (HcPkg.HcPkgInfo -> IO a) -> IO a
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
311
withHcPkg name comp progdb f =
312
  case compilerFlavor comp of
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
313 314 315
    GHC   -> f (GHC.hcPkgInfo progdb)
    GHCJS -> f (GHCJS.hcPkgInfo progdb)
    LHC   -> f (LHC.hcPkgInfo progdb)
316 317
    _     -> die ("Distribution.Simple.Register." ++ name ++ ":\
                  \not implemented for this compiler")
318

Duncan Coutts's avatar
Duncan Coutts committed
319
registerPackage :: Verbosity
320
                -> Compiler
321
                -> ProgramDb
322
                -> HcPkg.MultiInstance
323
                -> PackageDBStack
324
                -> InstalledPackageInfo
Duncan Coutts's avatar
Duncan Coutts committed
325
                -> IO ()
326
registerPackage verbosity comp progdb multiInstance packageDbs installedPkgInfo =
327
  case compilerFlavor comp of
328 329
    GHC   -> GHC.registerPackage   verbosity progdb multiInstance packageDbs installedPkgInfo
    GHCJS -> GHCJS.registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo
330
    _ | HcPkg.MultiInstance == multiInstance
331
          -> die "Registering multiple package instances is not yet supported for this compiler"
332 333
    LHC   -> LHC.registerPackage   verbosity      progdb packageDbs installedPkgInfo
    UHC   -> UHC.registerPackage   verbosity comp progdb packageDbs installedPkgInfo
334
    JHC   -> notice verbosity "Registering for jhc (nothing to do)"
335
    HaskellSuite {} ->
336
      HaskellSuite.registerPackage verbosity      progdb packageDbs installedPkgInfo
Duncan Coutts's avatar
Duncan Coutts committed
337 338 339
    _    -> die "Registering is not implemented for this compiler"

writeHcPkgRegisterScript :: Verbosity
340
                         -> [InstalledPackageInfo]
341
                         -> PackageDBStack
342
                         -> HcPkg.HcPkgInfo
Duncan Coutts's avatar
Duncan Coutts committed
343
                         -> IO ()
344 345 346 347 348 349 350 351
writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do
  let genScript installedPkgInfo =
          let invocation  = HcPkg.reregisterInvocation hpi Verbosity.normal
                              packageDbs (Right installedPkgInfo)
          in invocationAsSystemScript buildOS invocation
      scripts = map genScript ipis
      -- TODO: Do something more robust here
      regScript = unlines scripts
Duncan Coutts's avatar
Duncan Coutts committed
352

353
  info verbosity ("Creating package registration script: " ++ regScriptFileName)
354
  writeUTF8File regScriptFileName regScript
Duncan Coutts's avatar
Duncan Coutts committed
355 356 357 358 359 360
  setFileExecutable regScriptFileName

regScriptFileName :: FilePath
regScriptFileName = case buildOS of
                        Windows -> "register.bat"
                        _       -> "register.sh"
simonmar's avatar
simonmar committed
361

362

363 364 365
-- -----------------------------------------------------------------------------
-- Making the InstalledPackageInfo

Duncan Coutts's avatar
Duncan Coutts committed
366 367 368 369 370 371 372
-- | Construct 'InstalledPackageInfo' for a library in a package, given a set
-- of installation directories.
--
generalInstalledPackageInfo
  :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to
                                -- absolute paths.
  -> PackageDescription
373
  -> AbiHash
Duncan Coutts's avatar
Duncan Coutts committed
374
  -> Library
375
  -> LocalBuildInfo
Duncan Coutts's avatar
Duncan Coutts committed
376 377 378
  -> ComponentLocalBuildInfo
  -> InstallDirs FilePath
  -> InstalledPackageInfo
379
generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs =
380
  IPI.InstalledPackageInfo {
381 382 383
    IPI.sourcePackageId    = (packageId   pkg) {
                                pkgName = componentCompatPackageName clbi
                             },
384
    IPI.installedUnitId    = componentUnitId clbi,
385
    IPI.installedComponentId_ = componentComponentId clbi,
386
    IPI.instantiatedWith   = componentInstantiatedWith clbi,
387
    IPI.compatPackageKey   = componentCompatPackageKey clbi,
Duncan Coutts's avatar
Duncan Coutts committed
388 389 390 391 392 393 394
    IPI.license            = license     pkg,
    IPI.copyright          = copyright   pkg,
    IPI.maintainer         = maintainer  pkg,
    IPI.author             = author      pkg,
    IPI.stability          = stability   pkg,
    IPI.homepage           = homepage    pkg,
    IPI.pkgUrl             = pkgUrl      pkg,
395
    IPI.synopsis           = synopsis    pkg,
Duncan Coutts's avatar
Duncan Coutts committed
396 397
    IPI.description        = description pkg,
    IPI.category           = category    pkg,
398
    IPI.abiHash            = abi_hash,
399
    IPI.indefinite         = componentIsIndefinite clbi,
Duncan Coutts's avatar
Duncan Coutts committed
400
    IPI.exposed            = libExposed  lib,
401
    IPI.exposedModules     = componentExposedModules clbi,
Duncan Coutts's avatar
Duncan Coutts committed
402
    IPI.hiddenModules      = otherModules bi,
403
    IPI.trusted            = IPI.trusted IPI.emptyInstalledPackageInfo,
Duncan Coutts's avatar
Duncan Coutts committed
404
    IPI.importDirs         = [ libdir installDirs | hasModules ],
Christiaan Baaij's avatar
Christiaan Baaij committed
405 406
    IPI.libraryDirs        = libdirs,
    IPI.libraryDynDirs     = dynlibdirs,
407
    IPI.dataDir            = datadir installDirs,
408
    IPI.hsLibraries        = if hasLibrary
409
                               then [getHSLibraryName (componentUnitId clbi)]
410
                               else [],
Duncan Coutts's avatar
Duncan Coutts committed
411
    IPI.extraLibraries     = extraLibs bi,
412
    IPI.extraGHCiLibraries = extraGHCiLibs bi,
Duncan Coutts's avatar
Duncan Coutts committed
413 414
    IPI.includeDirs        = absinc ++ adjustRelIncDirs relinc,
    IPI.includes           = includes bi,
415 416 417
                             --TODO: unclear what the root cause of the
                             -- duplication is, but we nub it here for now:
    IPI.depends            = ordNub $ map fst (componentPackageDeps clbi),
Duncan Coutts's avatar
Duncan Coutts committed
418 419 420 421 422
    IPI.ccOptions          = [], -- Note. NOT ccOptions bi!
                                 -- We don't want cc-options to be propagated
                                 -- to C compilations in other packages.
    IPI.ldOptions          = ldOptions bi,
    IPI.frameworks         = frameworks bi,
423
    IPI.frameworkDirs      = extraFrameworkDirs bi,
Duncan Coutts's avatar
Duncan Coutts committed
424
    IPI.haddockInterfaces  = [haddockdir installDirs </> haddockName pkg],
425 426
    IPI.haddockHTMLs       = [htmldir installDirs],
    IPI.pkgRoot            = Nothing
Duncan Coutts's avatar
Duncan Coutts committed
427 428 429 430
  }
  where
    bi = libBuildInfo lib
    (absinc, relinc) = partition isAbsolute (includeDirs bi)
431
    hasModules = not $ null (allLibModules lib clbi)
Christiaan Baaij's avatar
Christiaan Baaij committed
432
    comp = compiler lbi
Duncan Coutts's avatar
Duncan Coutts committed
433
    hasLibrary = hasModules || not (null (cSources bi))
434
                            || (not (null (jsSources bi)) &&
Christiaan Baaij's avatar
Christiaan Baaij committed
435 436 437 438 439 440 441 442 443 444 445 446 447 448 449
                                compilerFlavor comp == GHCJS)
    (libdirs, dynlibdirs)
      | not hasLibrary
      = (extraLibDirs bi, [])
      -- the dynamic-library-dirs defaults to the library-dirs if not specified,
      -- so this works whether the dynamic-library-dirs field is supported or not

      | libraryDynDirSupported comp
      = (libdir    installDirs : extraLibDirs bi,
         dynlibdir installDirs : extraLibDirs bi)

      | otherwise
      = (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, [])
      -- the compiler doesn't understand the dynamic-library-dirs field so we
      -- add the dyn directory to the "normal" list in the library-dirs field
450

Ian D. Bollinger's avatar
Ian D. Bollinger committed
451
-- | Construct 'InstalledPackageInfo' for a library that is in place in the
Duncan Coutts's avatar
Duncan Coutts committed
452 453
-- build tree.
--
Ian D. Bollinger's avatar
Ian D. Bollinger committed
454
-- This function knows about the layout of in place packages.
Duncan Coutts's avatar
Duncan Coutts committed
455 456 457 458
--
inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree
                            -> FilePath -- ^ location of the dist tree
                            -> PackageDescription
459
                            -> AbiHash
Duncan Coutts's avatar
Duncan Coutts committed
460 461 462 463
                            -> Library
                            -> LocalBuildInfo
                            -> ComponentLocalBuildInfo
                            -> InstalledPackageInfo
464
inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi =
465
    generalInstalledPackageInfo adjustRelativeIncludeDirs
466
                                pkg abi_hash lib lbi clbi installDirs
Duncan Coutts's avatar
Duncan Coutts committed
467
  where
refold's avatar
refold committed
468
    adjustRelativeIncludeDirs = map (inplaceDir </>)
469
    libTargetDir = componentBuildDir lbi clbi
Duncan Coutts's avatar
Duncan Coutts committed
470
    installDirs =
471
      (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) {
472
        libdir     = inplaceDir </> libTargetDir,
Christiaan Baaij's avatar
Christiaan Baaij committed
473
        dynlibdir  = inplaceDir </> libTargetDir,
474
        datadir    = inplaceDir </> dataDir pkg,
Duncan Coutts's avatar
Duncan Coutts committed
475 476 477 478 479 480 481 482 483 484 485 486 487 488
        docdir     = inplaceDocdir,
        htmldir    = inplaceHtmldir,
        haddockdir = inplaceHtmldir
      }
    inplaceDocdir  = inplaceDir </> distPref </> "doc"
    inplaceHtmldir = inplaceDocdir </> "html" </> display (packageName pkg)


-- | Construct 'InstalledPackageInfo' for the final install location of a
-- library package.
--
-- This function knows about the layout of installed packages.
--
absoluteInstalledPackageInfo :: PackageDescription
489
                             -> AbiHash
Duncan Coutts's avatar
Duncan Coutts committed
490 491 492 493
                             -> Library
                             -> LocalBuildInfo
                             -> ComponentLocalBuildInfo
                             -> InstalledPackageInfo
494
absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi =
495
    generalInstalledPackageInfo adjustReativeIncludeDirs
496
                                pkg abi_hash lib lbi clbi installDirs
Duncan Coutts's avatar
Duncan Coutts committed
497 498 499 500 501 502 503
  where
    -- For installed packages we install all include files into one dir,
    -- whereas in the build tree they may live in multiple local dirs.
    adjustReativeIncludeDirs _
      | null (installIncludes bi) = []
      | otherwise                 = [includedir installDirs]
    bi = libBuildInfo lib
504
    installDirs = absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest
Duncan Coutts's avatar
Duncan Coutts committed
505

506 507

relocatableInstalledPackageInfo :: PackageDescription
508
                                -> AbiHash
509 510 511
                                -> Library
                                -> LocalBuildInfo
                                -> ComponentLocalBuildInfo
512
                                -> FilePath
513
                                -> InstalledPackageInfo
514
relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot =
515
    generalInstalledPackageInfo adjustReativeIncludeDirs
516
                                pkg abi_hash lib lbi clbi installDirs
517 518 519 520 521 522 523
  where
    -- For installed packages we install all include files into one dir,
    -- whereas in the build tree they may live in multiple local dirs.
    adjustReativeIncludeDirs _
      | null (installIncludes bi) = []
      | otherwise                 = [includedir installDirs]
    bi = libBuildInfo lib
524 525

    installDirs = fmap (("${pkgroot}" </>) . shortRelativePath pkgroot)
526
                $ absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest
527

simonmar's avatar
simonmar committed
528 529
-- -----------------------------------------------------------------------------
-- Unregistration
530

ijones's avatar
ijones committed
531
unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
Duncan Coutts's avatar
Duncan Coutts committed
532 533 534
unregister pkg lbi regFlags = do
  let pkgid     = packageId pkg
      genScript = fromFlag (regGenScript regFlags)
535
      verbosity = fromFlag (regVerbosity regFlags)
Duncan Coutts's avatar
Duncan Coutts committed
536
      packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi))
537
                                    (regPackageDB regFlags)
538 539 540 541 542 543 544
      unreg hpi =
        let invocation = HcPkg.unregisterInvocation
                           hpi Verbosity.normal packageDb pkgid
        in if genScript
             then writeFileAtomic unregScriptFileName
                    (BS.Char8.pack $ invocationAsSystemScript buildOS invocation)
             else runProgramInvocation verbosity invocation
Duncan Coutts's avatar
Duncan Coutts committed
545
  setupMessage verbosity "Unregistering" pkgid
546 547
  withHcPkg "unregistering is only implemented for GHC and GHCJS"
    (compiler lbi) (withPrograms lbi) unreg
ijones's avatar
ijones committed
548

Duncan Coutts's avatar
Duncan Coutts committed
549 550 551 552
unregScriptFileName :: FilePath
unregScriptFileName = case buildOS of
                          Windows -> "unregister.bat"
                          _       -> "unregister.sh"
553 554 555 556 557 558

internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath
internalPackageDBPath lbi distPref =
      case compilerFlavor (compiler lbi) of
        UHC -> UHC.inplacePackageDbPath lbi
        _   -> distPref </> "package.conf.inplace"