-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Program.HcPkg
-- Copyright   :  Duncan Coutts 2009, 2013
--
-- Maintainer  :  [email protected]
-- Portability :  portable
--
-- This module provides an library interface to the @hc-pkg@ program.
-- Currently only GHC, GHCJS and LHC have hc-pkg programs.

module Distribution.Simple.Program.HcPkg (
    HcPkgInfo(..),

    init,
    invoke,
    register,
    reregister,
    registerMultiInstance,
    unregister,
    recache,
    expose,
    hide,
    dump,
    describe,
    list,

    -- * Program invocations
    initInvocation,
    registerInvocation,
    reregisterInvocation,
    registerMultiInstanceInvocation,
    unregisterInvocation,
    recacheInvocation,
    exposeInvocation,
    hideInvocation,
    dumpInvocation,
    describeInvocation,
    listInvocation,
  ) where

import Distribution.Package hiding (installedUnitId)
import Distribution.InstalledPackageInfo
import Distribution.ParseUtils
import Distribution.Simple.Compiler
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Run
import Distribution.Text
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Compat.Exception

import Prelude hiding (init)
import Data.Char
         ( isSpace )
import Data.List
         ( stripPrefix )
import System.FilePath as FilePath
         ( (</>), (<.>)
         , splitPath, splitDirectories, joinPath, isPathSeparator )
import qualified System.FilePath.Posix as FilePath.Posix

-- | Information about the features and capabilities of an @hc-pkg@
--   program.
--
data HcPkgInfo = HcPkgInfo
  { hcPkgProgram    :: ConfiguredProgram
  , noPkgDbStack    :: Bool -- ^ no package DB stack supported
  , noVerboseFlag   :: Bool -- ^ hc-pkg does not support verbosity flags
  , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db
  , supportsDirDbs  :: Bool -- ^ supports directory style package databases
  , requiresDirDbs  :: Bool -- ^ requires directory style package databases
  , nativeMultiInstance  :: Bool -- ^ supports --enable-multi-instance flag
  , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache
  }

-- | Call @hc-pkg@ to initialise a package database at the location {path}.
--
-- > hc-pkg init {path}
--
init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO ()
init hpi verbosity preferCompat path
  |  not (supportsDirDbs hpi)
 || (not (requiresDirDbs hpi) && preferCompat)
  = writeFile path "[]"

  | otherwise
  = runProgramInvocation verbosity (initInvocation hpi verbosity path)

-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()
invoke hpi verbosity dbStack extraArgs =
  runProgramInvocation verbosity invocation
  where
    args       = packageDbStackOpts hpi dbStack ++ extraArgs
    invocation = programInvocation (hcPkgProgram hpi) args

-- | Call @hc-pkg@ to register a package.
--
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
--
register :: HcPkgInfo -> Verbosity -> PackageDBStack
         -> Either FilePath
                   InstalledPackageInfo
         -> IO ()
register hpi verbosity packagedb pkgFile =
  runProgramInvocation verbosity
    (registerInvocation hpi verbosity packagedb pkgFile)


-- | Call @hc-pkg@ to re-register a package.
--
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
--
reregister :: HcPkgInfo -> Verbosity -> PackageDBStack
           -> Either FilePath
                     InstalledPackageInfo
           -> IO ()
reregister hpi verbosity packagedb pkgFile =
  runProgramInvocation verbosity
    (reregisterInvocation hpi verbosity packagedb pkgFile)

registerMultiInstance :: HcPkgInfo -> Verbosity
                      -> PackageDBStack
                      -> InstalledPackageInfo
                      -> IO ()
registerMultiInstance hpi verbosity packagedbs pkgInfo
  | nativeMultiInstance hpi
  = runProgramInvocation verbosity
      (registerMultiInstanceInvocation hpi verbosity packagedbs (Right pkgInfo))

    -- This is a trick. Older versions of GHC do not support the
    -- --enable-multi-instance flag for ghc-pkg register but it turns out that
    -- the same ability is available by using ghc-pkg recache. The recache
    -- command is there to support distro package managers that like to work
    -- by just installing files and running update commands, rather than
    -- special add/remove commands. So the way to register by this method is
    -- to write the package registration file directly into the package db and
    -- then call hc-pkg recache.
    --
  | recacheMultiInstance hpi
  = do let pkgdb = last packagedbs
       writeRegistrationFileDirectly hpi pkgdb pkgInfo
       recache hpi verbosity pkgdb

  | otherwise
  = die $ "HcPkg.registerMultiInstance: the compiler does not support "
       ++ "registering multiple instances of packages."

writeRegistrationFileDirectly :: HcPkgInfo
                              -> PackageDB
                              -> InstalledPackageInfo
                              -> IO ()
writeRegistrationFileDirectly hpi (SpecificPackageDB dir) pkgInfo
  | supportsDirDbs hpi
  = do let pkgfile = dir </> display (installedUnitId pkgInfo) <.> "conf"
       writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo)

  | otherwise
  = die $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs"

writeRegistrationFileDirectly _ _ _ =
    -- We don't know here what the dir for the global or user dbs are,
    -- if that's needed it'll require a bit more plumbing to support.
    die $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now"


-- | Call @hc-pkg@ to unregister a package
--
-- > hc-pkg unregister [pkgid] [--user | --global | --package-db]
--
unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
unregister hpi verbosity packagedb pkgid =
  runProgramInvocation verbosity
    (unregisterInvocation hpi verbosity packagedb pkgid)


-- | Call @hc-pkg@ to recache the registered packages.
--
-- > hc-pkg recache [--user | --global | --package-db]
--
recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO ()
recache hpi verbosity packagedb =
  runProgramInvocation verbosity
    (recacheInvocation hpi verbosity packagedb)


-- | Call @hc-pkg@ to expose a package.
--
-- > hc-pkg expose [pkgid] [--user | --global | --package-db]
--
expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
expose hpi verbosity packagedb pkgid =
  runProgramInvocation verbosity
    (exposeInvocation hpi verbosity packagedb pkgid)

-- | Call @hc-pkg@ to retrieve a specific package
--
-- > hc-pkg describe [pkgid] [--user | --global | --package-db]
--
describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo]
describe hpi verbosity packagedb pid = do

  output <- getProgramInvocationOutput verbosity
              (describeInvocation hpi verbosity packagedb pid)
    `catchIO` \_ -> return ""

  case parsePackages output of
    Left ok -> return ok
    _       -> die $ "failed to parse output of '"
                  ++ programId (hcPkgProgram hpi) ++ " describe " ++ display pid ++ "'"

-- | Call @hc-pkg@ to hide a package.
--
-- > hc-pkg hide [pkgid] [--user | --global | --package-db]
--
hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
hide hpi verbosity packagedb pkgid =
  runProgramInvocation verbosity
    (hideInvocation hpi verbosity packagedb pkgid)


-- | Call @hc-pkg@ to get all the details of all the packages in the given
-- package database.
--
dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]
dump hpi verbosity packagedb = do

  output <- getProgramInvocationOutput verbosity
              (dumpInvocation hpi verbosity packagedb)
    `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"

  case parsePackages output of
    Left ok -> return ok
    _       -> die $ "failed to parse output of '"
                  ++ programId (hcPkgProgram hpi) ++ " dump'"

parsePackages :: String -> Either [InstalledPackageInfo] [PError]
parsePackages str =
  let parsed = map parseInstalledPackageInfo' (splitPkgs str)
   in case [ msg | ParseFailed msg <- parsed ] of
        []   -> Left [   setUnitId
                       . maybe id mungePackagePaths (pkgRoot pkg)
                       $ pkg
                     | ParseOk _ pkg <- parsed ]
        msgs -> Right msgs
  where
    parseInstalledPackageInfo' =
      parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo

--TODO: this could be a lot faster. We're doing normaliseLineEndings twice
-- and converting back and forth with lines/unlines.
splitPkgs :: String -> [String]
splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines
  where
    -- Handle the case of there being no packages at all.
    checkEmpty [s] | all isSpace s = []
    checkEmpty ss                  = ss

    splitWith :: (a -> Bool) -> [a] -> [[a]]
    splitWith p xs = ys : case zs of
                       []   -> []
                       _:ws -> splitWith p ws
      where (ys,zs) = break p xs

mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
mungePackagePaths pkgroot pkginfo =
    pkginfo {
      importDirs        = mungePaths (importDirs  pkginfo),
      includeDirs       = mungePaths (includeDirs pkginfo),
      libraryDirs       = mungePaths (libraryDirs pkginfo),
      frameworkDirs     = mungePaths (frameworkDirs pkginfo),
      haddockInterfaces = mungePaths (haddockInterfaces pkginfo),
      haddockHTMLs      = mungeUrls  (haddockHTMLs pkginfo)
    }
  where
    mungePaths = map mungePath
    mungeUrls  = map mungeUrl

    mungePath p = case stripVarPrefix "${pkgroot}" p of
      Just p' -> pkgroot </> p'
      Nothing -> p

    mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of
      Just p' -> toUrlPath pkgroot p'
      Nothing -> p

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
                 ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)

    stripVarPrefix var p =
      case splitPath p of
        (root:path') -> case stripPrefix var root of
          Just [sep] | isPathSeparator sep -> Just (joinPath path')
          _                                -> Nothing
        _                                  -> Nothing


-- Older installed package info files did not have the installedUnitId
-- field, so if it is missing then we fill it as the source package ID.
setUnitId :: InstalledPackageInfo -> InstalledPackageInfo
setUnitId pkginfo@InstalledPackageInfo {
                        installedUnitId = SimpleUnitId (ComponentId ""),
                        sourcePackageId = pkgid
                      }
                    = pkginfo {
                        installedUnitId = mkLegacyUnitId pkgid
                      }
setUnitId pkginfo = pkginfo


-- | Call @hc-pkg@ to get the source package Id of all the packages in the
-- given package database.
--
-- This is much less information than with 'dump', but also rather quicker.
-- Note in particular that it does not include the 'UnitId', just
-- the source 'PackageId' which is not necessarily unique in any package db.
--
list :: HcPkgInfo -> Verbosity -> PackageDB
     -> IO [PackageId]
list hpi verbosity packagedb = do

  output <- getProgramInvocationOutput verbosity
              (listInvocation hpi verbosity packagedb)
    `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed"

  case parsePackageIds output of
    Just ok -> return ok
    _       -> die $ "failed to parse output of '"
                  ++ programId (hcPkgProgram hpi) ++ " list'"

  where
    parsePackageIds = sequence . map simpleParse . words

--------------------------
-- The program invocations
--

initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
initInvocation hpi verbosity path =
    programInvocation (hcPkgProgram hpi) args
  where
    args = ["init", path]
        ++ verbosityOpts hpi verbosity

registerInvocation, reregisterInvocation, registerMultiInstanceInvocation
  :: HcPkgInfo -> Verbosity -> PackageDBStack
  -> Either FilePath InstalledPackageInfo
  -> ProgramInvocation
registerInvocation   = registerInvocation' "register" False
reregisterInvocation = registerInvocation' "update"   False
registerMultiInstanceInvocation = registerInvocation' "update" True

registerInvocation' :: String -> Bool
                    -> HcPkgInfo -> Verbosity -> PackageDBStack
                    -> Either FilePath InstalledPackageInfo
                    -> ProgramInvocation
registerInvocation' cmdname multiInstance hpi
                    verbosity packagedbs pkgFileOrInfo =
    case pkgFileOrInfo of
      Left pkgFile ->
        programInvocation (hcPkgProgram hpi) (args pkgFile)

      Right pkgInfo ->
        (programInvocation (hcPkgProgram hpi) (args "-")) {
          progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),
          progInvokeInputEncoding = IOEncodingUTF8
        }
  where
    args file = [cmdname, file]
             ++ (if noPkgDbStack hpi
                   then [packageDbOpts hpi (last packagedbs)]
                   else packageDbStackOpts hpi packagedbs)
             ++ [ "--enable-multi-instance" | multiInstance ]
             ++ verbosityOpts hpi verbosity

unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
                     -> ProgramInvocation
unregisterInvocation hpi verbosity packagedb pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["unregister", packageDbOpts hpi packagedb, display pkgid]
    ++ verbosityOpts hpi verbosity


recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB
                  -> ProgramInvocation
recacheInvocation hpi verbosity packagedb =
  programInvocation (hcPkgProgram hpi) $
       ["recache", packageDbOpts hpi packagedb]
    ++ verbosityOpts hpi verbosity


exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
                 -> ProgramInvocation
exposeInvocation hpi verbosity packagedb pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["expose", packageDbOpts hpi packagedb, display pkgid]
    ++ verbosityOpts hpi verbosity

describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId
                   -> ProgramInvocation
describeInvocation hpi verbosity packagedbs pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["describe", display pkgid]
    ++ (if noPkgDbStack hpi
          then [packageDbOpts hpi (last packagedbs)]
          else packageDbStackOpts hpi packagedbs)
    ++ verbosityOpts hpi verbosity

hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
               -> ProgramInvocation
hideInvocation hpi verbosity packagedb pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["hide", packageDbOpts hpi packagedb, display pkgid]
    ++ verbosityOpts hpi verbosity


dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
dumpInvocation hpi _verbosity packagedb =
    (programInvocation (hcPkgProgram hpi) args) {
      progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
    args = ["dump", packageDbOpts hpi packagedb]
        ++ verbosityOpts hpi silent
           -- We use verbosity level 'silent' because it is important that we
           -- do not contaminate the output with info/debug messages.

listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
listInvocation hpi _verbosity packagedb =
    (programInvocation (hcPkgProgram hpi) args) {
      progInvokeOutputEncoding = IOEncodingUTF8
    }
  where
    args = ["list", "--simple-output", packageDbOpts hpi packagedb]
        ++ verbosityOpts hpi silent
           -- We use verbosity level 'silent' because it is important that we
           -- do not contaminate the output with info/debug messages.


packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String]
packageDbStackOpts hpi dbstack = case dbstack of
  (GlobalPackageDB:UserPackageDB:dbs) -> "--global"
                                       : "--user"
                                       : map specific dbs
  (GlobalPackageDB:dbs)               -> "--global"
                                       : ("--no-user-" ++ packageDbFlag hpi)
                                       : map specific dbs
  _                                   -> ierror
  where
    specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
    specific _ = ierror
    ierror :: a
    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)

packageDbFlag :: HcPkgInfo -> String
packageDbFlag hpi
  | flagPackageConf hpi
  = "package-conf"
  | otherwise
  = "package-db"

packageDbOpts :: HcPkgInfo -> PackageDB -> String
packageDbOpts _ GlobalPackageDB        = "--global"
packageDbOpts _ UserPackageDB          = "--user"
packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db

verbosityOpts :: HcPkgInfo -> Verbosity -> [String]
verbosityOpts hpi v
  | noVerboseFlag hpi
                   = []
  | v >= deafening = ["-v2"]
  | v == silent    = ["-v0"]
  | otherwise      = []