update to current master againwip/T13904

1 files changed, 84 insertions, 3 deletions

diff --git a/compiler/cmm/Hoopl/Collections.hs b/compiler/cmm/Hoopl/Collections.hs
index 679057626b..f8bdfda3d1 100644
--- a/compiler/cmm/Hoopl/Collections.hs
+++ b/compiler/cmm/Hoopl/Collections.hs
@@ -1,11 +1,22 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
 module Hoopl.Collections
     ( IsSet(..)
     , setInsertList, setDeleteList, setUnions
     , IsMap(..)
     , mapInsertList, mapDeleteList, mapUnions
+    , UniqueMap, UniqueSet
     ) where
 
+import GhcPrelude
+
+import qualified Data.IntMap.Strict as M
+import qualified Data.IntSet as S
+
 import Data.List (foldl', foldl1')
 
 class IsSet set where
@@ -25,7 +36,8 @@ class IsSet set where
   setIntersection :: set -> set -> set
   setIsSubsetOf :: set -> set -> Bool
 
-  setFold :: (ElemOf set -> b -> b) -> b -> set -> b
+  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b
+  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b
 
   setElems :: set -> [ElemOf set]
   setFromList :: [ElemOf set] -> set
@@ -56,6 +68,7 @@ class IsMap map where
   mapInsert :: KeyOf map -> a -> map a -> map a
   mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
   mapDelete :: KeyOf map -> map a -> map a
+  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
 
   mapUnion :: map a -> map a -> map a
   mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
@@ -65,8 +78,9 @@ class IsMap map where
 
   mapMap :: (a -> b) -> map a -> map b
   mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b
-  mapFold :: (a -> b -> b) -> b -> map a -> b
-  mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b
+  mapFoldl :: (b -> a -> b) -> b -> map a -> b
+  mapFoldr :: (a -> b -> b) -> b -> map a -> b
+  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b
   mapFilter :: (a -> Bool) -> map a -> map a
 
   mapElems :: map a -> [a]
@@ -85,3 +99,70 @@ mapDeleteList keys map = foldl' (flip mapDelete) map keys
 mapUnions :: IsMap map => [map a] -> map a
 mapUnions [] = mapEmpty
 mapUnions maps = foldl1' mapUnion maps
+
+-----------------------------------------------------------------------------
+-- Basic instances
+-----------------------------------------------------------------------------
+
+newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show)
+
+instance IsSet UniqueSet where
+  type ElemOf UniqueSet = Int
+
+  setNull (US s) = S.null s
+  setSize (US s) = S.size s
+  setMember k (US s) = S.member k s
+
+  setEmpty = US S.empty
+  setSingleton k = US (S.singleton k)
+  setInsert k (US s) = US (S.insert k s)
+  setDelete k (US s) = US (S.delete k s)
+
+  setUnion (US x) (US y) = US (S.union x y)
+  setDifference (US x) (US y) = US (S.difference x y)
+  setIntersection (US x) (US y) = US (S.intersection x y)
+  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
+
+  setFoldl k z (US s) = S.foldl' k z s
+  setFoldr k z (US s) = S.foldr k z s
+
+  setElems (US s) = S.elems s
+  setFromList ks = US (S.fromList ks)
+
+newtype UniqueMap v = UM (M.IntMap v)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap UniqueMap where
+  type KeyOf UniqueMap = Int
+
+  mapNull (UM m) = M.null m
+  mapSize (UM m) = M.size m
+  mapMember k (UM m) = M.member k m
+  mapLookup k (UM m) = M.lookup k m
+  mapFindWithDefault def k (UM m) = M.findWithDefault def k m
+
+  mapEmpty = UM M.empty
+  mapSingleton k v = UM (M.singleton k v)
+  mapInsert k v (UM m) = UM (M.insert k v m)
+  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
+  mapDelete k (UM m) = UM (M.delete k m)
+  mapAlter f k (UM m) = UM (M.alter f k m)
+
+  mapUnion (UM x) (UM y) = UM (M.union x y)
+  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)
+  mapDifference (UM x) (UM y) = UM (M.difference x y)
+  mapIntersection (UM x) (UM y) = UM (M.intersection x y)
+  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y
+
+  mapMap f (UM m) = UM (M.map f m)
+  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)
+  mapFoldl k z (UM m) = M.foldl' k z m
+  mapFoldr k z (UM m) = M.foldr k z m
+  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
+  mapFilter f (UM m) = UM (M.filter f m)
+
+  mapElems (UM m) = M.elems m
+  mapKeys (UM m) = M.keys m
+  mapToList (UM m) = M.toList m
+  mapFromList assocs = UM (M.fromList assocs)
+  mapFromListWith f assocs = UM (M.fromListWith f assocs)