{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | A module providing the type 'CompCollection' and associated helper

-- functions.

--

-- The corresponding Cabal approach uses lists. See, for example, the

-- 'Distribution.Types.PackageDescription.sublibraries',

-- 'Distribution.Types.PackageDescription.foreignLibs',

-- 'Distribution.Types.PackageDescription.executables',

-- 'Distribution.Types.PackageDescription.testSuites', and

-- 'Distribution.Types.PackageDescription.benchmarks' fields.

--

-- Cabal removes all the unbuildable components very early (at the cost of

-- slightly worse error messages).

module Stack.Types.CompCollection
  ( CompCollection
  , getBuildableSet
  , getBuildableSetText
  , getBuildableListText
  , getBuildableListAs
  , foldAndMakeCollection
  , hasBuildableComponent
  , collectionLookup
  , collectionKeyValueList
  , collectionMember
  , foldComponentToAnotherCollection
  ) where

import qualified Data.Map as M
import qualified Data.Set as Set
import           Stack.Prelude
import           Stack.Types.Component
                   ( HasBuildInfo, HasName, StackBuildInfo (..)
                   , StackUnqualCompName (..)
                   )

-- | A type representing collections of components, distinguishing buildable

-- components and non-buildable components.

data CompCollection component = CompCollection
  { forall component.
CompCollection component -> InnerCollection component
buildableOnes :: {-# UNPACK #-} !(InnerCollection component)
  , forall component.
CompCollection component -> Set StackUnqualCompName
unbuildableOnes :: Set StackUnqualCompName
    -- ^ The field is lazy beacause it should only serve when users explicitely

    -- require unbuildable components to be built. The field allows for

    -- intelligible error messages.

  }
  deriving (Int -> CompCollection component -> ShowS
[CompCollection component] -> ShowS
CompCollection component -> String
(Int -> CompCollection component -> ShowS)
-> (CompCollection component -> String)
-> ([CompCollection component] -> ShowS)
-> Show (CompCollection component)
forall component.
Show component =>
Int -> CompCollection component -> ShowS
forall component.
Show component =>
[CompCollection component] -> ShowS
forall component.
Show component =>
CompCollection component -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall component.
Show component =>
Int -> CompCollection component -> ShowS
showsPrec :: Int -> CompCollection component -> ShowS
$cshow :: forall component.
Show component =>
CompCollection component -> String
show :: CompCollection component -> String
$cshowList :: forall component.
Show component =>
[CompCollection component] -> ShowS
showList :: [CompCollection component] -> ShowS
Show)

instance Semigroup (CompCollection component) where
  CompCollection component
a <> :: CompCollection component
-> CompCollection component -> CompCollection component
<> CompCollection component
b = CompCollection
    { buildableOnes :: InnerCollection component
buildableOnes = CompCollection component
a.buildableOnes InnerCollection component
-> InnerCollection component -> InnerCollection component
forall a. Semigroup a => a -> a -> a
<> CompCollection component
b.buildableOnes
    , unbuildableOnes :: Set StackUnqualCompName
unbuildableOnes = CompCollection component
a.unbuildableOnes Set StackUnqualCompName
-> Set StackUnqualCompName -> Set StackUnqualCompName
forall a. Semigroup a => a -> a -> a
<> CompCollection component
b.unbuildableOnes
    }

instance Monoid (CompCollection component) where
  mempty :: CompCollection component
mempty = CompCollection
    { buildableOnes :: InnerCollection component
buildableOnes = InnerCollection component
forall a. Monoid a => a
mempty
    , unbuildableOnes :: Set StackUnqualCompName
unbuildableOnes = Set StackUnqualCompName
forall a. Monoid a => a
mempty
    }

instance Foldable CompCollection where
  foldMap :: forall m a. Monoid m => (a -> m) -> CompCollection a -> m
foldMap a -> m
fn CompCollection a
collection = (a -> m) -> Map StackUnqualCompName a -> m
forall m a. Monoid m => (a -> m) -> Map StackUnqualCompName a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
fn CompCollection a
collection.buildableOnes
  foldr' :: forall a b. (a -> b -> b) -> b -> CompCollection a -> b
foldr' a -> b -> b
fn b
c CompCollection a
collection = (a -> b -> b) -> b -> Map StackUnqualCompName a -> b
forall a b k. (a -> b -> b) -> b -> Map k a -> b
M.foldr' a -> b -> b
fn b
c CompCollection a
collection.buildableOnes
  null :: forall a. CompCollection a -> Bool
null = Map StackUnqualCompName a -> Bool
forall k a. Map k a -> Bool
M.null (Map StackUnqualCompName a -> Bool)
-> (CompCollection a -> Map StackUnqualCompName a)
-> CompCollection a
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.buildableOnes)

-- | The 'Data.HashMap.Strict.HashMap' type is a more suitable choice than 'Map'

-- for 'Data.Text.Text' based keys in general (it scales better). However,

-- constant factors are largely dominant for maps with less than 1000 keys.

-- Packages with more than 100 components are extremely unlikely, so we use a

-- 'Map'.

type InnerCollection component = Map StackUnqualCompName component

-- | A function to add a component to a collection of components. Ensures that

-- both 'asNameMap' and 'asNameSet' are updated consistently.

addComponent ::
     HasName component
  => component
     -- ^ Component to add.

  -> InnerCollection component
     -- ^ Existing collection of components.

  -> InnerCollection component
addComponent :: forall component.
HasName component =>
component -> InnerCollection component -> InnerCollection component
addComponent component
component = StackUnqualCompName
-> component
-> Map StackUnqualCompName component
-> Map StackUnqualCompName component
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert component
component.name component
component

-- | For the given function and foldable data structure of components of type

-- @compA@, iterates on the elements of that structure and maps each element to

-- a component of type @compB@ while building a 'CompCollection'.

foldAndMakeCollection ::
     (HasBuildInfo compB, HasName compB, Foldable sourceCollection)
  => (compA -> compB)
     -- ^ Function to apply to each element in the data struture.

  -> sourceCollection compA
     -- ^ Given foldable data structure of components of type @compA@.

  -> CompCollection compB
foldAndMakeCollection :: forall compB (sourceCollection :: * -> *) compA.
(HasBuildInfo compB, HasName compB, Foldable sourceCollection) =>
(compA -> compB) -> sourceCollection compA -> CompCollection compB
foldAndMakeCollection compA -> compB
mapFn = (CompCollection compB -> compA -> CompCollection compB)
-> CompCollection compB
-> sourceCollection compA
-> CompCollection compB
forall b a. (b -> a -> b) -> b -> sourceCollection a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CompCollection compB -> compA -> CompCollection compB
compIterator CompCollection compB
forall a. Monoid a => a
mempty
 where
  compIterator :: CompCollection compB -> compA -> CompCollection compB
compIterator CompCollection compB
existingCollection compA
component =
    CompCollection compB -> compB -> CompCollection compB
forall {r} {r}.
(HasField "name" r StackUnqualCompName,
 HasField "buildable" r Bool, HasField "buildInfo" r r) =>
CompCollection r -> r -> CompCollection r
compCreator CompCollection compB
existingCollection (compA -> compB
mapFn compA
component)
  compCreator :: CompCollection r -> r -> CompCollection r
compCreator CompCollection r
existingCollection r
component
    | r
component.buildInfo.buildable = CompCollection r
existingCollection
        { buildableOnes =
            addComponent component existingCollection.buildableOnes
        }
    | Bool
otherwise = CompCollection r
existingCollection
        { unbuildableOnes =
            Set.insert component.name existingCollection.unbuildableOnes
        }

-- | Get the names of the buildable components in the given collection, as a

-- 'Set' of 'StackUnqualCompName'.

getBuildableSet :: CompCollection component -> Set StackUnqualCompName
getBuildableSet :: forall component.
CompCollection component -> Set StackUnqualCompName
getBuildableSet = Map StackUnqualCompName component -> Set StackUnqualCompName
forall k a. Map k a -> Set k
M.keysSet (Map StackUnqualCompName component -> Set StackUnqualCompName)
-> (CompCollection component -> Map StackUnqualCompName component)
-> CompCollection component
-> Set StackUnqualCompName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.buildableOnes)

-- | Get the names of the buildable components in the given collection, as a

-- 'Set' of 'Text'.

getBuildableSetText :: CompCollection component -> Set Text
getBuildableSetText :: forall component. CompCollection component -> Set Text
getBuildableSetText = (StackUnqualCompName -> Text)
-> Set StackUnqualCompName -> Set Text
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic (.unqualCompToText) (Set StackUnqualCompName -> Set Text)
-> (CompCollection component -> Set StackUnqualCompName)
-> CompCollection component
-> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompCollection component -> Set StackUnqualCompName
forall component.
CompCollection component -> Set StackUnqualCompName
getBuildableSet

-- | Get the names of the buildable components in the given collection, as a

-- list of 'Text.

getBuildableListText :: CompCollection component -> [Text]
getBuildableListText :: forall component. CompCollection component -> [Text]
getBuildableListText = (StackUnqualCompName -> Text) -> CompCollection component -> [Text]
forall something component.
(StackUnqualCompName -> something)
-> CompCollection component -> [something]
getBuildableListAs (.unqualCompToText)

-- | Apply the given function to the names of the buildable components in the

-- given collection, yielding a list.

getBuildableListAs ::
     (StackUnqualCompName -> something)
     -- ^ Function to apply to buildable components.

  -> CompCollection component
     -- ^ Collection of components.

  -> [something]
getBuildableListAs :: forall something component.
(StackUnqualCompName -> something)
-> CompCollection component -> [something]
getBuildableListAs StackUnqualCompName -> something
fn = (StackUnqualCompName -> [something] -> [something])
-> [something] -> Set StackUnqualCompName -> [something]
forall a b. (a -> b -> b) -> b -> Set a -> b
Set.foldr' (\StackUnqualCompName
v [something]
l -> StackUnqualCompName -> something
fn StackUnqualCompName
vsomething -> [something] -> [something]
forall a. a -> [a] -> [a]
:[something]
l) [] (Set StackUnqualCompName -> [something])
-> (CompCollection component -> Set StackUnqualCompName)
-> CompCollection component
-> [something]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompCollection component -> Set StackUnqualCompName
forall component.
CompCollection component -> Set StackUnqualCompName
getBuildableSet

-- | Yields 'True' if, and only if, the given collection includes at least one

-- buildable component.

hasBuildableComponent :: CompCollection component -> Bool
hasBuildableComponent :: forall a. CompCollection a -> Bool
hasBuildableComponent = Bool -> Bool
not (Bool -> Bool)
-> (CompCollection component -> Bool)
-> CompCollection component
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set StackUnqualCompName -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set StackUnqualCompName -> Bool)
-> (CompCollection component -> Set StackUnqualCompName)
-> CompCollection component
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompCollection component -> Set StackUnqualCompName
forall component.
CompCollection component -> Set StackUnqualCompName
getBuildableSet

-- | For the given name of a buildable component and the given collection of

-- components, yields 'Just' @component@ if the collection includes a buildable

-- component of that name, and 'Nothing' otherwise.

collectionLookup ::
     Text
     -- ^ Name of the buildable component.

  -> CompCollection component
     -- ^ Collection of components.

  -> Maybe component
collectionLookup :: forall component.
Text -> CompCollection component -> Maybe component
collectionLookup Text
needle CompCollection component
haystack =
  StackUnqualCompName
-> Map StackUnqualCompName component -> Maybe component
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> StackUnqualCompName
StackUnqualCompName Text
needle) CompCollection component
haystack.buildableOnes

-- | For a given collection of components, yields a list of pairs for buildable

-- components of the name of the component and the component.

collectionKeyValueList :: CompCollection component -> [(Text, component)]
collectionKeyValueList :: forall component. CompCollection component -> [(Text, component)]
collectionKeyValueList CompCollection component
haystack =
      (\(StackUnqualCompName Text
k, !component
v) -> (Text
k, component
v))
  ((StackUnqualCompName, component) -> (Text, component))
-> [(StackUnqualCompName, component)] -> [(Text, component)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map StackUnqualCompName component
-> [(StackUnqualCompName, component)]
forall k a. Map k a -> [(k, a)]
M.toList CompCollection component
haystack.buildableOnes

-- | Yields 'True' if, and only if, the given collection of components includes

-- a buildable component with the given name.

collectionMember ::
     Text
     -- ^ Name of the buildable component.

  -> CompCollection component
     -- ^ Collection of components.

  -> Bool
collectionMember :: forall component. Text -> CompCollection component -> Bool
collectionMember Text
needle CompCollection component
haystack = Maybe component -> Bool
forall a. Maybe a -> Bool
isJust (Maybe component -> Bool) -> Maybe component -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> CompCollection component -> Maybe component
forall component.
Text -> CompCollection component -> Maybe component
collectionLookup Text
needle CompCollection component
haystack

-- | Reduce the buildable components of the given collection of components by

-- applying the given binary operator to all buildable components, using the

-- given starting value (typically the right-identity of the operator).

foldComponentToAnotherCollection ::
     (Monad m)
  => CompCollection component
     -- ^ Collection of components.

  -> (component -> m a -> m a)
     -- ^ Binary operator.

  -> m a
     -- ^ Starting value.

  -> m a
foldComponentToAnotherCollection :: forall (m :: * -> *) component a.
Monad m =>
CompCollection component -> (component -> m a -> m a) -> m a -> m a
foldComponentToAnotherCollection CompCollection component
collection component -> m a -> m a
fn m a
initialValue =
  (component -> m a -> m a)
-> m a -> Map StackUnqualCompName component -> m a
forall a b k. (a -> b -> b) -> b -> Map k a -> b
M.foldr' component -> m a -> m a
fn m a
initialValue CompCollection component
collection.buildableOnes