CompCollection.hs

{-# 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
  { buildableOnes :: {-# UNPACK #-} !(InnerCollection component)
  , 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 (Show)

instance Semigroup (CompCollection component) where
  a <> b = CompCollection
    { buildableOnes = a.buildableOnes <> b.buildableOnes
    , unbuildableOnes = a.unbuildableOnes <> b.unbuildableOnes
    }

instance Monoid (CompCollection component) where
  mempty = CompCollection
    { buildableOnes = mempty
    , unbuildableOnes = mempty
    }

instance Foldable CompCollection where
  foldMap fn collection = foldMap fn collection.buildableOnes
  foldr' fn c collection = M.foldr' fn c collection.buildableOnes
  null = M.null . (.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 component = M.insert component.name 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 mapFn = foldl' compIterator mempty
 where
  compIterator existingCollection component =
    compCreator existingCollection (mapFn component)
  compCreator existingCollection component
    | component.buildInfo.buildable = existingCollection
        { buildableOnes =
            addComponent component existingCollection.buildableOnes
        }
    | otherwise = 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 = M.keysSet . (.buildableOnes)

-- | Get the names of the buildable components in the given collection, as a
-- 'Set' of 'Text'.
getBuildableSetText :: CompCollection component -> Set Text
getBuildableSetText = Set.mapMonotonic (.unqualCompToText) . getBuildableSet

-- | Get the names of the buildable components in the given collection, as a
-- list of 'Text.
getBuildableListText :: CompCollection component -> [Text]
getBuildableListText = 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 fn = Set.foldr' (\v l -> fn v:l) [] . getBuildableSet

-- | Yields 'True' if, and only if, the given collection includes at least one
-- buildable component.
hasBuildableComponent :: CompCollection component -> Bool
hasBuildableComponent = not . null . 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 needle haystack =
  M.lookup (StackUnqualCompName needle) 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 haystack =
      (\(StackUnqualCompName k, !v) -> (k, v))
  <$> M.toList 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 needle haystack = isJust $ collectionLookup needle 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 collection fn initialValue =
  M.foldr' fn initialValue collection.buildableOnes