ConfiguredComponent.hs

{-# LANGUAGE PatternGuards #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.ConfiguredComponent (
    ConfiguredComponent(..),
    cc_name,
    cc_cid,
    cc_pkgid,
    toConfiguredComponent,
    toConfiguredComponents,
    dispConfiguredComponent,

    ConfiguredComponentMap,
    extendConfiguredComponentMap,

    -- TODO: Should go somewhere else
    newPackageDepsBehaviour
) where

import Prelude ()
import Distribution.Compat.Prelude hiding ((<>))

import Distribution.Backpack.Id

import Distribution.Types.AnnotatedId
import Distribution.Types.Dependency
import Distribution.Types.ExeDependency
import Distribution.Types.IncludeRenaming
import Distribution.Types.ComponentId
import Distribution.Types.PackageId
import Distribution.Types.PackageName
import Distribution.Types.Mixin
import Distribution.Types.ComponentName
import Distribution.Types.LibraryName
import Distribution.Types.UnqualComponentName
import Distribution.Types.ComponentInclude
import Distribution.Package
import Distribution.PackageDescription as PD hiding (Flag)
import Distribution.Simple.BuildToolDepends
import Distribution.Simple.Setup as Setup
import Distribution.Simple.LocalBuildInfo
import Distribution.Version
import Distribution.Utils.LogProgress
import Distribution.Utils.MapAccum
import Distribution.Utils.Generic

import Control.Monad
import qualified Data.Set as Set
import qualified Data.Map as Map
import Distribution.Pretty
import Text.PrettyPrint

-- | A configured component, we know exactly what its 'ComponentId' is,
-- and the 'ComponentId's of the things it depends on.
data ConfiguredComponent
    = ConfiguredComponent {
        -- | Unique identifier of component, plus extra useful info.
        cc_ann_id :: AnnotatedId ComponentId,
        -- | The fragment of syntax from the Cabal file describing this
        -- component.
        cc_component :: Component,
        -- | Is this the public library component of the package?
        -- (If we invoke Setup with an instantiation, this is the
        -- component the instantiation applies to.)
        -- Note that in one-component configure mode, this is
        -- always True, because any component is the "public" one.)
        cc_public :: Bool,
        -- | Dependencies on executables from @build-tools@ and
        -- @build-tool-depends@.
        cc_exe_deps :: [AnnotatedId ComponentId],
        -- | The mixins of this package, including both explicit (from
        -- the @mixins@ field) and implicit (from @build-depends@).  Not
        -- mix-in linked yet; component configuration only looks at
        -- 'ComponentId's.
        cc_includes :: [ComponentInclude ComponentId IncludeRenaming]
      }


-- | Uniquely identifies a configured component.
cc_cid :: ConfiguredComponent -> ComponentId
cc_cid = ann_id . cc_ann_id

-- | The package this component came from.
cc_pkgid :: ConfiguredComponent -> PackageId
cc_pkgid = ann_pid . cc_ann_id

-- | The 'ComponentName' of a component; this uniquely identifies
-- a fragment of syntax within a specified Cabal file describing the
-- component.
cc_name :: ConfiguredComponent -> ComponentName
cc_name = ann_cname . cc_ann_id

-- | Pretty-print a 'ConfiguredComponent'.
dispConfiguredComponent :: ConfiguredComponent -> Doc
dispConfiguredComponent cc =
    hang (text "component" <+> pretty (cc_cid cc)) 4
         (vcat [ hsep $ [ text "include"
                        , pretty (ci_id incl), pretty (ci_renaming incl) ]
               | incl <- cc_includes cc
               ])

-- | Construct a 'ConfiguredComponent', given that the 'ComponentId'
-- and library/executable dependencies are known.  The primary
-- work this does is handling implicit @backpack-include@ fields.
mkConfiguredComponent
    :: PackageDescription
    -> ComponentId
    -> [AnnotatedId ComponentId] -- lib deps
    -> [AnnotatedId ComponentId] -- exe deps
    -> Component
    -> LogProgress ConfiguredComponent
mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do
    -- Resolve each @mixins@ into the actual dependency
    -- from @lib_deps@.
    explicit_includes <- forM (mixins bi) $ \(Mixin name rns) -> do
        let keys = fixFakePkgName pkg_descr name
        aid <- case Map.lookup keys deps_map of
                Nothing ->
                    dieProgress $
                    text "Mix-in refers to non-existent package" <+>
                    quotes (pretty name) $$
                    text "(did you forget to add the package to build-depends?)"
                Just r  -> return r
        return ComponentInclude {
                ci_ann_id   = aid,
                ci_renaming = rns,
                ci_implicit = False
            }

        -- Any @build-depends@ which is not explicitly mentioned in
        -- @backpack-include@ is converted into an "implicit" include.
    let used_explicitly = Set.fromList (map ci_id explicit_includes)
        implicit_includes
            = map (\aid -> ComponentInclude {
                                ci_ann_id = aid,
                                ci_renaming = defaultIncludeRenaming,
                                ci_implicit = True
                            })
            $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps

    return ConfiguredComponent {
            cc_ann_id = AnnotatedId {
                    ann_id = this_cid,
                    ann_pid = package pkg_descr,
                    ann_cname = componentName component
                },
            cc_component = component,
            cc_public = is_public,
            cc_exe_deps = exe_deps,
            cc_includes = explicit_includes ++ implicit_includes
        }
  where
    bi = componentBuildInfo component
    deps_map = Map.fromList [ ((packageName dep, ann_cname dep), dep)
                            | dep <- lib_deps ]
    is_public = componentName component == CLibName LMainLibName

type ConfiguredComponentMap =
        Map PackageName (Map ComponentName (AnnotatedId ComponentId))

toConfiguredComponent
    :: PackageDescription
    -> ComponentId
    -> ConfiguredComponentMap
    -> ConfiguredComponentMap
    -> Component
    -> LogProgress ConfiguredComponent
toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do
    lib_deps <-
        if newPackageDepsBehaviour pkg_descr
            then fmap concat $ forM (targetBuildDepends bi) $
                 \(Dependency name _ sublibs) -> do
                    -- The package name still needs fixing in case of legacy
                    -- sublibrary dependency syntax
                    let (pn, _) = fixFakePkgName pkg_descr name
                    pkg <- case Map.lookup pn lib_dep_map of
                        Nothing ->
                            dieProgress $
                                text "Dependency on unbuildable" <+>
                                text "package" <+> pretty pn
                        Just p -> return p
                    -- Return all library components
                    forM (Set.toList sublibs) $ \lib ->
                        let comp = CLibName lib in
                        case Map.lookup (CLibName $ LSubLibName $
                                         packageNameToUnqualComponentName name) pkg
                         <|> Map.lookup comp pkg
                        of
                            Nothing ->
                                dieProgress $
                                    text "Dependency on unbuildable" <+>
                                    text (showLibraryName lib) <+>
                                    text "from" <+> pretty pn
                            Just v -> return v
            else return old_style_lib_deps
    mkConfiguredComponent
       pkg_descr this_cid
       lib_deps exe_deps component
  where
    bi = componentBuildInfo component
    -- lib_dep_map contains a mix of internal and external deps.
    -- We want all the public libraries (dep_cn == CLibName)
    -- of all external deps (dep /= pn).  Note that this
    -- excludes the public library of the current package:
    -- this is not supported by old-style deps behavior
    -- because it would imply a cyclic dependency for the
    -- library itself.
    old_style_lib_deps = [ e
                         | (pn, comp_map) <- Map.toList lib_dep_map
                         , pn /= packageName pkg_descr
                         , (cn, e) <- Map.toList comp_map
                         , cn == CLibName LMainLibName ]
    -- We have to nub here, because 'getAllToolDependencies' may return
    -- duplicates (see #4986).  (NB: This is not needed for lib_deps,
    -- since those elaborate into includes, for which there explicitly
    -- may be multiple instances of a package)
    exe_deps = ordNub $
        [ exe
        | ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi
        -- The error suppression here is important, because in general
        -- we won't know about external dependencies (e.g., 'happy')
        -- which the package is attempting to use (those deps are only
        -- fed in when cabal-install uses this codepath.)
        -- TODO: Let cabal-install request errors here
        , Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map]
        ]

-- | Also computes the 'ComponentId', and sets cc_public if necessary.
-- This is Cabal-only; cabal-install won't use this.
toConfiguredComponent'
    :: Bool -- use_external_internal_deps
    -> FlagAssignment
    -> PackageDescription
    -> Bool -- deterministic
    -> Flag String      -- configIPID (todo: remove me)
    -> Flag ComponentId -- configCID
    -> ConfiguredComponentMap
    -> Component
    -> LogProgress ConfiguredComponent
toConfiguredComponent' use_external_internal_deps flags
                pkg_descr deterministic ipid_flag cid_flag
                dep_map component = do
    cc <- toConfiguredComponent
                pkg_descr this_cid
                dep_map dep_map component
    return $ if use_external_internal_deps
                then cc { cc_public = True }
                else cc
  where
    -- TODO: pass component names to it too!
    this_cid = computeComponentId deterministic ipid_flag cid_flag
                (package pkg_descr) (componentName component) (Just (deps, flags))
    deps = [ ann_id aid | m <- Map.elems dep_map
                        , aid <- Map.elems m ]

extendConfiguredComponentMap
    :: ConfiguredComponent
    -> ConfiguredComponentMap
    -> ConfiguredComponentMap
extendConfiguredComponentMap cc =
    Map.insertWith Map.union
        (pkgName (cc_pkgid cc))
        (Map.singleton (cc_name cc) (cc_ann_id cc))

-- Compute the 'ComponentId's for a graph of 'Component's.  The
-- list of internal components must be topologically sorted
-- based on internal package dependencies, so that any internal
-- dependency points to an entry earlier in the list.
--
-- TODO: This function currently restricts the input configured components to
-- one version per package, by using the type ConfiguredComponentMap.  It cannot
-- be used to configure a component that depends on one version of a package for
-- a library and another version for a build-tool.
toConfiguredComponents
    :: Bool -- use_external_internal_deps
    -> FlagAssignment
    -> Bool -- deterministic
    -> Flag String -- configIPID
    -> Flag ComponentId -- configCID
    -> PackageDescription
    -> ConfiguredComponentMap
    -> [Component]
    -> LogProgress [ConfiguredComponent]
toConfiguredComponents
    use_external_internal_deps flags deterministic ipid_flag cid_flag pkg_descr
    dep_map comps
    = fmap snd (mapAccumM go dep_map comps)
  where
    go m component = do
        cc <- toConfiguredComponent'
                        use_external_internal_deps flags pkg_descr
                        deterministic ipid_flag cid_flag
                        m component
        return (extendConfiguredComponentMap cc m, cc)

newPackageDepsBehaviourMinVersion :: Version
newPackageDepsBehaviourMinVersion = mkVersion [1,7,1]


-- In older cabal versions, there was only one set of package dependencies for
-- the whole package. In this version, we can have separate dependencies per
-- target, but we only enable this behaviour if the minimum cabal version
-- specified is >= a certain minimum. Otherwise, for compatibility we use the
-- old behaviour.
newPackageDepsBehaviour :: PackageDescription -> Bool
newPackageDepsBehaviour pkg =
   specVersion pkg >= newPackageDepsBehaviourMinVersion

-- | 'build-depends:' stanzas are currently ambiguous as the external packages
-- and internal libraries are specified the same. For now, we assume internal
-- libraries shadow, and this function disambiguates accordingly, but soon the
-- underlying ambiguity will be addressed.
-- Multiple public libraries (cabal 3.0) added an unambiguous way of specifying
-- sublibraries, but we still have to support the old syntax for bc reasons.
fixFakePkgName :: PackageDescription -> PackageName -> (PackageName, ComponentName)
fixFakePkgName pkg_descr pn =
  if subLibName `elem` internalLibraries
  then (packageName pkg_descr, CLibName (LSubLibName subLibName))
  else (pn,                    CLibName LMainLibName            )
  where
    subLibName        = packageNameToUnqualComponentName pn
    internalLibraries = mapMaybe (libraryNameString . libName)
                        (allLibraries pkg_descr)