ComponentDeps.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}

-- | Fine-grained package dependencies
--
-- Like many others, this module is meant to be "double-imported":
--
-- > import Distribution.Solver.Types.ComponentDeps (
-- >     Component
-- >   , ComponentDep
-- >   , ComponentDeps
-- >   )
-- > import qualified Distribution.Solver.Types.ComponentDeps as CD
module Distribution.Solver.Types.ComponentDeps (
    -- * Fine-grained package dependencies
    Component(..)
  , componentNameToComponent
  , ComponentDep
  , ComponentDeps -- opaque
    -- ** Constructing ComponentDeps
  , empty
  , fromList
  , singleton
  , insert
  , zip
  , filterDeps
  , fromLibraryDeps
  , fromSetupDeps
  , fromInstalled
    -- ** Deconstructing ComponentDeps
  , toList
  , flatDeps
  , nonSetupDeps
  , libraryDeps
  , setupDeps
  , select
  , components
  ) where

import Prelude ()
import Distribution.Types.UnqualComponentName
import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip)

import qualified Data.Map as Map
import Data.Foldable (fold)

import Distribution.Pretty (Pretty (..))
import qualified Distribution.Types.ComponentName as CN
import qualified Distribution.Types.LibraryName as LN
import qualified Text.PrettyPrint as PP


{-------------------------------------------------------------------------------
  Types
-------------------------------------------------------------------------------}

-- | Component of a package.
data Component =
    ComponentLib
  | ComponentSubLib UnqualComponentName
  | ComponentFLib   UnqualComponentName
  | ComponentExe    UnqualComponentName
  | ComponentTest   UnqualComponentName
  | ComponentBench  UnqualComponentName
  | ComponentSetup
  deriving (Show, Eq, Ord, Generic)

instance Binary Component
instance Structured Component

instance Pretty Component where
    pretty ComponentLib        = PP.text "lib"
    pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n
    pretty (ComponentFLib n)   = PP.text "flib:" <<>> pretty n
    pretty (ComponentExe n)    = PP.text "exe:" <<>> pretty n
    pretty (ComponentTest n)   = PP.text "test:" <<>> pretty n
    pretty (ComponentBench n)  = PP.text "bench:" <<>> pretty n
    pretty ComponentSetup      = PP.text "setup"

-- | Dependency for a single component.
type ComponentDep a = (Component, a)

-- | Fine-grained dependencies for a package.
--
-- Typically used as @ComponentDeps [Dependency]@, to represent the list of
-- dependencies for each named component within a package.
--
newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }
  deriving (Show, Functor, Eq, Ord, Generic)

instance Semigroup a => Monoid (ComponentDeps a) where
  mempty = ComponentDeps Map.empty
  mappend = (<>)

instance Semigroup a => Semigroup (ComponentDeps a) where
  ComponentDeps d <> ComponentDeps d' =
      ComponentDeps (Map.unionWith (<>) d d')

instance Foldable ComponentDeps where
  foldMap f = foldMap f . unComponentDeps

instance Traversable ComponentDeps where
  traverse f = fmap ComponentDeps . traverse f . unComponentDeps

instance Binary a => Binary (ComponentDeps a)
instance Structured a => Structured (ComponentDeps a)

componentNameToComponent :: CN.ComponentName -> Component
componentNameToComponent (CN.CLibName  LN.LMainLibName)   = ComponentLib
componentNameToComponent (CN.CLibName (LN.LSubLibName s)) = ComponentSubLib s
componentNameToComponent (CN.CFLibName                s)  = ComponentFLib   s
componentNameToComponent (CN.CExeName                 s)  = ComponentExe    s
componentNameToComponent (CN.CTestName                s)  = ComponentTest   s
componentNameToComponent (CN.CBenchName               s)  = ComponentBench  s

{-------------------------------------------------------------------------------
  Construction
-------------------------------------------------------------------------------}

empty :: ComponentDeps a
empty = ComponentDeps $ Map.empty

fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a
fromList = ComponentDeps . Map.fromListWith mappend

singleton :: Component -> a -> ComponentDeps a
singleton comp = ComponentDeps . Map.singleton comp

insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a
insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps
  where
    aux Nothing   = Just a
    aux (Just a') = Just $ a `mappend` a'

-- | Zip two 'ComponentDeps' together by 'Component', using 'mempty'
-- as the neutral element when a 'Component' is present only in one.
zip
  :: (Monoid a, Monoid b)
  => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b)
zip (ComponentDeps d1) (ComponentDeps d2) =
    ComponentDeps $
      Map.mergeWithKey
        (\_ a b -> Just (a,b))
        (fmap (\a -> (a, mempty)))
        (fmap (\b -> (mempty, b)))
        d1 d2

-- | Keep only selected components (and their associated deps info).
filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a
filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps

-- | ComponentDeps containing library dependencies only
fromLibraryDeps :: a -> ComponentDeps a
fromLibraryDeps = singleton ComponentLib

-- | ComponentDeps containing setup dependencies only.
fromSetupDeps :: a -> ComponentDeps a
fromSetupDeps = singleton ComponentSetup

-- | ComponentDeps for installed packages.
--
-- We assume that installed packages only record their library dependencies.
fromInstalled :: a -> ComponentDeps a
fromInstalled = fromLibraryDeps

{-------------------------------------------------------------------------------
  Deconstruction
-------------------------------------------------------------------------------}

toList :: ComponentDeps a -> [ComponentDep a]
toList = Map.toList . unComponentDeps

-- | All dependencies of a package.
--
-- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more
-- obvious than a use of 'fold', and moreover this avoids introducing lots of
-- @#ifdef@s for 7.10 just for the use of 'fold'.
flatDeps :: Monoid a => ComponentDeps a -> a
flatDeps = fold

-- | All dependencies except the setup dependencies.
--
-- Prior to the introduction of setup dependencies in version 1.24 this
-- would have been _all_ dependencies.
nonSetupDeps :: Monoid a => ComponentDeps a -> a
nonSetupDeps = select (/= ComponentSetup)

-- | Library dependencies proper only.  (Includes dependencies
-- of internal libraries.)
libraryDeps :: Monoid a => ComponentDeps a -> a
libraryDeps = select (\c -> case c of ComponentSubLib _ -> True
                                      ComponentLib -> True
                                      _ -> False)

-- | List components
components :: ComponentDeps a -> Set Component
components = Map.keysSet . unComponentDeps

-- | Setup dependencies.
setupDeps :: Monoid a => ComponentDeps a -> a
setupDeps = select (== ComponentSetup)

-- | Select dependencies satisfying a given predicate.
select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a
select p = foldMap snd . filter (p . fst) . toList