module Database.PostgreSQL.PQTypes.Utils.NubList
    ( NubList    -- opaque
    , toNubList  -- smart construtor
    , fromNubList
    , overNubList
    ) where

import Prelude
import Data.Monoid (Monoid(..))
import Data.Typeable

import qualified Text.Read as R
import qualified Data.Set as Set
import qualified Data.Semigroup as SG

{-
  This module is a copy-paste fork of Distribution.Utils.NubList in Cabal
  (Cabal-2.0.1.1 as it happens) to avoid depending on the whole of the Cabal
  library. `NubListR` was removed in the process and `ordNubBy` and `listUnion`
  hand-inlined to avoid depending on more Cabal-specific modules.
-}

-- | NubList : A de-duplicated list that maintains the original order.
newtype NubList a =
    NubList { 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, Typeable)

-- NubList assumes that nub retains the list order while removing duplicate
-- elements (keeping the first occurence). 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 :: [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) -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
ordNubBy a -> a
forall a. a -> a
id) [a]
list

-- | Lift a function over lists to a function over NubLists.
overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a
overNubList :: ([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

instance Ord a => SG.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 Ord a => [a] -> [a] -> [a]
[a] -> [a] -> [a]
`listUnion` [a]
ys
      where
        listUnion :: (Ord a) => [a] -> [a] -> [a]
        listUnion :: [a] -> [a] -> [a]
listUnion [a]
a [a]
b = [a]
a
          [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a -> a) -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
ordNubBy a -> a
forall a. a -> a
id ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` ([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
a)) [a]
b)


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
(SG.<>)

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 :: ([a] -> l a) -> ReadPrec (l a)
readNubList [a] -> l a
toList = 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
toList ReadPrec [a]
forall a. Read a => ReadPrec a
R.readPrec

ordNubBy :: Ord b => (a -> b) -> [a] -> [a]
ordNubBy :: (a -> b) -> [a] -> [a]
ordNubBy a -> b
f [a]
l = Set b -> [a] -> [a]
go Set b
forall a. Set a
Set.empty [a]
l
  where
    go :: Set b -> [a] -> [a]
go !Set b
_ [] = []
    go !Set b
s (a
x:[a]
xs)
      | b
y b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set b
s = Set b -> [a] -> [a]
go Set b
s [a]
xs
      | Bool
otherwise        = let !s' :: Set b
s' = b -> Set b -> Set b
forall a. Ord a => a -> Set a -> Set a
Set.insert b
y Set b
s
                            in a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set b -> [a] -> [a]
go Set b
s' [a]
xs
      where
        y :: b
y = a -> b
f a
x