{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Utils.NubList
    ( NubList    -- opaque
    , toNubList  -- smart construtor
    , fromNubList
    , overNubList

    , NubListR
    , toNubListR
    , fromNubListR
    , overNubListR
    ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Simple.Utils

import qualified Text.Read as R

-- | NubList : A de-duplicated list that maintains the original order.
newtype NubList a =
    NubList { forall a. NubList a -> [a]
fromNubList :: [a] }
    deriving (NubList a -> NubList a -> Bool
(NubList a -> NubList a -> Bool)
-> (NubList a -> NubList a -> Bool) -> Eq (NubList a)
forall a. Eq a => NubList a -> NubList a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NubList a -> NubList a -> Bool
$c/= :: forall a. Eq a => NubList a -> NubList a -> Bool
== :: NubList a -> NubList a -> Bool
$c== :: forall a. Eq a => NubList a -> NubList a -> Bool
Eq, (forall x. NubList a -> Rep (NubList a) x)
-> (forall x. Rep (NubList a) x -> NubList a)
-> Generic (NubList a)
forall x. Rep (NubList a) x -> NubList a
forall x. NubList a -> Rep (NubList a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (NubList a) x -> NubList a
forall a x. NubList a -> Rep (NubList a) x
$cto :: forall a x. Rep (NubList a) x -> NubList a
$cfrom :: forall a x. NubList a -> Rep (NubList a) x
Generic, Typeable)

-- NubList assumes that nub retains the list order while removing duplicate
-- elements (keeping the first occurrence). Documentation for "Data.List.nub"
-- does not specifically state that ordering is maintained so we will add a test
-- for that to the test suite.

-- | Smart constructor for the NubList type.
toNubList :: Ord a => [a] -> NubList a
toNubList :: forall a. Ord a => [a] -> NubList a
toNubList [a]
list = [a] -> NubList a
forall a. [a] -> NubList a
NubList ([a] -> NubList a) -> [a] -> NubList a
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. Ord a => [a] -> [a]
ordNub [a]
list

-- | Lift a function over lists to a function over NubLists.
overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a
overNubList :: forall a. Ord a => ([a] -> [a]) -> NubList a -> NubList a
overNubList [a] -> [a]
f (NubList [a]
list) = [a] -> NubList a
forall a. Ord a => [a] -> NubList a
toNubList ([a] -> NubList a) -> ([a] -> [a]) -> [a] -> NubList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
f ([a] -> NubList a) -> [a] -> NubList a
forall a b. (a -> b) -> a -> b
$ [a]
list

-- | Monoid operations on NubLists.
-- For a valid Monoid instance we need to satistfy the required monoid laws;
-- identity, associativity and closure.
--
-- Identity : by inspection:
--      mempty `mappend` NubList xs == NubList xs `mappend` mempty
--
-- Associativity : by inspection:
--      (NubList xs `mappend` NubList ys) `mappend` NubList zs
--      == NubList xs `mappend` (NubList ys `mappend` NubList zs)
--
-- Closure : appending two lists of type a and removing duplicates obviously
-- does not change the type.

instance Ord a => Monoid (NubList a) where
    mempty :: NubList a
mempty = [a] -> NubList a
forall a. [a] -> NubList a
NubList []
    mappend :: NubList a -> NubList a -> NubList a
mappend = NubList a -> NubList a -> NubList a
forall a. Semigroup a => a -> a -> a
(<>)

instance Ord a => Semigroup (NubList a) where
    (NubList [a]
xs) <> :: NubList a -> NubList a -> NubList a
<> (NubList [a]
ys) = [a] -> NubList a
forall a. [a] -> NubList a
NubList ([a] -> NubList a) -> [a] -> NubList a
forall a b. (a -> b) -> a -> b
$ [a]
xs [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
`listUnion` [a]
ys

instance Show a => Show (NubList a) where
    show :: NubList a -> String
show (NubList [a]
list) = [a] -> String
forall a. Show a => a -> String
show [a]
list

instance (Ord a, Read a) => Read (NubList a) where
    readPrec :: ReadPrec (NubList a)
readPrec = ([a] -> NubList a) -> ReadPrec (NubList a)
forall a (l :: * -> *). Read a => ([a] -> l a) -> ReadPrec (l a)
readNubList [a] -> NubList a
forall a. Ord a => [a] -> NubList a
toNubList

-- | Helper used by NubList/NubListR's Read instances.
readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a)
readNubList :: forall a (l :: * -> *). Read a => ([a] -> l a) -> ReadPrec (l a)
readNubList [a] -> l a
listToL = ReadPrec (l a) -> ReadPrec (l a)
forall a. ReadPrec a -> ReadPrec a
R.parens (ReadPrec (l a) -> ReadPrec (l a))
-> (ReadPrec (l a) -> ReadPrec (l a))
-> ReadPrec (l a)
-> ReadPrec (l a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ReadPrec (l a) -> ReadPrec (l a)
forall a. Int -> ReadPrec a -> ReadPrec a
R.prec Int
10 (ReadPrec (l a) -> ReadPrec (l a))
-> ReadPrec (l a) -> ReadPrec (l a)
forall a b. (a -> b) -> a -> b
$ ([a] -> l a) -> ReadPrec [a] -> ReadPrec (l a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> l a
listToL ReadPrec [a]
forall a. Read a => ReadPrec a
R.readPrec

-- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we
-- just pull off constructor and put the list. For 'get', we get the list and
-- make a 'NubList' out of it using 'toNubList'.
instance (Ord a, Binary a) => Binary (NubList a) where
    put :: NubList a -> Put
put (NubList [a]
l) = [a] -> Put
forall t. Binary t => t -> Put
put [a]
l
    get :: Get (NubList a)
get = ([a] -> NubList a) -> Get [a] -> Get (NubList a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> NubList a
forall a. Ord a => [a] -> NubList a
toNubList Get [a]
forall t. Binary t => Get t
get

instance Structured a => Structured (NubList a)

-- | NubListR : A right-biased version of 'NubList'. That is @toNubListR
-- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@,
-- unlike the normal 'NubList', which is left-biased. Built on top of
-- 'ordNubRight' and 'listUnionRight'.
newtype NubListR a =
    NubListR { forall a. NubListR a -> [a]
fromNubListR :: [a] }
    deriving NubListR a -> NubListR a -> Bool
(NubListR a -> NubListR a -> Bool)
-> (NubListR a -> NubListR a -> Bool) -> Eq (NubListR a)
forall a. Eq a => NubListR a -> NubListR a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NubListR a -> NubListR a -> Bool
$c/= :: forall a. Eq a => NubListR a -> NubListR a -> Bool
== :: NubListR a -> NubListR a -> Bool
$c== :: forall a. Eq a => NubListR a -> NubListR a -> Bool
Eq

-- | Smart constructor for the NubListR type.
toNubListR :: Ord a => [a] -> NubListR a
toNubListR :: forall a. Ord a => [a] -> NubListR a
toNubListR [a]
list = [a] -> NubListR a
forall a. [a] -> NubListR a
NubListR ([a] -> NubListR a) -> [a] -> NubListR a
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. Ord a => [a] -> [a]
ordNubRight [a]
list

-- | Lift a function over lists to a function over NubListRs.
overNubListR :: Ord a => ([a] -> [a]) -> NubListR a -> NubListR a
overNubListR :: forall a. Ord a => ([a] -> [a]) -> NubListR a -> NubListR a
overNubListR [a] -> [a]
f (NubListR [a]
list) = [a] -> NubListR a
forall a. Ord a => [a] -> NubListR a
toNubListR ([a] -> NubListR a) -> ([a] -> [a]) -> [a] -> NubListR a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
f ([a] -> NubListR a) -> [a] -> NubListR a
forall a b. (a -> b) -> a -> b
$ [a]
list

instance Ord a => Monoid (NubListR a) where
  mempty :: NubListR a
mempty = [a] -> NubListR a
forall a. [a] -> NubListR a
NubListR []
  mappend :: NubListR a -> NubListR a -> NubListR a
mappend = NubListR a -> NubListR a -> NubListR a
forall a. Semigroup a => a -> a -> a
(<>)

instance Ord a => Semigroup (NubListR a) where
  (NubListR [a]
xs) <> :: NubListR a -> NubListR a -> NubListR a
<> (NubListR [a]
ys) = [a] -> NubListR a
forall a. [a] -> NubListR a
NubListR ([a] -> NubListR a) -> [a] -> NubListR a
forall a b. (a -> b) -> a -> b
$ [a]
xs [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
`listUnionRight` [a]
ys

instance Show a => Show (NubListR a) where
  show :: NubListR a -> String
show (NubListR [a]
list) = [a] -> String
forall a. Show a => a -> String
show [a]
list

instance (Ord a, Read a) => Read (NubListR a) where
    readPrec :: ReadPrec (NubListR a)
readPrec = ([a] -> NubListR a) -> ReadPrec (NubListR a)
forall a (l :: * -> *). Read a => ([a] -> l a) -> ReadPrec (l a)
readNubList [a] -> NubListR a
forall a. Ord a => [a] -> NubListR a
toNubListR