-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Program.HcPkg
-- Copyright   :  Duncan Coutts 2009, 2013
--
-- Maintainer  :  cabal-devel@haskell.org
-- 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,
    unregister,
    expose,
    hide,
    dump,
    list,

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

import Prelude hiding (init)
import Distribution.Package
         ( PackageId, InstalledPackageId(..) )
import Distribution.InstalledPackageInfo
         ( InstalledPackageInfo, InstalledPackageInfo_(..)
         , showInstalledPackageInfo
         , emptyInstalledPackageInfo, fieldsInstalledPackageInfo )
import Distribution.ParseUtils
import Distribution.Simple.Compiler
         ( PackageDB(..), PackageDBStack )
import Distribution.Simple.Program.Types
         ( ConfiguredProgram(programId) )
import Distribution.Simple.Program.Run
         ( ProgramInvocation(..), IOEncoding(..), programInvocation
         , runProgramInvocation, getProgramInvocationOutput )
import Distribution.Text
         ( display, simpleParse )
import Distribution.Simple.Utils
         ( die )
import Distribution.Verbosity
         ( Verbosity, deafening, silent )
import Distribution.Compat.Exception
         ( catchExit )

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
  , useSingleFileDb :: Bool -- ^ requires single file package database
  }

-- | Call @hc-pkg@ to initialise a package database at the location {path}.
--
-- > hc-pkg init {path}
--
init :: HcPkgInfo -> Verbosity -> FilePath -> IO ()
init hpi verbosity path =
  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)


-- | 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 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 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)
    `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"

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

  where
    parsePackages str =
      let parsed = map parseInstalledPackageInfo' (splitPkgs str)
       in case [ msg | ParseFailed msg <- parsed ] of
            []   -> Left [   setInstalledPackageId
                           . maybe id mungePackagePaths (pkgRoot pkg)
                           $ pkg
                         | ParseOk _ pkg <- parsed ]
            msgs -> Right msgs

    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 installedPackageId
-- field, so if it is missing then we fill it as the source package ID.
setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo
setInstalledPackageId pkginfo@InstalledPackageInfo {
                        installedPackageId = InstalledPackageId "",
                        sourcePackageId    = pkgid
                      }
                    = pkginfo {
                        --TODO use a proper named function for the conversion
                        -- from source package id to installed package id
                        installedPackageId = InstalledPackageId (display pkgid)
                      }
setInstalledPackageId 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 'InstalledPackageId', 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)
    `catchExit` \_ -> 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
  :: HcPkgInfo -> Verbosity -> PackageDBStack
  -> Either FilePath InstalledPackageInfo
  -> ProgramInvocation
registerInvocation   = registerInvocation' "register"
reregisterInvocation = registerInvocation' "update"


registerInvocation' :: String -> HcPkgInfo -> Verbosity -> PackageDBStack
                    -> Either FilePath InstalledPackageInfo
                    -> ProgramInvocation
registerInvocation' cmdname hpi verbosity packagedbs (Left pkgFile) =
    programInvocation (hcPkgProgram hpi) args
  where
    args = [cmdname, pkgFile]
        ++ (if noPkgDbStack hpi
              then [packageDbOpts hpi (last packagedbs)]
              else packageDbStackOpts hpi packagedbs)
        ++ verbosityOpts hpi verbosity

registerInvocation' cmdname hpi verbosity packagedbs (Right pkgInfo) =
    (programInvocation (hcPkgProgram hpi) args) {
      progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),
      progInvokeInputEncoding = IOEncodingUTF8
    }
  where
    args = [cmdname, "-"]
        ++ (if noPkgDbStack hpi
              then [packageDbOpts hpi (last packagedbs)]
              else packageDbStackOpts hpi packagedbs)
        ++ 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


exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
                 -> ProgramInvocation
exposeInvocation hpi verbosity packagedb pkgid =
  programInvocation (hcPkgProgram hpi) $
       ["expose", packageDbOpts hpi packagedb, display pkgid]
    ++ 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      = []