Merge pull request #331 from treeowl/map-fromAscList-strictify

Make Data.Map.fromDistinct{Asc,Desc}List eager

Author: treeowl

Data/Map/Internal.hs

@@ -3431,15 +3431,16 @@ fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
   where
     go !_ t [] = t
     go s l ((kx, x) : xs) = case create s xs of
-                              (r, ys) -> go (s `shiftL` 1) (link kx x l r) ys
+                                (r :*: ys) -> let !t' = link kx x l r
+                                              in go (s `shiftL` 1) t' ys
 
-    create !_ [] = (Tip, [])
+    create !_ [] = (Tip :*: [])
     create s xs@(x' : xs')
-      | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip, xs')
+      | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')
       | otherwise = case create (s `shiftR` 1) xs of
-                      res@(_, []) -> res
-                      (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of
-                        (r, zs) -> (link ky y l r, zs)
+                      res@(_ :*: []) -> res
+                      (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
+                        (r :*: zs) -> (link ky y l r :*: zs)
 
 -- | /O(n)/. Build a map from a descending list of distinct elements in linear time.
 -- /The precondition is not checked./
@@ -3456,15 +3457,16 @@ fromDistinctDescList ((kx0, x0) : xs0) = go (1 :: Int) (Bin 1 kx0 x0 Tip Tip) xs
   where
      go !_ t [] = t
      go s r ((kx, x) : xs) = case create s xs of
-                               (l, ys) -> go (s `shiftL` 1) (link kx x l r) ys
+                               (l :*: ys) -> let !t' = link kx x l r
+                                             in go (s `shiftL` 1) t' ys
 
-     create !_ [] = (Tip, [])
+     create !_ [] = (Tip :*: [])
      create s xs@(x' : xs')
-       | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip, xs')
+       | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')
        | otherwise = case create (s `shiftR` 1) xs of
-                       res@(_, []) -> res
-                       (r, (ky, y):ys) -> case create (s `shiftR` 1) ys of
-                         (l, zs) -> (link ky y l r, zs)
+                       res@(_ :*: []) -> res
+                       (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
+                         (l :*: zs) -> (link ky y l r :*: zs)
 
 {-
 -- Functions very similar to these were used to implement

Data/Map/Strict/Internal.hs

@@ -1670,16 +1670,18 @@ fromDistinctAscList [] = Tip
 fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
   where
     go !_ t [] = t
-    go s l ((kx, x) : xs) = case create s xs of
-                              (r, ys) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys
+    go s l ((kx, x) : xs) =
+      case create s xs of
+        (r :*: ys) -> x `seq` let !t' = link kx x l r
+                           in go (s `shiftL` 1) t' ys
 
-    create !_ [] = (Tip, [])
+    create !_ [] = (Tip :*: [])
     create s xs@(x' : xs')
-      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip, xs')
+      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs')
       | otherwise = case create (s `shiftR` 1) xs of
-                      res@(_, []) -> res
-                      (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of
-                        (r, zs) -> y `seq` (link ky y l r, zs)
+                      res@(_ :*: []) -> res
+                      (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
+                        (r :*: zs) -> y `seq` (link ky y l r :*: zs)
 
 -- | /O(n)/. Build a map from a descending list of distinct elements in linear time.
 -- /The precondition is not checked./
@@ -1695,13 +1697,15 @@ fromDistinctDescList [] = Tip
 fromDistinctDescList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
   where
     go !_ t [] = t
-    go s r ((kx, x) : xs) = case create s xs of
-                              (l, ys) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys
+    go s r ((kx, x) : xs) =
+      case create s xs of
+        (l :*: ys) -> x `seq` let !t' = link kx x l r
+                              in go (s `shiftL` 1) t' ys
 
-    create !_ [] = (Tip, [])
+    create !_ [] = (Tip :*: [])
     create s xs@(x' : xs')
-      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip, xs')
+      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs')
       | otherwise = case create (s `shiftR` 1) xs of
-                      res@(_, []) -> res
-                      (r, (ky, y):ys) -> case create (s `shiftR` 1) ys of
-                        (l, zs) -> y `seq` (link ky y l r, zs)
+                      res@(_ :*: []) -> res
+                      (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
+                        (l :*: zs) -> y `seq` (link ky y l r :*: zs)

Data/Set/Internal.hs

@@ -974,7 +974,8 @@ fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
   where
     go !_ t [] = t
     go s l (x : xs) = case create s xs of
-                        (r :*: ys) -> go (s `shiftL` 1) (link x l r) ys
+                        (r :*: ys) -> let !t' = link x l r
+                                      in go (s `shiftL` 1) t' ys
 
     create !_ [] = (Tip :*: [])
     create s xs@(x : xs')
@@ -995,7 +996,8 @@ fromDistinctDescList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0
   where
     go !_ t [] = t
     go s r (x : xs) = case create s xs of
-                        (l :*: ys) -> go (s `shiftL` 1) (link x l r) ys
+                        (l :*: ys) -> let !t' = link x l r
+                                      in go (s `shiftL` 1) t' ys
 
     create !_ [] = (Tip :*: [])
     create s xs@(x : xs')

Utils/Containers/Internal/StrictPair.hs

@@ -16,6 +16,8 @@ module Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where
 -- @
 data StrictPair a b = !a :*: !b
 
+infixr 1 :*:
+
 -- | Convert a strict pair to a standard pair.
 toPair :: StrictPair a b -> (a, b)
 toPair (x :*: y) = (x, y)