Distribution/Backpack/ConfiguredComponent.hs

    {-# LANGUAGE PatternGuards #-}
    -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
    module Distribution.Backpack.ConfiguredComponent (
        ConfiguredComponent(..),
        cc_name,
        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.Dependency
    import Distribution.Types.IncludeRenaming
    import Distribution.Types.Mixin
    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 qualified Data.Set as Set
    import qualified Data.Map as Map
    import Data.Traversable
        ( mapAccumL )
    import Distribution.Text
    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 {
            -- | Uniquely identifies a configured component.
            cc_cid :: ComponentId,
            -- | The package this component came from.
            cc_pkgid :: PackageId,
            -- | 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 internal executables from @build-tools@.
            cc_internal_build_tools :: [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]
          }

    -- | 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 = componentName . cc_component

    -- | Pretty-print a 'ConfiguredComponent'.
    dispConfiguredComponent :: ConfiguredComponent -> Doc
    dispConfiguredComponent cc =
        hang (text "component" <+> disp (cc_cid cc)) 4
             (vcat [ hsep $ [ text "include", disp (ci_id incl), disp (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
        :: PackageId
        -> ComponentId
        -> [(PackageName, (ComponentId, PackageId))]
        -> [ComponentId]
        -> Component
        -> ConfiguredComponent
    mkConfiguredComponent this_pid this_cid lib_deps exe_deps component =
        ConfiguredComponent {
            cc_cid = this_cid,
            cc_pkgid = this_pid,
            cc_component = component,
            cc_public = is_public,
            cc_internal_build_tools = exe_deps,
            cc_includes = explicit_includes ++ implicit_includes
        }
      where
        bi = componentBuildInfo component
        deps_map = Map.fromList lib_deps

        -- Resolve each @mixins@ into the actual dependency
        -- from @lib_deps@.
        explicit_includes
            = [ let (cid, pid) =
                        case Map.lookup name deps_map of
                            Nothing ->
                                error $ "Mix-in refers to non-existent package " ++ display name ++
                                        " (did you forget to add the package to build-depends?)"
                            Just r  -> r
                in ComponentInclude {
                    ci_id       = cid,
                    -- TODO: We set pkgName = name here to make error messages
                    -- look better. But it would be better to properly
                    -- record component name here.
                    ci_pkgid    = pid { pkgName = name },
                    ci_renaming = rns,
                    ci_implicit = False
                   }
              | Mixin name rns <- mixins bi ]

        -- Any @build-depends@ which is not explicitly mentioned in
        -- @backpack-include@ is converted into an "implicit" include.
        used_explicitly = Set.fromList (map ci_id explicit_includes)
        implicit_includes
            = map (\(pn, (cid, pid)) -> ComponentInclude {
                                    ci_id = cid,
                                    -- See above ci_pkgid
                                    ci_pkgid = pid { pkgName = pn },
                                    ci_renaming = defaultIncludeRenaming,
                                    ci_implicit = True
                                  })
            $ filter (flip Set.notMember used_explicitly . fst . snd) lib_deps

        is_public = componentName component == CLibName

    type ConfiguredComponentMap =
            (Map PackageName (ComponentId, PackageId), -- libraries
             Map UnqualComponentName ComponentId)      -- executables

    -- Executable map must be different because an executable can
    -- have the same name as a library. Ew.

    -- | Given some ambient environment of package names that
    -- are "in scope", looks at the 'BuildInfo' to decide
    -- what the packages actually resolve to, and then builds
    -- a 'ConfiguredComponent'.
    toConfiguredComponent
        :: PackageDescription
        -> ComponentId
        -> Map PackageName (ComponentId, PackageId) -- external
        -> ConfiguredComponentMap
        -> Component
        -> ConfiguredComponent
    toConfiguredComponent pkg_descr this_cid
           external_lib_map (lib_map, exe_map) component =
        mkConfiguredComponent
           (package pkg_descr) this_cid
           lib_deps exe_deps component
      where
        bi = componentBuildInfo component
        find_it :: PackageName -> (ComponentId, PackageId)
        find_it name =
            fromMaybe (error ("toConfiguredComponent: " ++ display (packageName pkg_descr) ++
                                " " ++ display name)) $
                Map.lookup name lib_map <|>
                Map.lookup name external_lib_map
        lib_deps
            | newPackageDepsBehaviour pkg_descr
            = [ (name, find_it name)
              | Dependency name _ <- targetBuildDepends bi ]
            | otherwise
            = Map.toList external_lib_map
        exe_deps = [ cid
                   | toolName <- getAllInternalToolDependencies pkg_descr bi
                   , Just cid <- [ Map.lookup toolName exe_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
        -> Map PackageName (ComponentId, PackageId) -- external
        -> ConfiguredComponentMap
        -> Component
        -> ConfiguredComponent
    toConfiguredComponent' use_external_internal_deps flags
                    pkg_descr deterministic ipid_flag cid_flag
                    external_lib_map (lib_map, exe_map) component =
        let cc = toConfiguredComponent
                    pkg_descr this_cid
                    external_lib_map (lib_map, exe_map) component
        in if use_external_internal_deps
            then cc { cc_public = True }
            else cc
      where
        this_cid = computeComponentId deterministic ipid_flag cid_flag (package pkg_descr)
                    (componentName component) (Just (deps, flags))
        deps = [ cid | (cid, _) <- Map.elems external_lib_map ]

    extendConfiguredComponentMap
        :: ConfiguredComponent
        -> ConfiguredComponentMap
        -> ConfiguredComponentMap
    extendConfiguredComponentMap cc (lib_map, exe_map) =
        (lib_map', exe_map')
      where
        lib_map'
          = case cc_name cc of
              CLibName ->
                Map.insert (pkgName (cc_pkgid cc))
                           (cc_cid cc, cc_pkgid cc) lib_map
              CSubLibName str ->
                Map.insert (unqualComponentNameToPackageName str)
                           (cc_cid cc, cc_pkgid cc) lib_map
              _ -> lib_map
        exe_map'
          = case cc_name cc of
              CExeName str ->
                Map.insert str (cc_cid cc) exe_map
              _ -> exe_map

    -- 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.
    toConfiguredComponents
        :: Bool -- use_external_internal_deps
        -> FlagAssignment
        -> Bool -- deterministic
        -> Flag String -- configIPID
        -> Flag ComponentId -- configCID
        -> PackageDescription
        -> Map PackageName (ComponentId, PackageId)
        -> [Component]
        -> [ConfiguredComponent]
    toConfiguredComponents
        use_external_internal_deps flags deterministic ipid_flag cid_flag pkg_descr
        external_lib_map comps
        = snd (mapAccumL go (Map.empty, Map.empty) comps)
      where
        go m component = (extendConfiguredComponentMap cc m, cc)
          where cc = toConfiguredComponent'
                            use_external_internal_deps flags pkg_descr
                            deterministic ipid_flag cid_flag
                            external_lib_map m component

    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