-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Register
-- Copyright   :  Isaac Jones 2003-2004
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- 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,
-- or alternatively to register the package in place in the build tree. The
-- 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.

module Distribution.Simple.Register (
    register,
    unregister,

    initPackageDB,
    invokeHcPkg,
    registerPackage,
    generateRegistrationInfo,
    inplaceInstalledPackageInfo,
    absoluteInstalledPackageInfo,
    generalInstalledPackageInfo,
  ) where

import Distribution.Simple.LocalBuildInfo
         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)
         , ComponentName(..), getComponentLocalBuildInfo
         , LibraryName(..)
         , InstallDirs(..), absoluteInstallDirs )
import Distribution.Simple.BuildPaths (haddockName)
import qualified Distribution.Simple.GHC  as GHC
import qualified Distribution.Simple.LHC  as LHC
import qualified Distribution.Simple.Hugs as Hugs
import qualified Distribution.Simple.UHC  as UHC
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import Distribution.Simple.Compiler
         ( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor
         , PackageDBStack, registrationPackageDB )
import Distribution.Simple.Program
         ( ProgramConfiguration, ConfiguredProgram
         , runProgramInvocation, requireProgram, lookupProgram
         , ghcPkgProgram, lhcPkgProgram )
import Distribution.Simple.Program.Script
         ( invocationAsSystemScript )
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import Distribution.Simple.Setup
         ( RegisterFlags(..), CopyDest(..)
         , fromFlag, fromFlagOrDefault, flagToMaybe )
import Distribution.PackageDescription
         ( PackageDescription(..), Library(..), BuildInfo(..), hcOptions )
import Distribution.Package
         ( Package(..), packageName, InstalledPackageId(..) )
import Distribution.InstalledPackageInfo
         ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo)
         , showInstalledPackageInfo )
import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.Simple.Utils
         ( writeUTF8File, writeFileAtomic, setFileExecutable
         , die, notice, setupMessage )
import Distribution.System
         ( OS(..), buildOS )
import Distribution.Text
         ( display )
import Distribution.Version ( Version(..) )
import Distribution.Verbosity as Verbosity
         ( Verbosity, normal )
import Distribution.Compat.Exception
         ( tryIO )

import System.FilePath ((</>), (<.>), isAbsolute)
import System.Directory
         ( getCurrentDirectory, removeDirectoryRecursive )

import Data.Maybe
         ( isJust, fromMaybe, maybeToList )
import Data.List
         ( partition, nub )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8

-- -----------------------------------------------------------------------------
-- Registration

register :: PackageDescription -> LocalBuildInfo
         -> RegisterFlags -- ^Install in the user's database?; verbose
         -> IO ()
register pkg@PackageDescription { library       = Just lib  } lbi regFlags
  = do
    let clbi = getComponentLocalBuildInfo lbi CLibName
    installedPkgInfo <- generateRegistrationInfo
                           verbosity pkg lib lbi clbi inplace distPref

     -- Three different modes:
    case () of
     _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo
       | modeGenerateRegScript -> writeRegisterScript   installedPkgInfo
       | otherwise             -> registerPackage verbosity
                                    installedPkgInfo pkg lbi inplace packageDbs

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

    modeGenerateRegScript = fromFlag (regGenScript regFlags)

    inplace   = fromFlag (regInPlace regFlags)
    -- 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)

    writeRegistrationFile installedPkgInfo = do
      notice verbosity ("Creating package registration file: " ++ regFile)
      writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo)

    writeRegisterScript installedPkgInfo =
      case compilerFlavor (compiler lbi) of
        GHC  -> do (ghcPkg, _) <- requireProgram verbosity ghcPkgProgram (withPrograms lbi)
                   writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDbs
        LHC  -> do (lhcPkg, _) <- requireProgram verbosity lhcPkgProgram (withPrograms lbi)
                   writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDbs
        Hugs -> notice verbosity "Registration scripts not needed for hugs"
        JHC  -> notice verbosity "Registration scripts not needed for jhc"
        NHC  -> notice verbosity "Registration scripts not needed for nhc98"
        UHC  -> notice verbosity "Registration scripts not needed for uhc"
        _    -> die "Registration scripts are not implemented for this compiler"

register _ _ regFlags = notice verbosity "No package to register"
  where
    verbosity = fromFlag (regVerbosity regFlags)


generateRegistrationInfo :: Verbosity
                         -> PackageDescription
                         -> Library
                         -> LocalBuildInfo
                         -> ComponentLocalBuildInfo
                         -> Bool
                         -> FilePath
                         -> IO InstalledPackageInfo
generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref = do
  --TODO: eliminate pwd!
  pwd <- getCurrentDirectory

  --TODO: the method of setting the InstalledPackageId is compiler specific
  --      this aspect should be delegated to a per-compiler helper.
  let comp = compiler lbi
  ipid <-
    case compilerFlavor comp of
     GHC | compilerVersion comp >= Version [6,11] [] -> do
            s <- GHC.libAbiHash verbosity pkg lbi lib clbi
            return (InstalledPackageId (display (packageId pkg) ++ '-':s))
     _other -> do
            return (InstalledPackageId (display (packageId pkg)))

  let installedPkgInfo
        | inplace   = inplaceInstalledPackageInfo pwd distPref
                        pkg lib lbi clbi
        | otherwise = absoluteInstalledPackageInfo
                        pkg lib lbi clbi

  return installedPkgInfo{ IPI.installedPackageId = ipid }


-- | Create an empty package DB at the specified location.
initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath
                 -> IO ()
initPackageDB verbosity comp conf dbPath =
  case (compilerFlavor comp) of
    GHC -> GHC.initPackageDB verbosity conf dbPath
    HaskellSuite {} -> HaskellSuite.initPackageDB verbosity conf dbPath
    _   -> die "Distribution.Simple.Register.initPackageDB: \
               \not implemented for this compiler"

-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack
                -> [String] -> IO ()
invokeHcPkg verbosity comp conf dbStack extraArgs =
    case (compilerFlavor comp) of
      GHC -> GHC.invokeHcPkg verbosity conf dbStack extraArgs
      _   -> die "Distribution.Simple.Register.invokeHcPkg: \
                 \not implemented for this compiler"

registerPackage :: Verbosity
                -> InstalledPackageInfo
                -> PackageDescription
                -> LocalBuildInfo
                -> Bool
                -> PackageDBStack
                -> IO ()
registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do
  let msg = if inplace
            then "In-place registering"
            else "Registering"
  setupMessage verbosity msg (packageId pkg)
  case compilerFlavor (compiler lbi) of
    GHC  -> GHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs
    LHC  -> LHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs
    Hugs -> Hugs.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs
    UHC  -> UHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs
    JHC  -> notice verbosity "Registering for jhc (nothing to do)"
    NHC  -> notice verbosity "Registering for nhc98 (nothing to do)"
    HaskellSuite {} ->
      HaskellSuite.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs
    _    -> die "Registering is not implemented for this compiler"


writeHcPkgRegisterScript :: Verbosity
                         -> InstalledPackageInfo
                         -> ConfiguredProgram
                         -> PackageDBStack
                         -> IO ()
writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do
  let invocation  = HcPkg.reregisterInvocation hcPkg Verbosity.normal
                      packageDbs (Right installedPkgInfo)
      regScript   = invocationAsSystemScript buildOS   invocation

  notice verbosity ("Creating package registration script: " ++ regScriptFileName)
  writeUTF8File regScriptFileName regScript
  setFileExecutable regScriptFileName

regScriptFileName :: FilePath
regScriptFileName = case buildOS of
                        Windows -> "register.bat"
                        _       -> "register.sh"


-- -----------------------------------------------------------------------------
-- Making the InstalledPackageInfo

-- | 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
  -> Library
  -> ComponentLocalBuildInfo
  -> InstallDirs FilePath
  -> InstalledPackageInfo
generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs =
  InstalledPackageInfo {
    --TODO: do not open-code this conversion from PackageId to InstalledPackageId
    IPI.installedPackageId = InstalledPackageId (display (packageId pkg)),
    IPI.sourcePackageId    = packageId   pkg,
    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,
    IPI.synopsis           = synopsis    pkg,
    IPI.description        = description pkg,
    IPI.category           = category    pkg,
    IPI.exposed            = libExposed  lib,
    IPI.exposedModules     = exposedModules lib,
    IPI.hiddenModules      = otherModules bi,
    IPI.trusted            = IPI.trusted IPI.emptyInstalledPackageInfo,
    IPI.importDirs         = [ libdir installDirs | hasModules ],
    IPI.libraryDirs        = if hasLibrary
                               then libdir installDirs : extraLibDirs bi
                               else                      extraLibDirs bi,
    IPI.hsLibraries        = [ libname
                             | LibraryName libname <- componentLibraries clbi
                             , hasLibrary ],
    IPI.extraLibraries     = extraLibs bi,
    IPI.extraGHCiLibraries = [],
    IPI.includeDirs        = absinc ++ adjustRelIncDirs relinc,
    IPI.includes           = includes bi,
    IPI.depends            = map fst (componentPackageDeps clbi),
    IPI.hugsOptions        = hcOptions Hugs bi,
    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.frameworkDirs      = [],
    IPI.frameworks         = frameworks bi,
    IPI.haddockInterfaces  = [haddockdir installDirs </> haddockName pkg],
    IPI.haddockHTMLs       = [htmldir installDirs]
  }
  where
    bi = libBuildInfo lib
    (absinc, relinc) = partition isAbsolute (includeDirs bi)
    hasModules = not $ null (exposedModules lib)
                    && null (otherModules bi)
    hasLibrary = hasModules || not (null (cSources bi))


-- | Construct 'InstalledPackageInfo' for a library that is in place in the
-- build tree.
--
-- This function knows about the layout of in place packages.
--
inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree
                            -> FilePath -- ^ location of the dist tree
                            -> PackageDescription
                            -> Library
                            -> LocalBuildInfo
                            -> ComponentLocalBuildInfo
                            -> InstalledPackageInfo
inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi =
    generalInstalledPackageInfo adjustRelativeIncludeDirs pkg lib clbi
    installDirs
  where
    adjustRelativeIncludeDirs = map (inplaceDir </>)
    installDirs =
      (absoluteInstallDirs pkg lbi NoCopyDest) {
        libdir     = inplaceDir </> buildDir lbi,
        datadir    = inplaceDir,
        datasubdir = distPref,
        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
                             -> Library
                             -> LocalBuildInfo
                             -> ComponentLocalBuildInfo
                             -> InstalledPackageInfo
absoluteInstalledPackageInfo pkg lib lbi clbi =
    generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs
  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
    installDirs = absoluteInstallDirs pkg lbi NoCopyDest

-- -----------------------------------------------------------------------------
-- Unregistration

unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
unregister pkg lbi regFlags = do
  let pkgid     = packageId pkg
      genScript = fromFlag (regGenScript regFlags)
      verbosity = fromFlag (regVerbosity regFlags)
      packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi))
                                    (regPackageDB regFlags)
      installDirs = absoluteInstallDirs pkg lbi NoCopyDest
  setupMessage verbosity "Unregistering" pkgid
  case compilerFlavor (compiler lbi) of
    GHC ->
      let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)
          invocation = HcPkg.unregisterInvocation ghcPkg Verbosity.normal
                         packageDb pkgid
      in if genScript
           then writeFileAtomic unregScriptFileName
                  (BS.Char8.pack $ invocationAsSystemScript buildOS invocation)
            else runProgramInvocation verbosity invocation
    Hugs -> do
        _ <- tryIO $ removeDirectoryRecursive (libdir installDirs)
        return ()
    NHC -> do
        _ <- tryIO $ removeDirectoryRecursive (libdir installDirs)
        return ()
    _ ->
        die ("only unregistering with GHC and Hugs is implemented")

unregScriptFileName :: FilePath
unregScriptFileName = case buildOS of
                          Windows -> "unregister.bat"
                          _       -> "unregister.sh"