Cabal/src/Distribution/Utils/NubList.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4
   5 module Distribution.Utils.NubList
   6   ( NubList -- opaque
   7   , toNubList -- smart constructor
   8   , fromNubList
   9   , overNubList
  10   , NubListR
  11   , toNubListR
  12   , fromNubListR
  13   , overNubListR
  14   ) where
  15
  16 import Distribution.Compat.Prelude
  17 import Prelude ()
  18
  19 import Distribution.Simple.Utils
  20
  21 import qualified Text.Read as R
  22
  23 -- | NubList : A de-duplicated list that maintains the original order.
  24 newtype NubList a = NubList {fromNubList :: [a]}
  25   deriving (Eq, Generic, Typeable)
  26
  27 -- NubList assumes that nub retains the list order while removing duplicate
  28 -- elements (keeping the first occurrence). Documentation for "Data.List.nub"
  29 -- does not specifically state that ordering is maintained so we will add a test
  30 -- for that to the test suite.
  31
  32 -- | Smart constructor for the NubList type.
  33 toNubList :: Ord a => [a] -> NubList a
  34 toNubList list = NubList $ ordNub list
  35
  36 -- | Lift a function over lists to a function over NubLists.
  37 overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a
  38 overNubList f (NubList list) = toNubList . f $ list
  39
  40 -- | Monoid operations on NubLists.
  41 -- For a valid Monoid instance we need to satisfy the required monoid laws;
  42 -- identity, associativity and closure.
  43 --
  44 -- Identity : by inspection:
  45 --      mempty `mappend` NubList xs == NubList xs `mappend` mempty
  46 --
  47 -- Associativity : by inspection:
  48 --      (NubList xs `mappend` NubList ys) `mappend` NubList zs
  49 --      == NubList xs `mappend` (NubList ys `mappend` NubList zs)
  50 --
  51 -- Closure : appending two lists of type a and removing duplicates obviously
  52 -- does not change the type.
  53 instance Ord a => Monoid (NubList a) where
  54   mempty = NubList []
  55   mappend = (<>)
  56
  57 instance Ord a => Semigroup (NubList a) where
  58   (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys
  59
  60 instance Show a => Show (NubList a) where
  61   show (NubList list) = show list
  62
  63 instance (Ord a, Read a) => Read (NubList a) where
  64   readPrec = readNubList toNubList
  65
  66 -- | Helper used by NubList/NubListR's Read instances.
  67 readNubList :: Read a => ([a] -> l a) -> R.ReadPrec (l a)
  68 readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec
  69
  70 -- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we
  71 -- just pull off constructor and put the list. For 'get', we get the list and
  72 -- make a 'NubList' out of it using 'toNubList'.
  73 instance (Ord a, Binary a) => Binary (NubList a) where
  74   put (NubList l) = put l
  75   get = fmap toNubList get
  76
  77 instance Structured a => Structured (NubList a)
  78
  79 -- | NubListR : A right-biased version of 'NubList'. That is @toNubListR
  80 -- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@,
  81 -- unlike the normal 'NubList', which is left-biased. Built on top of
  82 -- 'ordNubRight' and 'listUnionRight'.
  83 newtype NubListR a = NubListR {fromNubListR :: [a]}
  84   deriving (Eq)
  85
  86 -- | Smart constructor for the NubListR type.
  87 toNubListR :: Ord a => [a] -> NubListR a
  88 toNubListR list = NubListR $ ordNubRight list
  89
  90 -- | Lift a function over lists to a function over NubListRs.
  91 overNubListR :: Ord a => ([a] -> [a]) -> NubListR a -> NubListR a
  92 overNubListR f (NubListR list) = toNubListR . f $ list
  93
  94 instance Ord a => Monoid (NubListR a) where
  95   mempty = NubListR []
  96   mappend = (<>)
  97
  98 instance Ord a => Semigroup (NubListR a) where
  99   (NubListR xs) <> (NubListR ys) = NubListR $ xs `listUnionRight` ys
 100
 101 instance Show a => Show (NubListR a) where
 102   show (NubListR list) = show list
 103
 104 instance (Ord a, Read a) => Read (NubListR a) where
 105   readPrec = readNubList toNubListR