src/Distribution/Compat/NonEmptySet.hs

    {-# LANGUAGE CPP                #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    module Distribution.Compat.NonEmptySet (
        NonEmptySet,
        -- * Construction
        singleton,
        -- * Insertion
        insert,
        -- * Deletion
        delete,
        -- * Conversions
        toNonEmpty,
        fromNonEmpty,
        toList,
        toSet,
        -- * Query
        member,
        -- * Map
        map,
    ) where

    import Prelude (Bool (..), Eq, Maybe (..), Ord (..), Read, Show (..), String, error, otherwise, return, showParen, showString, ($), (++), (.))

    import Control.DeepSeq    (NFData (..))
    import Data.Data          (Data)
    import Data.List.NonEmpty (NonEmpty (..))
    import Data.Semigroup     (Semigroup (..))
    import Data.Typeable      (Typeable)

    import qualified Data.Foldable as F
    import qualified Data.Set      as Set

    import Distribution.Compat.Binary    (Binary (..))
    import Distribution.Utils.Structured

    #if MIN_VERSION_binary(0,6,0)
    import Control.Applicative (empty)
    #else
    import Control.Monad (fail)
    #endif

    -- | @since 3.4.0.0
    newtype NonEmptySet a = NES (Set.Set a)
      deriving (Eq, Ord, Typeable, Data, Read)

    -------------------------------------------------------------------------------
    -- Instances
    -------------------------------------------------------------------------------

    instance Show a => Show (NonEmptySet a) where
        showsPrec d s = showParen (d > 10)
            $ showString "fromNonEmpty "
            . showsPrec 11 (toNonEmpty s)

    instance Binary a => Binary (NonEmptySet a) where
        put (NES s) = put s
        get = do
            xs <- get
            if Set.null xs
    #if MIN_VERSION_binary(0,6,0)
            then empty
    #else
            then fail "NonEmptySet: empty"
    #endif
            else return (NES xs)

    instance Structured a => Structured (NonEmptySet a) where
        structure = containerStructure

    instance NFData a => NFData (NonEmptySet a) where
        rnf (NES x) = rnf x

    -- | Note: there aren't @Monoid@ instance.
    instance Ord a => Semigroup (NonEmptySet a) where
        NES x <> NES y = NES (Set.union x y)

    instance F.Foldable NonEmptySet where
        foldMap f (NES s) = F.foldMap f s
        foldr f z (NES s) = F.foldr f z s

    #if MIN_VERSION_base(4,8,0)
        toList         = toList
        null _         = False
        length (NES s) = F.length s
    #endif

    -------------------------------------------------------------------------------
    -- Constructors
    -------------------------------------------------------------------------------

    singleton :: a -> NonEmptySet a
    singleton = NES . Set.singleton

    -------------------------------------------------------------------------------
    -- Insertion
    -------------------------------------------------------------------------------

    insert :: Ord a => a -> NonEmptySet a -> NonEmptySet a
    insert x (NES xs) = NES (Set.insert x xs)

    -------------------------------------------------------------------------------
    -- Deletion
    -------------------------------------------------------------------------------

    delete :: Ord a => a -> NonEmptySet a -> Maybe (NonEmptySet a)
    delete x (NES xs)
        | Set.null res = Nothing
        | otherwise    = Just (NES xs)
      where
        res = Set.delete x xs

    -------------------------------------------------------------------------------
    -- Conversions
    -------------------------------------------------------------------------------

    fromNonEmpty :: Ord a => NonEmpty a -> NonEmptySet a
    fromNonEmpty (x :| xs) = NES (Set.fromList (x : xs))

    toNonEmpty :: NonEmptySet a -> NonEmpty a
    toNonEmpty (NES s) = case Set.toList s of
        []   -> panic "toNonEmpty"
        x:xs -> x :| xs

    toList :: NonEmptySet a -> [a]
    toList (NES s) = Set.toList s

    toSet :: NonEmptySet a -> Set.Set a
    toSet (NES s) = s

    -------------------------------------------------------------------------------
    -- Query
    -------------------------------------------------------------------------------

    member :: Ord a => a -> NonEmptySet a -> Bool
    member x (NES xs) = Set.member x xs

    -------------------------------------------------------------------------------
    -- Map
    -------------------------------------------------------------------------------

    map
        :: ( Ord b
    #if !MIN_VERSION_containers(0,5,2)
           , Ord a
    #endif
           )
        => (a -> b) -> NonEmptySet a -> NonEmptySet b
    map f (NES x) = NES (Set.map f x)

    -------------------------------------------------------------------------------
    -- Internal
    -------------------------------------------------------------------------------

    panic :: String -> a
    panic msg = error $ "NonEmptySet invariant violated: " ++ msg