Packages.hs

-- (c) The University of Glasgow, 2006

{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}

-- | Package manipulation
module Packages (
        module PackageConfig,

        -- * Reading the package config, and processing cmdline args
        PackageState(preloadPackages, explicitPackages, requirementContext),
        PackageConfigMap,
        emptyPackageState,
        initPackages,
        readPackageConfigs,
        getPackageConfRefs,
        resolvePackageConfig,
        readPackageConfig,
        listPackageConfigMap,

        -- * Querying the package config
        lookupPackage,
        lookupPackage',
        lookupInstalledPackage,
        lookupPackageName,
        improveUnitId,
        searchPackageId,
        getPackageDetails,
        getInstalledPackageDetails,
        componentIdString,
        displayInstalledUnitId,
        listVisibleModuleNames,
        lookupModuleInAllPackages,
        lookupModuleWithSuggestions,
        lookupPluginModuleWithSuggestions,
        LookupResult(..),
        ModuleSuggestion(..),
        ModuleOrigin(..),

        -- * Inspecting the set of packages in scope
        getPackageIncludePath,
        getPackageLibraryPath,
        getPackageLinkOpts,
        getPackageExtraCcOpts,
        getPackageFrameworkPath,
        getPackageFrameworks,
        getPackageConfigMap,
        getPreloadPackagesAnd,

        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
        packageHsLibs,

        -- * Utils
        unwireUnitId,
        pprFlag,
        pprPackages,
        pprPackagesSimple,
        pprModuleMap,
        isDllName
    )
where

#include "HsVersions.h"

import GHC.PackageDb
import PackageConfig
import DynFlags
import Name             ( Name, nameModule_maybe )
import UniqFM
import UniqDFM
import UniqSet
import Module
import Util
import Panic
import Outputable
import Maybes

import System.Environment ( getEnv )
import FastString
import ErrUtils         ( debugTraceMsg, MsgDoc, printInfoForUser )
import Exception

import System.Directory
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import Control.Monad
import Data.Char ( toUpper )
import Data.List as List
import Data.Map (Map)
import Data.Set (Set)
import Data.Maybe (mapMaybe)
import Data.Monoid (First(..))
#if __GLASGOW_HASKELL__ > 710
import Data.Semigroup   ( Semigroup )
import qualified Data.Semigroup as Semigroup
#endif
import qualified Data.Map as Map
import qualified Data.Map.Strict as MapStrict
import qualified FiniteMap as Map
import qualified Data.Set as Set

-- ---------------------------------------------------------------------------
-- The Package state

-- | Package state is all stored in 'DynFlags', including the details of
-- all packages, which packages are exposed, and which modules they
-- provide.
--
-- The package state is computed by 'initPackages', and kept in DynFlags.
-- It is influenced by various package flags:
--
--   * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed.
--     If @-hide-all-packages@ was not specified, these commands also cause
--      all other packages with the same name to become hidden.
--
--   * @-hide-package <pkg>@ causes @<pkg>@ to become hidden.
--
--   * (there are a few more flags, check below for their semantics)
--
-- The package state has the following properties.
--
--   * Let @exposedPackages@ be the set of packages thus exposed.
--     Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of
--     their dependencies.
--
--   * When searching for a module from an preload import declaration,
--     only the exposed modules in @exposedPackages@ are valid.
--
--   * When searching for a module from an implicit import, all modules
--     from @depExposedPackages@ are valid.
--
--   * When linking in a compilation manager mode, we link in packages the
--     program depends on (the compiler knows this list by the
--     time it gets to the link step).  Also, we link in all packages
--     which were mentioned with preload @-package@ flags on the command-line,
--     or are a transitive dependency of same, or are \"base\"\/\"rts\".
--     The reason for this is that we might need packages which don't
--     contain any Haskell modules, and therefore won't be discovered
--     by the normal mechanism of dependency tracking.

-- Notes on DLLs
-- ~~~~~~~~~~~~~
-- When compiling module A, which imports module B, we need to
-- know whether B will be in the same DLL as A.
--      If it's in the same DLL, we refer to B_f_closure
--      If it isn't, we refer to _imp__B_f_closure
-- When compiling A, we record in B's Module value whether it's
-- in a different DLL, by setting the DLL flag.

-- | Given a module name, there may be multiple ways it came into scope,
-- possibly simultaneously.  This data type tracks all the possible ways
-- it could have come into scope.  Warning: don't use the record functions,
-- they're partial!
data ModuleOrigin =
    -- | Module is hidden, and thus never will be available for import.
    -- (But maybe the user didn't realize), so we'll still keep track
    -- of these modules.)
    ModHidden
    -- | Module is public, and could have come from some places.
  | ModOrigin {
        -- | @Just False@ means that this module is in
        -- someone's @exported-modules@ list, but that package is hidden;
        -- @Just True@ means that it is available; @Nothing@ means neither
        -- applies.
        fromOrigPackage :: Maybe Bool
        -- | Is the module available from a reexport of an exposed package?
        -- There could be multiple.
      , fromExposedReexport :: [PackageConfig]
        -- | Is the module available from a reexport of a hidden package?
      , fromHiddenReexport :: [PackageConfig]
        -- | Did the module export come from a package flag? (ToDo: track
        -- more information.
      , fromPackageFlag :: Bool
      }

instance Outputable ModuleOrigin where
    ppr ModHidden = text "hidden module"
    ppr (ModOrigin e res rhs f) = sep (punctuate comma (
        (case e of
            Nothing -> []
            Just False -> [text "hidden package"]
            Just True -> [text "exposed package"]) ++
        (if null res
            then []
            else [text "reexport by" <+>
                    sep (map (ppr . packageConfigId) res)]) ++
        (if null rhs
            then []
            else [text "hidden reexport by" <+>
                    sep (map (ppr . packageConfigId) res)]) ++
        (if f then [text "package flag"] else [])
        ))

-- | Smart constructor for a module which is in @exposed-modules@.  Takes
-- as an argument whether or not the defining package is exposed.
fromExposedModules :: Bool -> ModuleOrigin
fromExposedModules e = ModOrigin (Just e) [] [] False

-- | Smart constructor for a module which is in @reexported-modules@.  Takes
-- as an argument whether or not the reexporting package is expsed, and
-- also its 'PackageConfig'.
fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin
fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False

-- | Smart constructor for a module which was bound by a package flag.
fromFlag :: ModuleOrigin
fromFlag = ModOrigin Nothing [] [] True

#if __GLASGOW_HASKELL__ > 710
instance Semigroup ModuleOrigin where
    ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' =
        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
      where g (Just b) (Just b')
                | b == b'   = Just b
                | otherwise = panic "ModOrigin: package both exposed/hidden"
            g Nothing x = x
            g x Nothing = x
    _x <> _y = panic "ModOrigin: hidden module redefined"
#endif

instance Monoid ModuleOrigin where
    mempty = ModOrigin Nothing [] [] False
    mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') =
        ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')
      where g (Just b) (Just b')
                | b == b'   = Just b
                | otherwise = panic "ModOrigin: package both exposed/hidden"
            g Nothing x = x
            g x Nothing = x
    mappend _ _ = panic "ModOrigin: hidden module redefined"

-- | Is the name from the import actually visible? (i.e. does it cause
-- ambiguity, or is it only relevant when we're making suggestions?)
originVisible :: ModuleOrigin -> Bool
originVisible ModHidden = False
originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f

-- | Are there actually no providers for this module?  This will never occur
-- except when we're filtering based on package imports.
originEmpty :: ModuleOrigin -> Bool
originEmpty (ModOrigin Nothing [] [] False) = True
originEmpty _ = False

-- | 'UniqFM' map from 'InstalledUnitId'
type InstalledUnitIdMap = UniqDFM

-- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus
-- the transitive closure of preload packages.
data PackageConfigMap = PackageConfigMap {
        unPackageConfigMap :: InstalledUnitIdMap PackageConfig,
        -- | The set of transitively reachable packages according
        -- to the explicitly provided command line arguments.
        -- See Note [UnitId to InstalledUnitId improvement]
        preloadClosure :: UniqSet InstalledUnitId
    }

-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'.
type VisibilityMap = Map UnitId UnitVisibility

-- | 'UnitVisibility' records the various aspects of visibility of a particular
-- 'UnitId'.
data UnitVisibility = UnitVisibility
    { uv_expose_all :: Bool
      --  ^ Should all modules in exposed-modules should be dumped into scope?
    , uv_renamings :: [(ModuleName, ModuleName)]
      -- ^ Any custom renamings that should bring extra 'ModuleName's into
      -- scope.
    , uv_package_name :: First FastString
      -- ^ The package name is associated with the 'UnitId'.  This is used
      -- to implement legacy behavior where @-package foo-0.1@ implicitly
      -- hides any packages named @foo@
    , uv_requirements :: Map ModuleName (Set IndefModule)
      -- ^ The signatures which are contributed to the requirements context
      -- from this unit ID.
    , uv_explicit :: Bool
      -- ^ Whether or not this unit was explicitly brought into scope,
      -- as opposed to implicitly via the 'exposed' fields in the
      -- package database (when @-hide-all-packages@ is not passed.)
    }

instance Outputable UnitVisibility where
    ppr (UnitVisibility {
        uv_expose_all = b,
        uv_renamings = rns,
        uv_package_name = First mb_pn,
        uv_requirements = reqs,
        uv_explicit = explicit
    }) = ppr (b, rns, mb_pn, reqs, explicit)
instance Monoid UnitVisibility where
    mempty = UnitVisibility
             { uv_expose_all = False
             , uv_renamings = []
             , uv_package_name = First Nothing
             , uv_requirements = Map.empty
             , uv_explicit = False
             }
    mappend uv1 uv2
        = UnitVisibility
          { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2
          , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2
          , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2)
          , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2)
          , uv_explicit = uv_explicit uv1 || uv_explicit uv2
          }

type WiredUnitId = DefUnitId
type PreloadUnitId = InstalledUnitId

-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings
-- in scope.  The 'PackageConf' is not cached, mostly for convenience reasons
-- (since this is the slow path, we'll just look it up again).
type ModuleToPkgConfAll =
    Map ModuleName (Map Module ModuleOrigin)

data PackageState = PackageState {
  -- | A mapping of 'UnitId' to 'PackageConfig'.  This list is adjusted
  -- so that only valid packages are here.  'PackageConfig' reflects
  -- what was stored *on disk*, except for the 'trusted' flag, which
  -- is adjusted at runtime.  (In particular, some packages in this map
  -- may have the 'exposed' flag be 'False'.)
  pkgIdMap              :: PackageConfigMap,

  -- | A mapping of 'PackageName' to 'ComponentId'.  This is used when
  -- users refer to packages in Backpack includes.
  packageNameMap            :: Map PackageName ComponentId,

  -- | A mapping from wired in names to the original names from the
  -- package database.
  unwireMap :: Map WiredUnitId WiredUnitId,

  -- | The packages we're going to link in eagerly.  This list
  -- should be in reverse dependency order; that is, a package
  -- is always mentioned before the packages it depends on.
  preloadPackages      :: [PreloadUnitId],

  -- | Packages which we explicitly depend on (from a command line flag).
  -- We'll use this to generate version macros.
  explicitPackages      :: [UnitId],

  -- | This is a full map from 'ModuleName' to all modules which may possibly
  -- be providing it.  These providers may be hidden (but we'll still want
  -- to report them in error messages), or it may be an ambiguous import.
  moduleToPkgConfAll    :: !ModuleToPkgConfAll,

  -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility.
  pluginModuleToPkgConfAll    :: !ModuleToPkgConfAll,

  -- | A map saying, for each requirement, what interfaces must be merged
  -- together when we use them.  For example, if our dependencies
  -- are @p[A=<A>]@ and @q[A=<A>,B=r[C=<A>]:B]@, then the interfaces
  -- to merge for A are @p[A=<A>]:A@, @q[A=<A>,B=r[C=<A>]:B]:A@
  -- and @r[C=<A>]:C@.
  --
  -- There's an entry in this map for each hole in our home library.
  requirementContext :: Map ModuleName [IndefModule]
  }

emptyPackageState :: PackageState
emptyPackageState = PackageState {
    pkgIdMap = emptyPackageConfigMap,
    packageNameMap = Map.empty,
    unwireMap = Map.empty,
    preloadPackages = [],
    explicitPackages = [],
    moduleToPkgConfAll = Map.empty,
    pluginModuleToPkgConfAll = Map.empty,
    requirementContext = Map.empty
    }

type InstalledPackageIndex = Map InstalledUnitId PackageConfig

-- | Empty package configuration map
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet

-- | Find the package we know about with the given unit id, if any
lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags))

-- | A more specialized interface, which takes a boolean specifying
-- whether or not to look for on-the-fly renamed interfaces, and
-- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can
-- be used while we're initializing 'DynFlags'
lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid
lookupPackage' True m@(PackageConfigMap pkg_map _) uid =
    case splitUnitIdInsts uid of
        (iuid, Just indef) ->
            fmap (renamePackage m (indefUnitIdInsts indef))
                 (lookupUDFM pkg_map iuid)
        (_, Nothing) -> lookupUDFM pkg_map uid

{-
-- | Find the indefinite package for a given 'ComponentId'.
-- The way this works is just by fiat'ing that every indefinite package's
-- unit key is precisely its component ID; and that they share uniques.
lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig
lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs
  where
    PackageConfigMap pkg_map = pkgIdMap (pkgState dflags)
-}

-- | Find the package we know about with the given package name (e.g. @foo@), if any
-- (NB: there might be a locally defined unit name which overrides this)
lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId
lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags))

-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
                               (listPackageConfigMap dflags)

-- | Extends the package configuration map with a list of package configs.
extendPackageConfigMap
   :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs
  = PackageConfigMap (foldl add pkg_map new_pkgs) closure
    -- We also add the expanded version of the packageConfigId, so that
    -- 'improveUnitId' can find it.
  where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p)
                                  (installedPackageConfigId p) p

-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
getPackageDetails :: DynFlags -> UnitId -> PackageConfig
getPackageDetails dflags pid =
    expectJust "getPackageDetails" (lookupPackage dflags pid)

lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid

lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig
lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid

getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig
getInstalledPackageDetails dflags uid =
    expectJust "getInstalledPackageDetails" $
        lookupInstalledPackage dflags uid

-- | Get a list of entries from the package database.  NB: be careful with
-- this function, although all packages in this map are "visible", this
-- does not imply that the exposed-modules of the package are available
-- (they may have been thinned or renamed).
listPackageConfigMap :: DynFlags -> [PackageConfig]
listPackageConfigMap dflags = eltsUDFM pkg_map
  where
    PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags)

-- ----------------------------------------------------------------------------
-- Loading the package db files and building up the package state

-- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
-- database files, and sets up various internal tables of package
-- information, according to the package-related flags on the
-- command-line (@-package@, @-hide-package@ etc.)
--
-- Returns a list of packages to link in if we're doing dynamic linking.
-- This list contains the packages that the user explicitly mentioned with
-- @-package@ flags.
--
-- 'initPackages' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'pkgState' in 'DynFlags' and return a list of packages to
-- link in.
initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId])
initPackages dflags0 = do
  dflags <- interpretPackageEnv dflags0
  pkg_db <-
    case pkgDatabase dflags of
        Nothing -> readPackageConfigs dflags
        Just db -> return $ map (\(p, pkgs)
                                    -> (p, setBatchPackageFlags dflags pkgs)) db
  (pkg_state, preload)
        <- mkPackageState dflags pkg_db []
  return (dflags{ pkgDatabase = Just pkg_db,
                  pkgState = pkg_state },
          preload)

-- -----------------------------------------------------------------------------
-- Reading the package database(s)

readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])]
readPackageConfigs dflags = do
  conf_refs <- getPackageConfRefs dflags
  confs     <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
  mapM (readPackageConfig dflags) confs


getPackageConfRefs :: DynFlags -> IO [PkgConfRef]
getPackageConfRefs dflags = do
  let system_conf_refs = [UserPkgConf, GlobalPkgConf]

  e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
  let base_conf_refs = case e_pkg_path of
        Left _ -> system_conf_refs
        Right path
         | not (null path) && isSearchPathSeparator (last path)
         -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs
         | otherwise
         -> map PkgConfFile (splitSearchPath path)

  return $ reverse (extraPkgConfs dflags base_conf_refs)
  -- later packages shadow earlier ones.  extraPkgConfs
  -- is in the opposite order to the flags on the
  -- command line.

resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
-- NB: This logic is reimplemented in Cabal, so if you change it,
-- make sure you update Cabal.  (Or, better yet, dump it in the
-- compiler info so Cabal can use the info.)
resolvePackageConfig dflags UserPkgConf = runMaybeT $ do
  dir <- versionedAppDir dflags
  let pkgconf = dir </> "package.conf.d"
  exist <- tryMaybeT $ doesDirectoryExist pkgconf
  if exist then return pkgconf else mzero
resolvePackageConfig _ (PkgConfFile name) = return $ Just name

readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])
readPackageConfig dflags conf_file = do
  isdir <- doesDirectoryExist conf_file

  proto_pkg_configs <-
    if isdir
       then readDirStylePackageConfig conf_file
       else do
            isfile <- doesFileExist conf_file
            if isfile
               then do
                 mpkgs <- tryReadOldFileStylePackageConfig
                 case mpkgs of
                   Just pkgs -> return pkgs
                   Nothing   -> throwGhcExceptionIO $ InstallationError $
                      "ghc no longer supports single-file style package " ++
                      "databases (" ++ conf_file ++
                      ") use 'ghc-pkg init' to create the database with " ++
                      "the correct format."
               else throwGhcExceptionIO $ InstallationError $
                      "can't find a package database at " ++ conf_file

  let
      top_dir = topDir dflags
      pkgroot = takeDirectory conf_file
      pkg_configs1 = map (mungePackageConfig top_dir pkgroot)
                         proto_pkg_configs
      pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
  --
  return (conf_file, pkg_configs2)
  where
    readDirStylePackageConfig conf_dir = do
      let filename = conf_dir </> "package.cache"
      debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
      readPackageDbForGhc filename

    -- Single-file style package dbs have been deprecated for some time, but
    -- it turns out that Cabal was using them in one place. So this is a
    -- workaround to allow older Cabal versions to use this newer ghc.
    -- We check if the file db contains just "[]" and if so, we look for a new
    -- dir-style db in conf_file.d/, ie in a dir next to the given file.
    -- We cannot just replace the file with a new dir style since Cabal still
    -- assumes it's a file and tries to overwrite with 'writeFile'.
    -- ghc-pkg also cooperates with this workaround.
    tryReadOldFileStylePackageConfig = do
      content <- readFile conf_file `catchIO` \_ -> return ""
      if take 2 content == "[]"
        then do
          let conf_dir = conf_file <.> "d"
          direxists <- doesDirectoryExist conf_dir
          if direxists
             then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
                     liftM Just (readDirStylePackageConfig conf_dir)
             else return (Just []) -- ghc-pkg will create it when it's updated
        else return Nothing

setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
  where
    maybeDistrustAll pkgs'
      | gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
      | otherwise                           = pkgs'

    distrust pkg = pkg{ trusted = False }

mungePackageConfig :: FilePath -> FilePath
                   -> PackageConfig -> PackageConfig
mungePackageConfig top_dir pkgroot =
    mungeDynLibFields
  . mungePackagePaths top_dir pkgroot

mungeDynLibFields :: PackageConfig -> PackageConfig
mungeDynLibFields pkg =
    pkg {
      libraryDynDirs     = libraryDynDirs pkg
                `orIfNull` libraryDirs pkg
    }
  where
    orIfNull [] flags = flags
    orIfNull flags _  = flags

-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
-- 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.
--
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mungePackagePaths top_dir pkgroot pkg =
    pkg {
      importDirs  = munge_paths (importDirs pkg),
      includeDirs = munge_paths (includeDirs pkg),
      libraryDirs = munge_paths (libraryDirs pkg),
      libraryDynDirs = munge_paths (libraryDynDirs pkg),
      frameworkDirs = munge_paths (frameworkDirs pkg),
      haddockInterfaces = munge_paths (haddockInterfaces pkg),
      haddockHTMLs = munge_urls (haddockHTMLs pkg)
    }
  where
    munge_paths = map munge_path
    munge_urls  = map munge_url

    munge_path p
      | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
      | Just p' <- stripVarPrefix "$topdir"    p = top_dir ++ p'
      | otherwise                                = p

    munge_url p
      | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
      | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'
      | otherwise                                   = p

    toUrlPath r p = "file:///"
                 -- URLs always use posix style '/' separators:
                 ++ FilePath.Posix.joinPath
                        (r : -- We need to drop a leading "/" or "\\"
                             -- if there is one:
                             dropWhile (all isPathSeparator)
                                       (FilePath.splitDirectories p))

    -- We could drop the separator here, and then use </> above. However,
    -- by leaving it in and using ++ we keep the same path separator
    -- rather than letting FilePath change it to use \ as the separator
    stripVarPrefix var path = case stripPrefix var path of
                              Just [] -> Just []
                              Just cs@(c : _) | isPathSeparator c -> Just cs
                              _ -> Nothing


-- -----------------------------------------------------------------------------
-- Modify our copy of the package database based on trust flags,
-- -trust and -distrust.

applyTrustFlag
   :: DynFlags
   -> UnusablePackages
   -> [PackageConfig]
   -> TrustFlag
   -> IO [PackageConfig]
applyTrustFlag dflags unusable pkgs flag =
  case flag of
    -- we trust all matching packages. Maybe should only trust first one?
    -- and leave others the same or set them untrusted
    TrustPackage str ->
       case selectPackages (PackageArg str) pkgs unusable of
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map trust ps ++ qs)
          where trust p = p {trusted=True}

    DistrustPackage str ->
       case selectPackages (PackageArg str) pkgs unusable of
         Left ps       -> trustFlagErr dflags flag ps
         Right (ps,qs) -> return (map distrust ps ++ qs)
          where distrust p = p {trusted=False}

-- | A little utility to tell if the 'thisPackage' is indefinite
-- (if it is not, we should never use on-the-fly renaming.)
isIndefinite :: DynFlags -> Bool
isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags))

applyPackageFlag
   :: DynFlags
   -> PackageConfigMap
   -> UnusablePackages
   -> Bool -- if False, if you expose a package, it implicitly hides
           -- any previously exposed packages with the same name
   -> [PackageConfig]
   -> VisibilityMap           -- Initially exposed
   -> PackageFlag               -- flag to apply
   -> IO VisibilityMap        -- Now exposed

applyPackageFlag dflags pkg_db unusable no_hide_others pkgs vm flag =
  case flag of
    ExposePackage _ arg (ModRenaming b rns) ->
       case findPackages pkg_db arg pkgs unusable of
         Left ps         -> packageFlagErr dflags flag ps
         Right (p:_) -> return vm'
          where
           n = fsPackageName p

           -- If a user says @-unit-id p[A=<A>]@, this imposes
           -- a requirement on us: whatever our signature A is,
           -- it must fulfill all of p[A=<A>]:A's requirements.
           -- This method is responsible for computing what our
           -- inherited requirements are.
           reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid
                | otherwise                 = Map.empty

           collectHoles uid = case splitUnitIdInsts uid of
                (_, Just indef) ->
                  let local = [ Map.singleton
                                  (moduleName mod)
                                  (Set.singleton $ IndefModule indef mod_name)
                              | (mod_name, mod) <- indefUnitIdInsts indef
                              , isHoleModule mod ]
                      recurse = [ collectHoles (moduleUnitId mod)
                                | (_, mod) <- indefUnitIdInsts indef ]
                  in Map.unionsWith Set.union $ local ++ recurse
                -- Other types of unit identities don't have holes
                (_, Nothing) -> Map.empty


           uv = UnitVisibility
                { uv_expose_all = b
                , uv_renamings = rns
                , uv_package_name = First (Just n)
                , uv_requirements = reqs
                , uv_explicit = True
                }
           vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared
           -- In the old days, if you said `ghc -package p-0.1 -package p-0.2`
           -- (or if p-0.1 was registered in the pkgdb as exposed: True),
           -- the second package flag would override the first one and you
           -- would only see p-0.2 in exposed modules.  This is good for
           -- usability.
           --
           -- However, with thinning and renaming (or Backpack), there might be
           -- situations where you legitimately want to see two versions of a
           -- package at the same time, and this behavior would make it
           -- impossible to do so.  So we decided that if you pass
           -- -hide-all-packages, this should turn OFF the overriding behavior
           -- where an exposed package hides all other packages with the same
           -- name.  This should not affect Cabal at all, which only ever
           -- exposes one package at a time.
           --
           -- NB: Why a variable no_hide_others?  We have to apply this logic to
           -- -plugin-package too, and it's more consistent if the switch in
           -- behavior is based off of
           -- -hide-all-packages/-hide-all-plugin-packages depending on what
           -- flag is in question.
           vm_cleared | no_hide_others = vm
                      -- NB: renamings never clear
                      | (_:_) <- rns = vm
                      | otherwise = Map.filterWithKey
                            (\k uv -> k == packageConfigId p
                                   || First (Just n) /= uv_package_name uv) vm
         _ -> panic "applyPackageFlag"

    HidePackage str ->
       case findPackages pkg_db (PackageArg str) pkgs unusable of
         Left ps  -> packageFlagErr dflags flag ps
         Right ps -> return vm'
          where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps)

-- | Like 'selectPackages', but doesn't return a list of unmatched
-- packages.  Furthermore, any packages it returns are *renamed*
-- if the 'UnitArg' has a renaming associated with it.
findPackages :: PackageConfigMap -> PackageArg -> [PackageConfig]
             -> UnusablePackages
             -> Either [(PackageConfig, UnusablePackageReason)]
                [PackageConfig]
findPackages pkg_db arg pkgs unusable
  = let ps = mapMaybe (finder arg) pkgs
    in if null ps
        then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y))
                            (Map.elems unusable))
        else Right (sortByVersion (reverse ps))
  where
    finder (PackageArg str) p
      = if str == sourcePackageIdString p || str == packageNameString p
          then Just p
          else Nothing
    finder (UnitIdArg uid) p
      = let (iuid, mb_indef) = splitUnitIdInsts uid
        in if iuid == installedPackageConfigId p
              then Just (case mb_indef of
                            Nothing    -> p
                            Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p)
              else Nothing

selectPackages :: PackageArg -> [PackageConfig]
               -> UnusablePackages
               -> Either [(PackageConfig, UnusablePackageReason)]
                  ([PackageConfig], [PackageConfig])
selectPackages arg pkgs unusable
  = let matches = matching arg
        (ps,rest) = partition matches pkgs
    in if null ps
        then Left (filter (matches.fst) (Map.elems unusable))
        -- NB: packages from later package databases are LATER
        -- in the list.  We want to prefer the latest package.
        else Right (sortByVersion (reverse ps), rest)

-- | Rename a 'PackageConfig' according to some module instantiation.
renamePackage :: PackageConfigMap -> [(ModuleName, Module)]
              -> PackageConfig -> PackageConfig
renamePackage pkg_map insts conf =
    let hsubst = listToUFM insts
        smod  = renameHoleModule' pkg_map hsubst
        new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf)
    in conf {
        instantiatedWith = new_insts,
        exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod))
                             (exposedModules conf)
    }


-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
matchingStr :: String -> PackageConfig -> Bool
matchingStr str p
        =  str == sourcePackageIdString p
        || str == packageNameString p

matchingId :: InstalledUnitId -> PackageConfig -> Bool
matchingId uid p = uid == installedPackageConfigId p

matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
matching (UnitIdArg (DefiniteUnitId (DefUnitId uid)))  = matchingId uid
matching (UnitIdArg _)  = \_ -> False -- TODO: warn in this case

sortByVersion :: [PackageConfig] -> [PackageConfig]
sortByVersion = sortBy (flip (comparing packageVersion))

comparing :: Ord a => (t -> a) -> t -> t -> Ordering
comparing f a b = f a `compare` f b

packageFlagErr :: DynFlags
               -> PackageFlag
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a

-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
packageFlagErr dflags (ExposePackage _ (PackageArg pkg) _) []
  | is_dph_package pkg
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
  where dph_err = text "the " <> text pkg <> text " package is not installed."
                  $$ text "To install it: \"cabal install dph\"."
        is_dph_package pkg = "dph" `isPrefixOf` pkg
packageFlagErr dflags flag reasons
  = packageFlagErr' dflags (pprFlag flag) reasons

trustFlagErr :: DynFlags
             -> TrustFlag
             -> [(PackageConfig, UnusablePackageReason)]
             -> IO a
trustFlagErr dflags flag reasons
  = packageFlagErr' dflags (pprTrustFlag flag) reasons

packageFlagErr' :: DynFlags
               -> SDoc
               -> [(PackageConfig, UnusablePackageReason)]
               -> IO a
packageFlagErr' dflags flag_doc reasons
  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
  where err = text "cannot satisfy " <> flag_doc <>
                (if null reasons then Outputable.empty else text ": ") $$
              nest 4 (ppr_reasons $$
                      text "(use -v for more information)")
        ppr_reasons = vcat (map ppr_reason reasons)
        ppr_reason (p, reason) =
            pprReason (ppr (unitId p) <+> text "is") reason

pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
    HidePackage p   -> text "-hide-package " <> text p
    ExposePackage doc _ _ -> text doc

pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag flag = case flag of
    TrustPackage p    -> text "-trust " <> text p
    DistrustPackage p -> text "-distrust " <> text p

-- -----------------------------------------------------------------------------
-- Wired-in packages

wired_in_pkgids :: [String]
wired_in_pkgids = map unitIdString wiredInUnitIds

type WiredPackagesMap = Map WiredUnitId WiredUnitId

findWiredInPackages
   :: DynFlags
   -> [PackageConfig]           -- database
   -> VisibilityMap             -- info on what packages are visible
                                -- for wired in selection
   -> IO ([PackageConfig],  -- package database updated for wired in
          WiredPackagesMap) -- map from unit id to wired identity

findWiredInPackages dflags pkgs vis_map = do
  --
  -- Now we must find our wired-in packages, and rename them to
  -- their canonical names (eg. base-1.0 ==> base).
  --
  let
        matches :: PackageConfig -> String -> Bool
        pc `matches` pid = packageNameString pc == pid

        -- find which package corresponds to each wired-in package
        -- delete any other packages with the same name
        -- update the package and any dependencies to point to the new
        -- one.
        --
        -- When choosing which package to map to a wired-in package
        -- name, we try to pick the latest version of exposed packages.
        -- However, if there are no exposed wired in packages available
        -- (e.g. -hide-all-packages was used), we can't bail: we *have*
        -- to assign a package for the wired-in package: so we try again
        -- with hidden packages included to (and pick the latest
        -- version).
        --
        -- You can also override the default choice by using -ignore-package:
        -- this works even when there is no exposed wired in package
        -- available.
        --
        findWiredInPackage :: [PackageConfig] -> String
                           -> IO (Maybe PackageConfig)
        findWiredInPackage pkgs wired_pkg =
           let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
               all_exposed_ps =
                    [ p | p <- all_ps
                        , Map.member (packageConfigId p) vis_map ] in
           case all_exposed_ps of
            [] -> case all_ps of
                       []   -> notfound
                       many -> pick (head (sortByVersion many))
            many -> pick (head (sortByVersion many))
          where
                notfound = do
                          debugTraceMsg dflags 2 $
                            text "wired-in package "
                                 <> text wired_pkg
                                 <> text " not found."
                          return Nothing
                pick :: PackageConfig
                     -> IO (Maybe PackageConfig)
                pick pkg = do
                        debugTraceMsg dflags 2 $
                            text "wired-in package "
                                 <> text wired_pkg
                                 <> text " mapped to "
                                 <> ppr (unitId pkg)
                        return (Just pkg)


  mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
  let