{-# LANGUAGE DeriveDataTypeable #-}
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
{-
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 { fromNubList :: [a] }
deriving (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 list = NubList $ (ordNubBy id) list
-- | Lift a function over lists to a function over NubLists.
overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a
overNubList f (NubList list) = toNubList . f $ list
instance Ord a => Monoid (NubList a) where
mempty = NubList []
(NubList xs) `mappend` (NubList ys) = NubList $ xs `listUnion` ys
where listUnion :: (Ord a) => [a] -> [a] -> [a]
listUnion a b = a ++ (ordNubBy id) (filter (`Set.notMember` (Set.fromList a)) b)
instance Show a => Show (NubList a) where
show (NubList list) = show list
instance (Ord a, Read a) => Read (NubList a) where
readPrec = readNubList toNubList
-- | Helper used by NubList/NubListR's Read instances.
readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a)
readNubList toList = R.parens . R.prec 10 $ fmap toList R.readPrec
ordNubBy :: Ord b => (a -> b) -> [a] -> [a]
ordNubBy f l = go Set.empty l
where
go !_ [] = []
go !s (x:xs)
| y `Set.member` s = go s xs
| otherwise = let !s' = Set.insert y s
in x : go s' xs
where
y = f x