content: -----------------------------------------------------------------------------
  -- |
  -- 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 and LHC have hc-pkg programs.
  
  module Distribution.Simple.Program.HcPkg (
      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, programVersion) )
  import Distribution.Simple.Program.Run
           ( ProgramInvocation(..), IOEncoding(..), programInvocation
           , runProgramInvocation, getProgramInvocationOutput )
  import Distribution.Version
           ( Version(..) )
  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.Maybe
           ( fromMaybe )
  import Data.List
           ( stripPrefix )
  import System.FilePath as FilePath
           ( (</>), splitPath, splitDirectories, joinPath, isPathSeparator )
  import qualified System.FilePath.Posix as FilePath.Posix
  
  
  -- | Call @hc-pkg@ to initialise a package database at the location {path}.
  --
  -- > hc-pkg init {path}
  --
  init :: Verbosity -> ConfiguredProgram -> FilePath -> IO ()
  init verbosity hcPkg path =
    runProgramInvocation verbosity
      (initInvocation hcPkg verbosity path)
  
  -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
  -- provided command-line arguments to it.
  invoke :: Verbosity -> ConfiguredProgram -> PackageDBStack -> [String] -> IO ()
  invoke verbosity hcPkg dbStack extraArgs =
    runProgramInvocation verbosity invocation
    where
      args       = packageDbStackOpts hcPkg dbStack ++ extraArgs
      invocation = programInvocation hcPkg args
  
  -- | Call @hc-pkg@ to register a package.
  --
  -- > hc-pkg register {filename | -} [--user | --global | --package-db]
  --
  register :: Verbosity -> ConfiguredProgram -> PackageDBStack
           -> Either FilePath
                     InstalledPackageInfo
           -> IO ()
  register verbosity hcPkg packagedb pkgFile =
    runProgramInvocation verbosity
      (registerInvocation hcPkg verbosity packagedb pkgFile)
  
  
  -- | Call @hc-pkg@ to re-register a package.
  --
  -- > hc-pkg register {filename | -} [--user | --global | --package-db]
  --
  reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack
             -> Either FilePath
                       InstalledPackageInfo
             -> IO ()
  reregister verbosity hcPkg packagedb pkgFile =
    runProgramInvocation verbosity
      (reregisterInvocation hcPkg verbosity packagedb pkgFile)
  
  
  -- | Call @hc-pkg@ to unregister a package
  --
  -- > hc-pkg unregister [pkgid] [--user | --global | --package-db]
  --
  unregister :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()
  unregister verbosity hcPkg packagedb pkgid =
    runProgramInvocation verbosity
      (unregisterInvocation hcPkg verbosity packagedb pkgid)
  
  
  -- | Call @hc-pkg@ to expose a package.
  --
  -- > hc-pkg expose [pkgid] [--user | --global | --package-db]
  --
  expose :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()
  expose verbosity hcPkg packagedb pkgid =
    runProgramInvocation verbosity
      (exposeInvocation hcPkg verbosity packagedb pkgid)
  
  
  -- | Call @hc-pkg@ to expose a package.
  --
  -- > hc-pkg expose [pkgid] [--user | --global | --package-db]
  --
  hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()
  hide verbosity hcPkg packagedb pkgid =
    runProgramInvocation verbosity
      (hideInvocation hcPkg verbosity packagedb pkgid)
  
  
  -- | Call @hc-pkg@ to get all the details of all the packages in the given
  -- package database.
  --
  dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo]
  dump verbosity hcPkg packagedb = do
  
    output <- getProgramInvocationOutput verbosity
                (dumpInvocation hcPkg verbosity packagedb)
      `catchExit` \_ -> die $ programId hcPkg ++ " dump failed"
  
    case parsePackages output of
      Left ok -> return ok
      _       -> die $ "failed to parse output of '"
                    ++ programId hcPkg ++ " dump'"
  
    where
      parsePackages str =
        let parsed = map parseInstalledPackageInfo' (splitPkgs str)
         in case [ msg | ParseFailed msg <- parsed ] of
              []   -> Left [   setInstalledPackageId
                             . maybe id mungePackagePaths pkgroot
                             $ pkg
                           | ParseOk _ (pkgroot, pkg) <- parsed ]
              msgs -> Right msgs
  
      parseInstalledPackageInfo' =
          parseFieldsFlat fields (Nothing, emptyInstalledPackageInfo)
        where
          fields =     liftFieldFst pkgrootField
                 : map liftFieldSnd fieldsInstalledPackageInfo
  
          pkgrootField =
            simpleField "pkgroot"
              showFilePath    parseFilePathQ
              (fromMaybe "")  (\x _ -> Just x)
  
          liftFieldFst = liftField fst (\x (_x,y) -> (x,y))
          liftFieldSnd = liftField snd (\y (x,_y) -> (x,y))
  
      --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 :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [PackageId]
  list verbosity hcPkg packagedb = do
  
    output <- getProgramInvocationOutput verbosity
                (listInvocation hcPkg verbosity packagedb)
      `catchExit` \_ -> die $ programId hcPkg ++ " list failed"
  
    case parsePackageIds output of
      Just ok -> return ok
      _       -> die $ "failed to parse output of '"
                    ++ programId hcPkg ++ " list'"
  
    where
      parsePackageIds str =
        let parsed = map simpleParse (words str)
         in case [ () | Nothing <- parsed ] of
              [] -> Just [ pkgid | Just pkgid <- parsed ]
              _  -> Nothing
  
  
  --------------------------
  -- The program invocations
  --
  
  initInvocation :: ConfiguredProgram
                 -> Verbosity -> FilePath -> ProgramInvocation
  initInvocation hcPkg verbosity path =
      programInvocation hcPkg args
    where
      args = ["init", path]
          ++ verbosityOpts hcPkg verbosity
  
  registerInvocation, reregisterInvocation
    :: ConfiguredProgram -> Verbosity -> PackageDBStack
    -> Either FilePath InstalledPackageInfo
    -> ProgramInvocation
  registerInvocation   = registerInvocation' "register"
  reregisterInvocation = registerInvocation' "update"
  
  
  registerInvocation' :: String
                      -> ConfiguredProgram -> Verbosity -> PackageDBStack
                      -> Either FilePath InstalledPackageInfo
                      -> ProgramInvocation
  registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) =
      programInvocation hcPkg args
    where
      args = [cmdname, pkgFile]
          ++ (if legacyVersion hcPkg
                then [packageDbOpts hcPkg (last packagedbs)]
                else packageDbStackOpts hcPkg packagedbs)
          ++ verbosityOpts hcPkg verbosity
  
  registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) =
      (programInvocation hcPkg args) {
        progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),
        progInvokeInputEncoding = IOEncodingUTF8
      }
    where
      args = [cmdname, "-"]
          ++ (if legacyVersion hcPkg
                then [packageDbOpts hcPkg (last packagedbs)]
                else packageDbStackOpts hcPkg packagedbs)
          ++ verbosityOpts hcPkg verbosity
  
  
  unregisterInvocation :: ConfiguredProgram
                       -> Verbosity -> PackageDB -> PackageId
                       -> ProgramInvocation
  unregisterInvocation hcPkg verbosity packagedb pkgid =
    programInvocation hcPkg $
         ["unregister", packageDbOpts hcPkg packagedb, display pkgid]
      ++ verbosityOpts hcPkg verbosity
  
  
  exposeInvocation :: ConfiguredProgram
                   -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation
  exposeInvocation hcPkg verbosity packagedb pkgid =
    programInvocation hcPkg $
         ["expose", packageDbOpts hcPkg packagedb, display pkgid]
      ++ verbosityOpts hcPkg verbosity
  
  
  hideInvocation :: ConfiguredProgram
                 -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation
  hideInvocation hcPkg verbosity packagedb pkgid =
    programInvocation hcPkg $
         ["hide", packageDbOpts hcPkg packagedb, display pkgid]
      ++ verbosityOpts hcPkg verbosity
  
  
  dumpInvocation :: ConfiguredProgram
                 -> Verbosity -> PackageDB -> ProgramInvocation
  dumpInvocation hcPkg _verbosity packagedb =
      (programInvocation hcPkg args) {
        progInvokeOutputEncoding = IOEncodingUTF8
      }
    where
      args = ["dump", packageDbOpts hcPkg packagedb]
          ++ verbosityOpts hcPkg silent
             -- We use verbosity level 'silent' because it is important that we
             -- do not contaminate the output with info/debug messages.
  
  listInvocation :: ConfiguredProgram
                 -> Verbosity -> PackageDB -> ProgramInvocation
  listInvocation hcPkg _verbosity packagedb =
      (programInvocation hcPkg args) {
        progInvokeOutputEncoding = IOEncodingUTF8
      }
    where
      args = ["list", "--simple-output", packageDbOpts hcPkg packagedb]
          ++ verbosityOpts hcPkg silent
             -- We use verbosity level 'silent' because it is important that we
             -- do not contaminate the output with info/debug messages.
  
  
  packageDbStackOpts :: ConfiguredProgram -> PackageDBStack -> [String]
  packageDbStackOpts hcPkg dbstack = case dbstack of
    (GlobalPackageDB:UserPackageDB:dbs) -> "--global"
                                         : "--user"
                                         : map specific dbs
    (GlobalPackageDB:dbs)               -> "--global"
                                         : ("--no-user-" ++ packageDbFlag hcPkg)
                                         : map specific dbs
    _                                   -> ierror
    where
      specific (SpecificPackageDB db) = "--" ++ packageDbFlag hcPkg ++ "=" ++ db
      specific _ = ierror
      ierror :: a
      ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)
  
  packageDbFlag :: ConfiguredProgram -> String
  packageDbFlag hcPkg
    | programVersion hcPkg < Just (Version [7,5] [])
    = "package-conf"
    | otherwise
    = "package-db"
  
  packageDbOpts :: ConfiguredProgram -> PackageDB -> String
  packageDbOpts _ GlobalPackageDB        = "--global"
  packageDbOpts _ UserPackageDB          = "--user"
  packageDbOpts hcPkg (SpecificPackageDB db) = "--" ++ packageDbFlag hcPkg ++ "=" ++ db
  
  verbosityOpts :: ConfiguredProgram -> Verbosity -> [String]
  verbosityOpts hcPkg v
  
    -- ghc-pkg < 6.11 does not support -v
    | programId hcPkg == "ghc-pkg"
   && programVersion hcPkg < Just (Version [6,11] [])
                     = []
  
    | v >= deafening = ["-v2"]
    | v == silent    = ["-v0"]
    | otherwise      = []
  
  -- Handle quirks in ghc-pkg 6.8 and older
  legacyVersion :: ConfiguredProgram -> Bool
  legacyVersion hcPkg = programId hcPkg == "ghc-pkg"
                     && programVersion hcPkg < Just (Version [6,9] [])
  