Distribution/Simple/Program/HcPkg.hs

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