    -----------------------------------------------------------------------------
    -- |
    -- 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      = []