GHC/Data/List/SetOps.hs

    {-
    (c) The University of Glasgow 2006
    (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

    -}

    {-# LANGUAGE CPP #-}

    -- | Set-like operations on lists
    --
    -- Avoid using them as much as possible
    module GHC.Data.List.SetOps (
            unionLists, minusList,

            -- Association lists
            Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,

            -- Duplicate handling
            hasNoDups, removeDups, findDupsEq,
            equivClasses,

            -- Indexing
            getNth
       ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Utils.Misc
    import GHC.Driver.Ppr

    import qualified Data.List as L
    import qualified Data.List.NonEmpty as NE
    import Data.List.NonEmpty (NonEmpty(..))
    import qualified Data.Set as S

    getNth :: Outputable a => [a] -> Int -> a
    getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
                 xs !! n

    {-
    ************************************************************************
    *                                                                      *
            Treating lists as sets
            Assumes the lists contain no duplicates, but are unordered
    *                                                                      *
    ************************************************************************
    -}

    -- | Assumes that the arguments contain no duplicates
    unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a]
    -- We special case some reasonable common patterns.
    unionLists xs [] = xs
    unionLists [] ys = ys
    unionLists [x] ys
      | isIn "unionLists" x ys = ys
      | otherwise = x:ys
    unionLists xs [y]
      | isIn "unionLists" y xs = xs
      | otherwise = y:xs
    unionLists xs ys
      = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys)
        [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys

    -- | Calculate the set difference of two lists. This is
    -- /O((m + n) log n)/, where we subtract a list of /n/ elements
    -- from a list of /m/ elements.
    --
    -- Extremely short cases are handled specially:
    -- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1,
    -- it takes /O(n)/ time.
    minusList :: Ord a => [a] -> [a] -> [a]
    -- There's no point building a set to perform just one lookup, so we handle
    -- extremely short lists specially. It might actually be better to use
    -- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5).
    -- The tipping point will be somewhere in the area of where /m/ and /log n/
    -- become comparable, but we probably don't want to work too hard on this.
    minusList [] _ = []
    minusList xs@[x] ys
      | x `elem` ys = []
      | otherwise = xs
    -- Using an empty set or a singleton would also be silly, so let's not.
    minusList xs [] = xs
    minusList xs [y] = filter (/= y) xs
    -- When each list has at least two elements, we build a set from the
    -- second argument, allowing us to filter the first argument fairly
    -- efficiently.
    minusList xs ys = filter (`S.notMember` yss) xs
      where
        yss = S.fromList ys

    {-
    ************************************************************************
    *                                                                      *
    \subsection[Utils-assoc]{Association lists}
    *                                                                      *
    ************************************************************************

    Inefficient finite maps based on association lists and equality.
    -}

    -- | A finite mapping based on equality and association lists.
    type Assoc a b = [(a,b)]

    assoc             :: (Eq a) => String -> Assoc a b -> a -> b
    assocDefault      :: (Eq a) => b -> Assoc a b -> a -> b
    assocUsing        :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b
    -- | Lookup key, fail gracefully using Nothing if not found.
    assocMaybe        :: (Eq a) => Assoc a b -> a -> Maybe b
    assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b

    assocDefaultUsing _  deflt []             _   = deflt
    assocDefaultUsing eq deflt ((k,v) : rest) key
      | k `eq` key = v
      | otherwise  = assocDefaultUsing eq deflt rest key

    assoc crash_msg         list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
    assocDefault deflt      list key = assocDefaultUsing (==) deflt list key
    assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key

    assocMaybe alist key
      = lookup alist
      where
        lookup []             = Nothing
        lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest

    {-
    ************************************************************************
    *                                                                      *
    \subsection[Utils-dups]{Duplicate-handling}
    *                                                                      *
    ************************************************************************
    -}

    hasNoDups :: (Eq a) => [a] -> Bool

    hasNoDups xs = f [] xs
      where
        f _           []     = True
        f seen_so_far (x:xs) = if x `is_elem` seen_so_far
                               then False
                               else f (x:seen_so_far) xs

        is_elem = isIn "hasNoDups"

    equivClasses :: (a -> a -> Ordering) -- Comparison
                 -> [a]
                 -> [NonEmpty a]

    equivClasses _   []      = []
    equivClasses _   [stuff] = [stuff :| []]
    equivClasses cmp items   = NE.groupBy eq (L.sortBy cmp items)
      where
        eq a b = case cmp a b of { EQ -> True; _ -> False }

    removeDups :: (a -> a -> Ordering) -- Comparison function
               -> [a]
               -> ([a],          -- List with no duplicates
                   [NonEmpty a]) -- List of duplicate groups.  One representative
                                 -- from each group appears in the first result

    removeDups _   []  = ([], [])
    removeDups _   [x] = ([x],[])
    removeDups cmp xs
      = case L.mapAccumR collect_dups [] (equivClasses cmp xs) of { (dups, xs') ->
        (xs', dups) }
      where
        collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a)
        collect_dups dups_so_far (x :| [])     = (dups_so_far,      x)
        collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x)

    findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a]
    findDupsEq _  [] = []
    findDupsEq eq (x:xs) | L.null eq_xs  = findDupsEq eq xs
                         | otherwise     = (x :| eq_xs) : findDupsEq eq neq_xs
        where (eq_xs, neq_xs) = L.partition (eq x) xs