Use UnionListsOrd instead of UnionLists in most places.wip/andreask/unionLists

This should get rid of most, if not all "Overlong lists" errors and fix #20016

3 files changed, 25 insertions, 9 deletions

diff --git a/compiler/GHC/Data/List/SetOps.hs b/compiler/GHC/Data/List/SetOps.hs
index 187d862b3d..dff41991da 100644
--- a/compiler/GHC/Data/List/SetOps.hs
+++ b/compiler/GHC/Data/List/SetOps.hs
@@ -12,7 +12,7 @@
 --
 -- Avoid using them as much as possible
 module GHC.Data.List.SetOps (
-        unionLists, minusList,
+        unionLists, unionListsOrd, minusList,
 
         -- Association lists
         Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
@@ -54,6 +54,19 @@ getNth xs n = assertPpr (xs `lengthExceeds` n) (ppr n $$ ppr xs) $
 -}
 
 
+
+-- | Combines the two lists while keeping their order, placing the first argument
+-- first in the result.
+--
+-- Uses a set internally to record duplicates. This makes it slightly slower for
+-- very small lists but avoids quadratic behaviour for large lists.
+unionListsOrd :: (HasDebugCallStack, Outputable a, Ord a) => [a] -> [a] -> [a]
+unionListsOrd xs ys
+  -- Since both arguments don't have internal duplicates we can just take all of xs
+  -- and every element of ys that's not already in xs.
+  = let set_ys = S.fromList ys
+    in (filter (\e -> not $ S.member e set_ys) xs) ++ ys
+
 -- | Assumes that the arguments contain no duplicates
 unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a]
 -- We special case some reasonable common patterns.
@@ -161,7 +174,7 @@ equivClasses cmp items   = NE.groupBy eq (L.sortBy cmp items)
     eq a b = case cmp a b of { EQ -> True; _ -> False }
 
 -- | Remove the duplicates from a list using the provided
--- comparison function.
+-- comparison function. Might change the order of elements.
 --
 -- Returns the list without duplicates, and accumulates
 -- all the duplicates in the second component of its result.
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 31e5f8ceed..dcf720e4a2 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -1412,9 +1412,9 @@ plusImportAvails
                    imp_trust_pkgs    = tpkgs1 `S.union` tpkgs2,
                    imp_trust_own_pkg = tself1 || tself2,
                    imp_boot_mods   = srs1 `plusModDeps` srcs2,
-                   imp_sig_mods      = sig_mods1 `unionLists` sig_mods2,
-                   imp_orphs         = orphs1 `unionLists` orphs2,
-                   imp_finsts        = finsts1 `unionLists` finsts2 }
+                   imp_sig_mods      = unionListsOrd sig_mods1 sig_mods2,
+                   imp_orphs         = unionListsOrd orphs1 orphs2,
+                   imp_finsts        = unionListsOrd finsts1 finsts2 }
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Types/Avail.hs b/compiler/GHC/Types/Avail.hs
index 487802687f..90e3d1a0c9 100644
--- a/compiler/GHC/Types/Avail.hs
+++ b/compiler/GHC/Types/Avail.hs
@@ -276,6 +276,9 @@ instance HasOccName GreName where
   occName (NormalGreName n) = occName n
   occName (FieldGreName fl) = occName fl
 
+instance Ord GreName where
+  compare = stableGreNameCmp
+
 -- | A 'Name' for internal use, but not for output to the user.  For fields, the
 -- 'OccName' will be the selector.  See Note [GreNames] in GHC.Types.Name.Reader.
 greNameMangledName :: GreName -> Name
@@ -315,10 +318,10 @@ plusAvail (AvailTC _ [])     a2@(AvailTC {})   = a2
 plusAvail a1@(AvailTC {})       (AvailTC _ []) = a1
 plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2))
   = case (NormalGreName n1==s1, NormalGreName n2==s2) of  -- Maintain invariant the parent is first
-       (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
-       (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
-       (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
-       (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
+       (True,True)   -> AvailTC n1 (s1 : (ss1 `unionListsOrd` ss2))
+       (True,False)  -> AvailTC n1 (s1 : (ss1 `unionListsOrd` (s2:ss2)))
+       (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionListsOrd` ss2))
+       (False,False) -> AvailTC n1 ((s1:ss1) `unionListsOrd` (s2:ss2))
 plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2])
 
 -- | trims an 'AvailInfo' to keep only a single name