-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.ComponentsGraph (
    ComponentsGraph,
    ComponentsWithDeps,
    mkComponentsGraph,
    componentsGraphToList,
    dispComponentsWithDeps,
    componentCycleMsg
) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Package
import Distribution.PackageDescription as PD hiding (Flag)
import Distribution.Simple.BuildToolDepends
import Distribution.Simple.LocalBuildInfo
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.UnqualComponentName
import Distribution.Compat.Graph (Graph, Node(..))
import qualified Distribution.Compat.Graph as Graph

import Distribution.Pretty (pretty)
import Text.PrettyPrint

------------------------------------------------------------------------------
-- Components graph
------------------------------------------------------------------------------

-- | A graph of source-level components by their source-level
-- dependencies
--
type ComponentsGraph = Graph (Node ComponentName Component)

-- | A list of components associated with the source level
-- dependencies between them.
--
type ComponentsWithDeps = [(Component, [ComponentName])]

-- | Pretty-print 'ComponentsWithDeps'.
--
dispComponentsWithDeps :: ComponentsWithDeps -> Doc
dispComponentsWithDeps :: ComponentsWithDeps -> Doc
dispComponentsWithDeps ComponentsWithDeps
graph =
    [Doc] -> Doc
vcat [ Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"component" Doc -> Doc -> Doc
<+> ComponentName -> Doc
forall a. Pretty a => a -> Doc
pretty (Component -> ComponentName
componentName Component
c)) Int
4
                ([Doc] -> Doc
vcat [ String -> Doc
text String
"dependency" Doc -> Doc -> Doc
<+> ComponentName -> Doc
forall a. Pretty a => a -> Doc
pretty ComponentName
cdep | ComponentName
cdep <- [ComponentName]
cdeps ])
         | (Component
c, [ComponentName]
cdeps) <- ComponentsWithDeps
graph ]

-- | Create a 'Graph' of 'Component', or report a cycle if there is a
-- problem.
--
mkComponentsGraph :: ComponentRequestedSpec
                  -> PackageDescription
                  -> Either [ComponentName] ComponentsGraph
mkComponentsGraph :: ComponentRequestedSpec
-> PackageDescription -> Either [ComponentName] ComponentsGraph
mkComponentsGraph ComponentRequestedSpec
enabled PackageDescription
pkg_descr =
    let g :: ComponentsGraph
g = [Node ComponentName Component] -> ComponentsGraph
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList
                           [ Component
-> ComponentName -> [ComponentName] -> Node ComponentName Component
forall k a. a -> k -> [k] -> Node k a
N Component
c (Component -> ComponentName
componentName Component
c) (Component -> [ComponentName]
componentDeps Component
c)
                           | Component
c <- PackageDescription -> [Component]
pkgBuildableComponents PackageDescription
pkg_descr
                           , ComponentRequestedSpec -> Component -> Bool
componentEnabled ComponentRequestedSpec
enabled Component
c ]
    in case ComponentsGraph -> [[Node ComponentName Component]]
forall a. Graph a -> [[a]]
Graph.cycles ComponentsGraph
g of
          []     -> ComponentsGraph -> Either [ComponentName] ComponentsGraph
forall a b. b -> Either a b
Right ComponentsGraph
g
          [[Node ComponentName Component]]
ccycles -> [ComponentName] -> Either [ComponentName] ComponentsGraph
forall a b. a -> Either a b
Left  [ Component -> ComponentName
componentName Component
c | N Component
c ComponentName
_ [ComponentName]
_ <- [[Node ComponentName Component]] -> [Node ComponentName Component]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Node ComponentName Component]]
ccycles ]
  where
    -- The dependencies for the given component
    componentDeps :: Component -> [ComponentName]
componentDeps Component
component =
      (UnqualComponentName -> ComponentName
CExeName (UnqualComponentName -> ComponentName)
-> [UnqualComponentName] -> [ComponentName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageDescription -> BuildInfo -> [UnqualComponentName]
getAllInternalToolDependencies PackageDescription
pkg_descr BuildInfo
bi)

      [ComponentName] -> [ComponentName] -> [ComponentName]
forall a. [a] -> [a] -> [a]
++ [ if PackageName
pkgname PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageDescription -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageDescription
pkg_descr
           then LibraryName -> ComponentName
CLibName LibraryName
LMainLibName
           else LibraryName -> ComponentName
CLibName (UnqualComponentName -> LibraryName
LSubLibName UnqualComponentName
toolname)
         | Dependency PackageName
pkgname VersionRange
_ Set LibraryName
_ <- BuildInfo -> [Dependency]
targetBuildDepends BuildInfo
bi
         , let toolname :: UnqualComponentName
toolname = PackageName -> UnqualComponentName
packageNameToUnqualComponentName PackageName
pkgname
         , UnqualComponentName
toolname UnqualComponentName -> [UnqualComponentName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnqualComponentName]
internalPkgDeps ]
      where
        bi :: BuildInfo
bi = Component -> BuildInfo
componentBuildInfo Component
component
        internalPkgDeps :: [UnqualComponentName]
internalPkgDeps = (Library -> UnqualComponentName)
-> [Library] -> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map (LibraryName -> UnqualComponentName
conv (LibraryName -> UnqualComponentName)
-> (Library -> LibraryName) -> Library -> UnqualComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> LibraryName
libName) (PackageDescription -> [Library]
allLibraries PackageDescription
pkg_descr)

        conv :: LibraryName -> UnqualComponentName
conv LibraryName
LMainLibName    = PackageName -> UnqualComponentName
packageNameToUnqualComponentName (PackageName -> UnqualComponentName)
-> PackageName -> UnqualComponentName
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageDescription
pkg_descr
        conv (LSubLibName UnqualComponentName
s) = UnqualComponentName
s

-- | Given the package description and a 'PackageDescription' (used
-- to determine if a package name is internal or not), sort the
-- components in dependency order (fewest dependencies first).  This is
-- NOT necessarily the build order (although it is in the absence of
-- Backpack.)
--
componentsGraphToList :: ComponentsGraph
                      -> ComponentsWithDeps
componentsGraphToList :: ComponentsGraph -> ComponentsWithDeps
componentsGraphToList =
    (Node ComponentName Component -> (Component, [ComponentName]))
-> [Node ComponentName Component] -> ComponentsWithDeps
forall a b. (a -> b) -> [a] -> [b]
map (\(N Component
c ComponentName
_ [ComponentName]
cs) -> (Component
c, [ComponentName]
cs)) ([Node ComponentName Component] -> ComponentsWithDeps)
-> (ComponentsGraph -> [Node ComponentName Component])
-> ComponentsGraph
-> ComponentsWithDeps
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentsGraph -> [Node ComponentName Component]
forall a. Graph a -> [a]
Graph.revTopSort

-- | Error message when there is a cycle; takes the SCC of components.
componentCycleMsg :: [ComponentName] -> Doc
componentCycleMsg :: [ComponentName] -> Doc
componentCycleMsg [ComponentName]
cnames =
    String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"Components in the package depend on each other in a cyclic way:\n  "
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" depends on "
            [ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
showComponentName ComponentName
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
            | ComponentName
cname <- [ComponentName]
cnames [ComponentName] -> [ComponentName] -> [ComponentName]
forall a. [a] -> [a] -> [a]
++ [[ComponentName] -> ComponentName
forall a. [a] -> a
head [ComponentName]
cnames] ]