From 28b12850dd34930a9d1bc3a22b6bc7e6f5dd480a Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Mon, 1 Apr 2019 22:26:23 -0400
Subject: [PATCH] Create NonEmptySet type

---
 Data/Map/Internal.hs        |   7 +-
 Data/Map/Strict/Internal.hs |   3 +-
 Data/Set.hs                 |   1 +
 Data/Set/Internal.hs        | 315 ++++++++++++++++++++----------------
 tests/set-properties.hs     |   6 +-
 5 files changed, 188 insertions(+), 144 deletions(-)

diff --git a/Data/Map/Internal.hs b/Data/Map/Internal.hs
index 2c681c079..2cb689951 100644
--- a/Data/Map/Internal.hs
+++ b/Data/Map/Internal.hs
@@ -1923,7 +1923,7 @@ difference t1 (Bin (NonEmptyMap _ k _ l2 r2)) = case split k t1 of
 withoutKeys :: Ord k => Map k a -> Set k -> Map k a
 withoutKeys Tip _ = Tip
 withoutKeys m Set.Tip = m
-withoutKeys m (Set.Bin _ k ls rs) = case splitMember k m of
+withoutKeys m (Set.Bin (Set.NonEmptySet _ k ls rs)) = case splitMember k m of
   (lm, b, rm)
      | not b && lm' `ptrEq` lm && rm' `ptrEq` rm -> m
      | otherwise -> link2 lm' rm'
@@ -3316,7 +3316,8 @@ assocs m
 
 keysSet :: Map k a -> Set.Set k
 keysSet Tip = Set.Tip
-keysSet (Bin (NonEmptyMap sz kx _ l r)) = Set.Bin sz kx (keysSet l) (keysSet r)
+keysSet (Bin (NonEmptyMap sz kx _ l r)) = Set.Bin $
+  Set.NonEmptySet sz kx (keysSet l) (keysSet r)
 
 -- | /O(n)/. Build a map from a set of keys and a function which for each key
 -- computes its value.
@@ -3326,7 +3327,7 @@ keysSet (Bin (NonEmptyMap sz kx _ l r)) = Set.Bin sz kx (keysSet l) (keysSet r)
 
 fromSet :: (k -> a) -> Set.Set k -> Map k a
 fromSet _ Set.Tip = Tip
-fromSet f (Set.Bin sz x l r) = Bin $ NonEmptyMap sz x (f x) (fromSet f l) (fromSet f r)
+fromSet f (Set.Bin (Set.NonEmptySet sz x l r)) = Bin $ NonEmptyMap sz x (f x) (fromSet f l) (fromSet f r)
 
 {--------------------------------------------------------------------
   Lists
diff --git a/Data/Map/Strict/Internal.hs b/Data/Map/Strict/Internal.hs
index a2ca1e5e1..53a569042 100644
--- a/Data/Map/Strict/Internal.hs
+++ b/Data/Map/Strict/Internal.hs
@@ -1467,7 +1467,8 @@ mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []
 
 fromSet :: (k -> a) -> Set.Set k -> Map k a
 fromSet _ Set.Tip = Tip
-fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin (NonEmptyMap sz x v (fromSet f l) (fromSet f r))
+fromSet f (Set.Bin (Set.NonEmptySet sz x l r)) = case f x of
+  v -> v `seq` Bin (NonEmptyMap sz x v (fromSet f l) (fromSet f r))
 
 {--------------------------------------------------------------------
   Lists
diff --git a/Data/Set.hs b/Data/Set.hs
index 2dea90b52..c74b10af6 100644
--- a/Data/Set.hs
+++ b/Data/Set.hs
@@ -70,6 +70,7 @@ module Data.Set (
               Set          -- instance Eq,Ord,Show,Read,Data,Typeable
 #else
               Set(..)
+            , NonEmptySet(..)
 #endif
 
             -- * Construction
diff --git a/Data/Set/Internal.hs b/Data/Set/Internal.hs
index a6ee13ca1..49c9a550f 100644
--- a/Data/Set/Internal.hs
+++ b/Data/Set/Internal.hs
@@ -124,7 +124,8 @@
 
 module Data.Set.Internal (
             -- * Set type
-              Set(..)       -- instance Eq,Ord,Show,Read,Data,Typeable
+              Set(..)         -- instance Eq,Ord,Show,Read,Data,Typeable
+            , NonEmptySet(..) -- instance Eq,Ord,Show,Read,Data,Typeable
             , Size
 
             -- * Operators
@@ -284,9 +285,11 @@ m1 \\ m2 = difference m1 m2
 -- | A set of values @a@.
 
 -- See Note: Order of constructors
-data Set a    = Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a)
+data Set a    = Bin {-# UNPACK #-} !(NonEmptySet a)
               | Tip
 
+data NonEmptySet a = NonEmptySet {-# UNPACK #-} !Size !a !(Set a) !(Set a)
+
 type Size     = Int
 
 #if __GLASGOW_HASKELL__ >= 708
@@ -311,8 +314,8 @@ instance Ord a => Semigroup (Set a) where
 instance Foldable.Foldable Set where
     fold = go
       where go Tip = mempty
-            go (Bin 1 k _ _) = k
-            go (Bin _ k l r) = go l `mappend` (k `mappend` go r)
+            go (Bin (NonEmptySet  1 k _ _)) = k
+            go (Bin (NonEmptySet  _ k l r)) = go l `mappend` (k `mappend` go r)
     {-# INLINABLE fold #-}
     foldr = foldr
     {-# INLINE foldr #-}
@@ -320,8 +323,8 @@ instance Foldable.Foldable Set where
     {-# INLINE foldl #-}
     foldMap f t = go t
       where go Tip = mempty
-            go (Bin 1 k _ _) = f k
-            go (Bin _ k l r) = go l `mappend` (f k `mappend` go r)
+            go (Bin (NonEmptySet  1 k _ _)) = f k
+            go (Bin (NonEmptySet  _ k l r)) = go l `mappend` (f k `mappend` go r)
     {-# INLINE foldMap #-}
     foldl' = foldl'
     {-# INLINE foldl' #-}
@@ -336,7 +339,7 @@ instance Foldable.Foldable Set where
     {-# INLINE toList #-}
     elem = go
       where go !_ Tip = False
-            go x (Bin _ y l r) = x == y || go x l || go x r
+            go x (Bin (NonEmptySet _ y l r)) = x == y || go x l || go x r
     {-# INLINABLE elem #-}
     minimum = findMin
     {-# INLINE minimum #-}
@@ -381,13 +384,13 @@ setDataType = mkDataType "Data.Set.Internal.Set" [fromListConstr]
 -- | /O(1)/. Is this the empty set?
 null :: Set a -> Bool
 null Tip      = True
-null (Bin {}) = False
+null (Bin (NonEmptySet {})) = False
 {-# INLINE null #-}
 
 -- | /O(1)/. The number of elements in the set.
 size :: Set a -> Int
 size Tip = 0
-size (Bin sz _ _ _) = sz
+size (Bin (NonEmptySet sz _ _ _)) = sz
 {-# INLINE size #-}
 
 -- | /O(log n)/. Is the element in the set?
@@ -395,7 +398,7 @@ member :: Ord a => a -> Set a -> Bool
 member = go
   where
     go !_ Tip = False
-    go x (Bin _ y l r) = case compare x y of
+    go x (Bin (NonEmptySet _ y l r)) = case compare x y of
       LT -> go x l
       GT -> go x r
       EQ -> True
@@ -422,12 +425,15 @@ lookupLT :: Ord a => a -> Set a -> Maybe a
 lookupLT = goNothing
   where
     goNothing !_ Tip = Nothing
-    goNothing x (Bin _ y l r) | x <= y = goNothing x l
-                              | otherwise = goJust x y r
+    goNothing x (Bin (NonEmptySet _ y l r))
+        | x <= y = goNothing x l
+        | otherwise = goJust x y r
 
     goJust !_ best Tip = Just best
-    goJust x best (Bin _ y l r) | x <= y = goJust x best l
-                                | otherwise = goJust x y r
+    goJust x best (Bin (NonEmptySet _ y l r))
+      | x <= y = goJust x best l
+      | otherwise = goJust x y r
+
 #if __GLASGOW_HASKELL__
 {-# INLINABLE lookupLT #-}
 #else
@@ -442,12 +448,15 @@ lookupGT :: Ord a => a -> Set a -> Maybe a
 lookupGT = goNothing
   where
     goNothing !_ Tip = Nothing
-    goNothing x (Bin _ y l r) | x < y = goJust x y l
-                              | otherwise = goNothing x r
+    goNothing x (Bin (NonEmptySet _ y l r))
+        | x < y = goJust x y l
+        | otherwise = goNothing x r
 
     goJust !_ best Tip = Just best
-    goJust x best (Bin _ y l r) | x < y = goJust x y l
-                                | otherwise = goJust x best r
+    goJust x best (Bin (NonEmptySet _ y l r))
+        | x < y = goJust x y l
+        | otherwise = goJust x best r
+
 #if __GLASGOW_HASKELL__
 {-# INLINABLE lookupGT #-}
 #else
@@ -463,14 +472,17 @@ lookupLE :: Ord a => a -> Set a -> Maybe a
 lookupLE = goNothing
   where
     goNothing !_ Tip = Nothing
-    goNothing x (Bin _ y l r) = case compare x y of LT -> goNothing x l
-                                                    EQ -> Just y
-                                                    GT -> goJust x y r
+    goNothing x (Bin (NonEmptySet _ y l r)) = case compare x y of
+        LT -> goNothing x l
+        EQ -> Just y
+        GT -> goJust x y r
 
     goJust !_ best Tip = Just best
-    goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x best l
-                                                      EQ -> Just y
-                                                      GT -> goJust x y r
+    goJust x best (Bin (NonEmptySet _ y l r)) = case compare x y of
+        LT -> goJust x best l
+        EQ -> Just y
+        GT -> goJust x y r
+
 #if __GLASGOW_HASKELL__
 {-# INLINABLE lookupLE #-}
 #else
@@ -486,14 +498,17 @@ lookupGE :: Ord a => a -> Set a -> Maybe a
 lookupGE = goNothing
   where
     goNothing !_ Tip = Nothing
-    goNothing x (Bin _ y l r) = case compare x y of LT -> goJust x y l
-                                                    EQ -> Just y
-                                                    GT -> goNothing x r
+    goNothing x (Bin (NonEmptySet _ y l r)) = case compare x y of
+        LT -> goJust x y l
+        EQ -> Just y
+        GT -> goNothing x r
 
     goJust !_ best Tip = Just best
-    goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x y l
-                                                      EQ -> Just y
-                                                      GT -> goJust x best r
+    goJust x best (Bin (NonEmptySet _ y l r)) = case compare x y of
+        LT -> goJust x y l
+        EQ -> Just y
+        GT -> goJust x best r
+
 #if __GLASGOW_HASKELL__
 {-# INLINABLE lookupGE #-}
 #else
@@ -510,7 +525,7 @@ empty = Tip
 
 -- | /O(1)/. Create a singleton set.
 singleton :: a -> Set a
-singleton x = Bin 1 x Tip Tip
+singleton x = Bin $ NonEmptySet 1 x Tip Tip
 {-# INLINE singleton #-}
 
 {--------------------------------------------------------------------
@@ -527,7 +542,7 @@ insert x0 = go x0 x0
   where
     go :: Ord a => a -> a -> Set a -> Set a
     go orig !_ Tip = singleton (lazy orig)
-    go orig !x t@(Bin sz y l r) = case compare x y of
+    go orig !x t@(Bin (NonEmptySet sz y l r)) = case compare x y of
         LT | l' `ptrEq` l -> t
            | otherwise -> balanceL y l' r
            where !l' = go orig x l
@@ -535,7 +550,7 @@ insert x0 = go x0 x0
            | otherwise -> balanceR y l r'
            where !r' = go orig x r
         EQ | lazy orig `seq` (orig `ptrEq` y) -> t
-           | otherwise -> Bin sz (lazy orig) l r
+           | otherwise -> Bin $ NonEmptySet sz (lazy orig) l r
 #if __GLASGOW_HASKELL__
 {-# INLINABLE insert #-}
 #else
@@ -557,7 +572,7 @@ insertR x0 = go x0 x0
   where
     go :: Ord a => a -> a -> Set a -> Set a
     go orig !_ Tip = singleton (lazy orig)
-    go orig !x t@(Bin _ y l r) = case compare x y of
+    go orig !x t@(Bin (NonEmptySet _ y l r)) = case compare x y of
         LT | l' `ptrEq` l -> t
            | otherwise -> balanceL y l' r
            where !l' = go orig x l
@@ -579,7 +594,7 @@ delete = go
   where
     go :: Ord a => a -> Set a -> Set a
     go !_ Tip = Tip
-    go x t@(Bin _ y l r) = case compare x y of
+    go x t@(Bin (NonEmptySet _ y l r)) = case compare x y of
         LT | l' `ptrEq` l -> t
            | otherwise -> balanceR y l' r
            where !l' = go x l
@@ -617,7 +632,7 @@ isSubsetOf t1 t2
 isSubsetOfX :: Ord a => Set a -> Set a -> Bool
 isSubsetOfX Tip _ = True
 isSubsetOfX _ Tip = False
-isSubsetOfX (Bin _ x l r) t
+isSubsetOfX (Bin (NonEmptySet _ x l r)) t
   = found && isSubsetOfX l lt && isSubsetOfX r gt
   where
     (lt,found,gt) = splitMember x t
@@ -641,7 +656,7 @@ isSubsetOfX (Bin _ x l r) t
 disjoint :: Ord a => Set a -> Set a -> Bool
 disjoint Tip _ = True
 disjoint _ Tip = True
-disjoint (Bin _ x l r) t
+disjoint (Bin (NonEmptySet _ x l r)) t
   -- Analogous implementation to `subsetOfX`
   = not found && disjoint l lt && disjoint r gt
   where
@@ -657,7 +672,7 @@ disjoint (Bin _ x l r) t
 
 lookupMinSure :: a -> Set a -> a
 lookupMinSure x Tip = x
-lookupMinSure _ (Bin _ x l _) = lookupMinSure x l
+lookupMinSure _ (Bin (NonEmptySet _ x l _)) = lookupMinSure x l
 
 -- | /O(log n)/. The minimal element of a set.
 --
@@ -665,7 +680,7 @@ lookupMinSure _ (Bin _ x l _) = lookupMinSure x l
 
 lookupMin :: Set a -> Maybe a
 lookupMin Tip = Nothing
-lookupMin (Bin _ x l _) = Just $! lookupMinSure x l
+lookupMin (Bin (NonEmptySet _ x l _)) = Just $! lookupMinSure x l
 
 -- | /O(log n)/. The minimal element of a set.
 findMin :: Set a -> a
@@ -675,7 +690,7 @@ findMin t
 
 lookupMaxSure :: a -> Set a -> a
 lookupMaxSure x Tip = x
-lookupMaxSure _ (Bin _ x _ r) = lookupMaxSure x r
+lookupMaxSure _ (Bin (NonEmptySet _ x _ r)) = lookupMaxSure x r
 
 -- | /O(log n)/. The maximal element of a set.
 --
@@ -683,7 +698,7 @@ lookupMaxSure _ (Bin _ x _ r) = lookupMaxSure x r
 
 lookupMax :: Set a -> Maybe a
 lookupMax Tip = Nothing
-lookupMax (Bin _ x _ r) = Just $! lookupMaxSure x r
+lookupMax (Bin (NonEmptySet _ x _ r)) = Just $! lookupMaxSure x r
 
 -- | /O(log n)/. The maximal element of a set.
 findMax :: Set a -> a
@@ -693,14 +708,14 @@ findMax t
 
 -- | /O(log n)/. Delete the minimal element. Returns an empty set if the set is empty.
 deleteMin :: Set a -> Set a
-deleteMin (Bin _ _ Tip r) = r
-deleteMin (Bin _ x l r)   = balanceR x (deleteMin l) r
+deleteMin (Bin (NonEmptySet _ _ Tip r)) = r
+deleteMin (Bin (NonEmptySet _ x l r))   = balanceR x (deleteMin l) r
 deleteMin Tip             = Tip
 
 -- | /O(log n)/. Delete the maximal element. Returns an empty set if the set is empty.
 deleteMax :: Set a -> Set a
-deleteMax (Bin _ _ l Tip) = l
-deleteMax (Bin _ x l r)   = balanceL x l (deleteMax r)
+deleteMax (Bin (NonEmptySet _ _ l Tip)) = l
+deleteMax (Bin (NonEmptySet _ x l r))   = balanceL x l (deleteMax r)
 deleteMax Tip             = Tip
 
 {--------------------------------------------------------------------
@@ -717,10 +732,10 @@ unions = Foldable.foldl' union empty
 -- equal elements are encountered.
 union :: Ord a => Set a -> Set a -> Set a
 union t1 Tip  = t1
-union t1 (Bin 1 x _ _) = insertR x t1
-union (Bin 1 x _ _) t2 = insert x t2
+union t1 (Bin (NonEmptySet 1 x _ _)) = insertR x t1
+union (Bin (NonEmptySet 1 x _ _)) t2 = insert x t2
 union Tip t2  = t2
-union t1@(Bin _ x l1 r1) t2 = case splitS x t2 of
+union t1@(Bin (NonEmptySet _ x l1 r1)) t2 = case splitS x t2 of
   (l2 :*: r2)
     | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1
     | otherwise -> link x l1l2 r1r2
@@ -737,7 +752,7 @@ union t1@(Bin _ x l1 r1) t2 = case splitS x t2 of
 difference :: Ord a => Set a -> Set a -> Set a
 difference Tip _   = Tip
 difference t1 Tip  = t1
-difference t1 (Bin _ x l2 r2) = case split x t1 of
+difference t1 (Bin (NonEmptySet _ x l2 r2)) = case split x t1 of
    (l1, r1)
      | size l1l2 + size r1r2 == size t1 -> t1
      | otherwise -> merge l1l2 r1r2
@@ -764,7 +779,7 @@ difference t1 (Bin _ x l2 r2) = case split x t1 of
 intersection :: Ord a => Set a -> Set a -> Set a
 intersection Tip _ = Tip
 intersection _ Tip = Tip
-intersection t1@(Bin _ x l1 r1) t2
+intersection t1@(Bin (NonEmptySet _ x l1 r1)) t2
   | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1
         then t1
         else link x l1l2 r1r2
@@ -783,7 +798,7 @@ intersection t1@(Bin _ x l1 r1) t2
 -- | /O(n)/. Filter all elements that satisfy the predicate.
 filter :: (a -> Bool) -> Set a -> Set a
 filter _ Tip = Tip
-filter p t@(Bin _ x l r)
+filter p t@(Bin (NonEmptySet _ x l r))
     | p x = if l `ptrEq` l' && r `ptrEq` r'
             then t
             else link x l' r'
@@ -799,7 +814,7 @@ partition :: (a -> Bool) -> Set a -> (Set a,Set a)
 partition p0 t0 = toPair $ go p0 t0
   where
     go _ Tip = (Tip :*: Tip)
-    go p t@(Bin _ x l r) = case (go p l, go p r) of
+    go p t@(Bin (NonEmptySet _ x l r)) = case (go p l, go p r) of
       ((l1 :*: l2), (r1 :*: r2))
         | p x       -> (if l1 `ptrEq` l && r1 `ptrEq` r
                         then t
@@ -837,7 +852,7 @@ map f = fromList . List.map f . toList
 
 mapMonotonic :: (a->b) -> Set a -> Set b
 mapMonotonic _ Tip = Tip
-mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)
+mapMonotonic f (Bin (NonEmptySet sz x l r)) = Bin $ NonEmptySet sz (f x) (mapMonotonic f l) (mapMonotonic f r)
 
 {--------------------------------------------------------------------
   Fold
@@ -861,7 +876,7 @@ foldr :: (a -> b -> b) -> b -> Set a -> b
 foldr f z = go z
   where
     go z' Tip           = z'
-    go z' (Bin _ x l r) = go (f x (go z' r)) l
+    go z' (Bin (NonEmptySet _ x l r)) = go (f x (go z' r)) l
 {-# INLINE foldr #-}
 
 -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is
@@ -871,7 +886,7 @@ foldr' :: (a -> b -> b) -> b -> Set a -> b
 foldr' f z = go z
   where
     go !z' Tip           = z'
-    go z' (Bin _ x l r) = go (f x (go z' r)) l
+    go z' (Bin (NonEmptySet _ x l r)) = go (f x (go z' r)) l
 {-# INLINE foldr' #-}
 
 -- | /O(n)/. Fold the elements in the set using the given left-associative
@@ -884,7 +899,7 @@ foldl :: (a -> b -> a) -> a -> Set b -> a
 foldl f z = go z
   where
     go z' Tip           = z'
-    go z' (Bin _ x l r) = go (f (go z' l) x) r
+    go z' (Bin (NonEmptySet _ x l r)) = go (f (go z' l) x) r
 {-# INLINE foldl #-}
 
 -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is
@@ -894,7 +909,7 @@ foldl' :: (a -> b -> a) -> a -> Set b -> a
 foldl' f z = go z
   where
     go !z' Tip           = z'
-    go z' (Bin _ x l r) = go (f (go z' l) x) r
+    go z' (Bin (NonEmptySet _ x l r)) = go (f (go z' l) x) r
 {-# INLINE foldl' #-}
 
 {--------------------------------------------------------------------
@@ -967,9 +982,9 @@ foldlFB = foldl
 -- create, it is not inlined, so we inline it manually.
 fromList :: Ord a => [a] -> Set a
 fromList [] = Tip
-fromList [x] = Bin 1 x Tip Tip
-fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0
-                    | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0
+fromList [x] = Bin $ NonEmptySet 1 x Tip Tip
+fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin (NonEmptySet 1 x0 Tip Tip)) xs0
+                    | otherwise = go (1::Int) (Bin (NonEmptySet 1 x0 Tip Tip)) xs0
   where
     not_ordered _ [] = False
     not_ordered x (y : _) = x >= y
@@ -992,8 +1007,8 @@ fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0
     -- ordered so far.
     create !_ [] = (Tip, [], [])
     create s xs@(x : xss)
-      | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss)
-                                      else (Bin 1 x Tip Tip, xss, [])
+      | s == 1 = if not_ordered x xss then (Bin $ NonEmptySet 1 x Tip Tip, [], xss)
+                                      else (Bin $ NonEmptySet 1 x Tip Tip, xss, [])
       | otherwise = case create (s `shiftR` 1) xs of
                       res@(_, [], _) -> res
                       (l, [y], zs) -> (insertMax y l, [], zs)
@@ -1049,7 +1064,7 @@ combineEq (x : xs) = combineEq' x xs
 -- create, it is not inlined, so we inline it manually.
 fromDistinctAscList :: [a] -> Set a
 fromDistinctAscList [] = Tip
-fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
+fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin $ NonEmptySet 1 x0 Tip Tip) xs0
   where
     go !_ t [] = t
     go s l (x : xs) = case create s xs of
@@ -1058,7 +1073,7 @@ fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
 
     create !_ [] = (Tip :*: [])
     create s xs@(x : xs')
-      | s == 1 = (Bin 1 x Tip Tip :*: xs')
+      | s == 1 = (Bin (NonEmptySet 1 x Tip Tip) :*: xs')
       | otherwise = case create (s `shiftR` 1) xs of
                       res@(_ :*: []) -> res
                       (l :*: (y:ys)) -> case create (s `shiftR` 1) ys of
@@ -1073,7 +1088,7 @@ fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
 -- @since 0.5.8
 fromDistinctDescList :: [a] -> Set a
 fromDistinctDescList [] = Tip
-fromDistinctDescList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
+fromDistinctDescList (x0 : xs0) = go (1::Int) (Bin (NonEmptySet 1 x0 Tip Tip)) xs0
   where
     go !_ t [] = t
     go s r (x : xs) = case create s xs of
@@ -1082,7 +1097,7 @@ fromDistinctDescList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
 
     create !_ [] = (Tip :*: [])
     create s xs@(x : xs')
-      | s == 1 = (Bin 1 x Tip Tip :*: xs')
+      | s == 1 = (Bin (NonEmptySet 1 x Tip Tip) :*: xs')
       | otherwise = case create (s `shiftR` 1) xs of
                       res@(_ :*: []) -> res
                       (r :*: (y:ys)) -> case create (s `shiftR` 1) ys of
@@ -1157,7 +1172,7 @@ INSTANCE_TYPEABLE1(Set)
 
 instance NFData a => NFData (Set a) where
     rnf Tip           = ()
-    rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r
+    rnf (Bin (NonEmptySet _ y l r)) = rnf y `seq` rnf l `seq` rnf r
 
 {--------------------------------------------------------------------
   Split
@@ -1171,7 +1186,7 @@ split x t = toPair $ splitS x t
 
 splitS :: Ord a => a -> Set a -> StrictPair (Set a) (Set a)
 splitS _ Tip = (Tip :*: Tip)
-splitS x (Bin _ y l r)
+splitS x (Bin (NonEmptySet _ y l r))
       = case compare x y of
           LT -> let (lt :*: gt) = splitS x l in (lt :*: link y gt r)
           GT -> let (lt :*: gt) = splitS x r in (link y l lt :*: gt)
@@ -1182,7 +1197,7 @@ splitS x (Bin _ y l r)
 -- element was found in the original set.
 splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a)
 splitMember _ Tip = (Tip, False, Tip)
-splitMember x (Bin _ y l r)
+splitMember x (Bin (NonEmptySet _ y l r))
    = case compare x y of
        LT -> let (lt, found, gt) = splitMember x l
                  !gt' = link y gt r
@@ -1217,7 +1232,7 @@ findIndex = go 0
   where
     go :: Ord a => Int -> a -> Set a -> Int
     go !_ !_ Tip  = error "Set.findIndex: element is not in the set"
-    go idx x (Bin _ kx l r) = case compare x kx of
+    go idx x (Bin (NonEmptySet _ kx l r)) = case compare x kx of
       LT -> go idx x l
       GT -> go (idx + size l + 1) x r
       EQ -> idx + size l
@@ -1242,7 +1257,7 @@ lookupIndex = go 0
   where
     go :: Ord a => Int -> a -> Set a -> Maybe Int
     go !_ !_ Tip  = Nothing
-    go idx x (Bin _ kx l r) = case compare x kx of
+    go idx x (Bin (NonEmptySet _ kx l r)) = case compare x kx of
       LT -> go idx x l
       GT -> go (idx + size l + 1) x r
       EQ -> Just $! idx + size l
@@ -1262,7 +1277,7 @@ lookupIndex = go 0
 
 elemAt :: Int -> Set a -> a
 elemAt !_ Tip = error "Set.elemAt: index out of range"
-elemAt i (Bin _ x l r)
+elemAt i (Bin (NonEmptySet _ x l r))
   = case compare i sizeL of
       LT -> elemAt i l
       GT -> elemAt (i-sizeL-1) r
@@ -1285,7 +1300,7 @@ deleteAt :: Int -> Set a -> Set a
 deleteAt !i t =
   case t of
     Tip -> error "Set.deleteAt: index out of range"
-    Bin _ x l r -> case compare i sizeL of
+    Bin (NonEmptySet _ x l r) -> case compare i sizeL of
       LT -> balanceR x (deleteAt i l) r
       GT -> balanceL x l (deleteAt (i-sizeL-1) r)
       EQ -> glue l r
@@ -1306,7 +1321,7 @@ take i0 m0 = go i0 m0
   where
     go i !_ | i <= 0 = Tip
     go !_ Tip = Tip
-    go i (Bin _ x l r) =
+    go i (Bin (NonEmptySet _ x l r)) =
       case compare i sizeL of
         LT -> go i l
         GT -> link x l (go (i - sizeL - 1) r)
@@ -1327,7 +1342,7 @@ drop i0 m0 = go i0 m0
   where
     go i m | i <= 0 = m
     go !_ Tip = Tip
-    go i (Bin _ x l r) =
+    go i (Bin (NonEmptySet _ x l r)) =
       case compare i sizeL of
         LT -> link x (go i l) r
         GT -> go (i - sizeL - 1) r
@@ -1346,7 +1361,7 @@ splitAt i0 m0
   where
     go i m | i <= 0 = Tip :*: m
     go !_ Tip = Tip :*: Tip
-    go i (Bin _ x l r)
+    go i (Bin (NonEmptySet _ x l r))
       = case compare i sizeL of
           LT -> case go i l of
                   ll :*: lr -> ll :*: link x lr r
@@ -1368,7 +1383,7 @@ splitAt i0 m0
 
 takeWhileAntitone :: (a -> Bool) -> Set a -> Set a
 takeWhileAntitone _ Tip = Tip
-takeWhileAntitone p (Bin _ x l r)
+takeWhileAntitone p (Bin (NonEmptySet _ x l r))
   | p x = link x l (takeWhileAntitone p r)
   | otherwise = takeWhileAntitone p l
 
@@ -1385,7 +1400,7 @@ takeWhileAntitone p (Bin _ x l r)
 
 dropWhileAntitone :: (a -> Bool) -> Set a -> Set a
 dropWhileAntitone _ Tip = Tip
-dropWhileAntitone p (Bin _ x l r)
+dropWhileAntitone p (Bin (NonEmptySet _ x l r))
   | p x = dropWhileAntitone p r
   | otherwise = link x (dropWhileAntitone p l) r
 
@@ -1409,7 +1424,7 @@ spanAntitone :: (a -> Bool) -> Set a -> (Set a, Set a)
 spanAntitone p0 m = toPair (go p0 m)
   where
     go _ Tip = Tip :*: Tip
-    go p (Bin _ x l r)
+    go p (Bin (NonEmptySet _ x l r))
       | p x = let u :*: v = go p r in link x l u :*: v
       | otherwise = let u :*: v = go p l in u :*: link x v r
 
@@ -1442,7 +1457,7 @@ spanAntitone p0 m = toPair (go p0 m)
 link :: a -> Set a -> Set a -> Set a
 link x Tip r  = insertMin x r
 link x l Tip  = insertMax x l
-link x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)
+link x l@(Bin (NonEmptySet sizeL y ly ry)) r@(Bin (NonEmptySet sizeR z lz rz))
   | delta*sizeL < sizeR  = balanceL z (link x l lz) rz
   | delta*sizeR < sizeL  = balanceR y ly (link x ry r)
   | otherwise            = bin x l r
@@ -1453,13 +1468,13 @@ insertMax,insertMin :: a -> Set a -> Set a
 insertMax x t
   = case t of
       Tip -> singleton x
-      Bin _ y l r
+      Bin (NonEmptySet _ y l r)
           -> balanceR y l (insertMax x r)
 
 insertMin x t
   = case t of
       Tip -> singleton x
-      Bin _ y l r
+      Bin (NonEmptySet _ y l r)
           -> balanceL y (insertMin x l) r
 
 {--------------------------------------------------------------------
@@ -1468,7 +1483,7 @@ insertMin x t
 merge :: Set a -> Set a -> Set a
 merge Tip r   = r
 merge l Tip   = l
-merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
+merge l@(Bin (NonEmptySet sizeL x lx rx)) r@(Bin (NonEmptySet sizeR y ly ry))
   | delta*sizeL < sizeR = balanceL y (merge l ly) ry
   | delta*sizeR < sizeL = balanceR x lx (merge rx r)
   | otherwise           = glue l r
@@ -1480,7 +1495,7 @@ merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
 glue :: Set a -> Set a -> Set a
 glue Tip r = r
 glue l Tip = l
-glue l@(Bin sl xl ll lr) r@(Bin sr xr rl rr)
+glue l@(Bin (NonEmptySet sl xl ll lr)) r@(Bin (NonEmptySet sr xr rl rr))
   | sl > sr = let !(m :*: l') = maxViewSure xl ll lr in balanceR m l' r
   | otherwise = let !(m :*: r') = minViewSure xr rl rr in balanceL m l r'
 
@@ -1505,7 +1520,7 @@ minViewSure :: a -> Set a -> Set a -> StrictPair a (Set a)
 minViewSure = go
   where
     go x Tip r = x :*: r
-    go x (Bin _ xl ll lr) r =
+    go x (Bin (NonEmptySet _ xl ll lr)) r =
       case go xl ll lr of
         xm :*: l' -> xm :*: balanceR x l' r
 
@@ -1513,13 +1528,13 @@ minViewSure = go
 -- stripped of that element, or 'Nothing' if passed an empty set.
 minView :: Set a -> Maybe (a, Set a)
 minView Tip = Nothing
-minView (Bin _ x l r) = Just $! toPair $ minViewSure x l r
+minView (Bin (NonEmptySet _ x l r)) = Just $! toPair $ minViewSure x l r
 
 maxViewSure :: a -> Set a -> Set a -> StrictPair a (Set a)
 maxViewSure = go
   where
     go x l Tip = x :*: l
-    go x l (Bin _ xr rl rr) =
+    go x l (Bin (NonEmptySet _ xr rl rr)) =
       case go xr rl rr of
         xm :*: r' -> xm :*: balanceL x l r'
 
@@ -1527,7 +1542,7 @@ maxViewSure = go
 -- stripped of that element, or 'Nothing' if passed an empty set.
 maxView :: Set a -> Maybe (a, Set a)
 maxView Tip = Nothing
-maxView (Bin _ x l r) = Just $! toPair $ maxViewSure x l r
+maxView (Bin (NonEmptySet _ x l r)) = Just $! toPair $ maxViewSure x l r
 
 {--------------------------------------------------------------------
   [balance x l r] balances two trees with value x.
@@ -1570,10 +1585,10 @@ ratio = 2
 --
 --   balance :: a -> Set a -> Set a -> Set a
 --   balance x l r
---     | sizeL + sizeR <= 1   = Bin sizeX x l r
+--     | sizeL + sizeR <= 1   = Bin $ NonEmptySet sizeX x l r
 --     | sizeR > delta*sizeL  = rotateL x l r
 --     | sizeL > delta*sizeR  = rotateR x l r
---     | otherwise            = Bin sizeX x l r
+--     | otherwise            = Bin $ NonEmptySet sizeX x l r
 --     where
 --       sizeL = size l
 --       sizeR = size r
@@ -1591,7 +1606,7 @@ ratio = 2
 --   singleR x1 (Bin _ x2 t1 t2) t3  = bin x2 t1 (bin x1 t2 t3)
 --
 --   doubleL, doubleR :: a -> Set a -> Set a -> Set a
---   doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
+--   doubleL x1 t1 (Bin (NonEmptySet _ x2 (Bin _ x3 t2 t3) t4)) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
 --   doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
 --
 -- It is only written in such a way that every node is pattern-matched only once.
@@ -1608,24 +1623,35 @@ ratio = 2
 balanceL :: a -> Set a -> Set a -> Set a
 balanceL x l r = case r of
   Tip -> case l of
-           Tip -> Bin 1 x Tip Tip
-           (Bin _ _ Tip Tip) -> Bin 2 x l Tip
-           (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)
-           (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)
-           (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr))
-             | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)
-             | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)
-
-  (Bin rs _ _ _) -> case l of
-           Tip -> Bin (1+rs) x Tip r
-
-           (Bin ls lx ll lr)
-              | ls > delta*rs  -> case (ll, lr) of
-                   (Bin lls _ _ _, Bin lrs lrx lrl lrr)
-                     | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)
-                     | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)
-                   (_, _) -> error "Failure in Data.Map.balanceL"
-              | otherwise -> Bin (1+ls+rs) x l r
+    Tip -> Bin $ NonEmptySet 1 x Tip Tip
+    (Bin (NonEmptySet _ _ Tip Tip)) ->
+      Bin $ NonEmptySet 2 x l Tip
+    (Bin (NonEmptySet _ lx Tip (Bin (NonEmptySet _ lrx _ _)))) ->
+      Bin $ NonEmptySet 3 lrx (Bin $ NonEmptySet 1 lx Tip Tip) (Bin $ NonEmptySet 1 x Tip Tip)
+    (Bin (NonEmptySet _ lx ll@(Bin (NonEmptySet _ _ _ _)) Tip)) ->
+      Bin $ NonEmptySet 3 lx ll (Bin $ NonEmptySet 1 x Tip Tip)
+    (Bin (NonEmptySet ls lx ll@(Bin (NonEmptySet lls _ _ _))
+                            lr@(Bin (NonEmptySet lrs lrx lrl lrr))))
+      | lrs < ratio*lls ->
+        Bin $ NonEmptySet (1+ls) lx ll (Bin $ NonEmptySet (1+lrs) x lr Tip)
+      | otherwise ->
+        Bin $ NonEmptySet (1+ls) lrx
+          (Bin $ NonEmptySet (1+lls+size lrl) lx ll lrl)
+          (Bin $ NonEmptySet (1+size lrr) x lrr Tip)
+
+  (Bin (NonEmptySet rs _ _ _)) -> case l of
+    Tip -> Bin $ NonEmptySet (1+rs) x Tip r
+    (Bin (NonEmptySet ls lx ll lr))
+      | ls > delta*rs  -> case (ll, lr) of
+          (Bin (NonEmptySet lls _ _ _), Bin (NonEmptySet lrs lrx lrl lrr))
+            | lrs < ratio*lls -> Bin $ NonEmptySet (1+ls+rs) lx
+              ll
+              (Bin $ NonEmptySet (1+rs+lrs) x lr r)
+            | otherwise -> Bin $ NonEmptySet (1+ls+rs) lrx
+              (Bin $ NonEmptySet (1+lls+size lrl) lx ll lrl)
+              (Bin $ NonEmptySet (1+rs+size lrr) x lrr r)
+          (_, _) -> error "Failure in Data.Set.balanceL"
+      | otherwise -> Bin $ NonEmptySet (1+ls+rs) x l r
 {-# NOINLINE balanceL #-}
 
 -- balanceR is called when right subtree might have been inserted to or when
@@ -1633,24 +1659,39 @@ balanceL x l r = case r of
 balanceR :: a -> Set a -> Set a -> Set a
 balanceR x l r = case l of
   Tip -> case r of
-           Tip -> Bin 1 x Tip Tip
-           (Bin _ _ Tip Tip) -> Bin 2 x Tip r
-           (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr
-           (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)
-           (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _))
-             | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr
-             | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)
-
-  (Bin ls _ _ _) -> case r of
-           Tip -> Bin (1+ls) x l Tip
-
-           (Bin rs rx rl rr)
-              | rs > delta*ls  -> case (rl, rr) of
-                   (Bin rls rlx rll rlr, Bin rrs _ _ _)
-                     | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr
-                     | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)
-                   (_, _) -> error "Failure in Data.Map.balanceR"
-              | otherwise -> Bin (1+ls+rs) x l r
+    Tip -> Bin $ NonEmptySet 1 x Tip Tip
+    (Bin (NonEmptySet _ _ Tip Tip)) ->
+      Bin $ NonEmptySet 2 x Tip r
+    (Bin (NonEmptySet _ rx Tip rr@(Bin (NonEmptySet _ _ _ _)))) ->
+      Bin $ NonEmptySet 3 rx (Bin (NonEmptySet 1 x Tip Tip)) rr
+    (Bin (NonEmptySet _ rx (Bin (NonEmptySet _ rlx _ _)) Tip)) ->
+      Bin $ NonEmptySet 3 rlx
+        (Bin (NonEmptySet 1 x Tip Tip))
+        (Bin (NonEmptySet 1 rx Tip Tip))
+    (Bin (NonEmptySet rs rx
+           rl@(Bin (NonEmptySet rls rlx rll rlr))
+           rr@(Bin (NonEmptySet rrs _ _ _))))
+      | rls < ratio*rrs -> Bin $ NonEmptySet (1+rs) rx
+        (Bin (NonEmptySet (1+rls) x Tip rl))
+        rr
+      | otherwise -> Bin $ NonEmptySet (1+rs) rlx
+        (Bin (NonEmptySet (1+size rll) x Tip rll))
+        (Bin (NonEmptySet (1+rrs+size rlr) rx rlr rr))
+
+  (Bin (NonEmptySet ls _ _ _)) -> case r of
+    Tip -> Bin $ NonEmptySet (1+ls) x l Tip
+
+    (Bin (NonEmptySet rs rx rl rr))
+      | rs > delta*ls  -> case (rl, rr) of
+        (Bin (NonEmptySet rls rlx rll rlr), Bin (NonEmptySet rrs _ _ _))
+          | rls < ratio*rrs -> Bin $ NonEmptySet (1+ls+rs) rx
+            (Bin (NonEmptySet (1+ls+rls) x l rl))
+            rr
+          | otherwise -> Bin $ NonEmptySet (1+ls+rs) rlx
+            (Bin $ NonEmptySet (1+ls+size rll) x l rll)
+            (Bin $ NonEmptySet (1+rrs+size rlr) rx rlr rr)
+        (_, _) -> error "Failure in Data.Set.balanceR"
+          | otherwise -> Bin $ NonEmptySet (1+ls+rs) x l r
 {-# NOINLINE balanceR #-}
 
 {--------------------------------------------------------------------
@@ -1658,7 +1699,7 @@ balanceR x l r = case l of
 --------------------------------------------------------------------}
 bin :: a -> Set a -> Set a -> Set a
 bin x l r
-  = Bin (size l + size r + 1) x l r
+  = Bin $ NonEmptySet (size l + size r + 1) x l r
 {-# INLINE bin #-}
 
 
@@ -1690,7 +1731,7 @@ splitRoot :: Set a -> [Set a]
 splitRoot orig =
   case orig of
     Tip           -> []
-    Bin _ v l r -> [l, singleton v, r]
+    Bin (NonEmptySet _ v l r) -> [l, singleton v, r]
 {-# INLINE splitRoot #-}
 
 
@@ -1746,7 +1787,7 @@ cartesianProduct :: Set a -> Set b -> Set (a, b)
 -- When the second argument has at most one element, we can be a little
 -- clever.
 cartesianProduct !_as Tip = Tip
-cartesianProduct as (Bin 1 b _ _) = mapMonotonic (flip (,) b) as
+cartesianProduct as (Bin (NonEmptySet 1 b _ _)) = mapMonotonic (flip (,) b) as
 cartesianProduct as bs =
   getMergeSet $ foldMap (\a -> MergeSet $ mapMonotonic ((,) a) bs) as
 
@@ -1839,9 +1880,9 @@ showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS
 showsTree wide lbars rbars t
   = case t of
       Tip -> showsBars lbars . showString "|\n"
-      Bin _ x Tip Tip
+      Bin (NonEmptySet _ x Tip Tip)
           -> showsBars lbars . shows x . showString "\n"
-      Bin _ x l r
+      Bin (NonEmptySet _ x l r)
           -> showsTree wide (withBar rbars) (withEmpty rbars) r .
              showWide wide rbars .
              showsBars lbars . shows x . showString "\n" .
@@ -1852,9 +1893,9 @@ showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS
 showsTreeHang wide bars t
   = case t of
       Tip -> showsBars bars . showString "|\n"
-      Bin _ x Tip Tip
+      Bin (NonEmptySet _ x Tip Tip)
           -> showsBars bars . shows x . showString "\n"
-      Bin _ x l r
+      Bin (NonEmptySet _ x l r)
           -> showsBars bars . shows x . showString "\n" .
              showWide wide bars .
              showsTreeHang wide (withBar bars) l .
@@ -1894,13 +1935,13 @@ ordered t
     bounded lo hi t'
       = case t' of
           Tip         -> True
-          Bin _ x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r
+          Bin (NonEmptySet _ x l r) -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r
 
 balanced :: Set a -> Bool
 balanced t
   = case t of
       Tip         -> True
-      Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
+      Bin (NonEmptySet _ _ l r) -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
                      balanced l && balanced r
 
 validsize :: Set a -> Bool
@@ -1910,6 +1951,6 @@ validsize t
     realsize t'
       = case t' of
           Tip          -> Just 0
-          Bin sz _ l r -> case (realsize l,realsize r) of
+          Bin (NonEmptySet sz _ l r) -> case (realsize l,realsize r) of
                             (Just n,Just m)  | n+m+1 == sz  -> Just sz
                             _                -> Nothing
diff --git a/tests/set-properties.hs b/tests/set-properties.hs
index e235c0add..c351020e8 100644
--- a/tests/set-properties.hs
+++ b/tests/set-properties.hs
@@ -238,15 +238,15 @@ mkArb step n
      p <- step
      q <- step
      if dir
-       then return (Bin 2 q (singleton p) Tip)
-       else return (Bin 2 p Tip (singleton q))
+       then return (Bin $ NonEmptySet 2 q (singleton p) Tip)
+       else return (Bin $ NonEmptySet 2 p Tip (singleton q))
   | otherwise = do
       -- This assumes a balance factor of delta = 3
       let upper = (3*(n - 1)) `quot` 4
       let lower = (n + 2) `quot` 4
       ln <- liftGen $ choose (lower, upper)
       let rn = n - ln - 1
-      liftM3 (\lt x rt -> Bin n x lt rt) (mkArb step ln) step (mkArb step rn)
+      liftM3 (\lt x rt -> Bin $ NonEmptySet n x lt rt) (mkArb step ln) step (mkArb step rn)
 
 -- | Given a strictly increasing list of elements, produce an arbitrarily
 -- shaped set with exactly those elements.