X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=hs-rrdtool.git;a=blobdiff_plain;f=Types%2FData%2FMap.hs;h=9f12a5d56e9afe3186aa216c17bfc2aac40fd847;hp=6cb61c62b2f5bc015a29eb141b736c9d722a5689;hb=a370bc29f91d16ad36da733fb82061b9a543700e;hpb=315cb18674266b201bd9eb48efb60edd1f30c41f

diff --git a/Types/Data/Map.hs b/Types/Data/Map.hs
index 6cb61c6..9f12a5d 100644
--- a/Types/Data/Map.hs
+++ b/Types/Data/Map.hs
@@ -90,18 +90,16 @@ type instance Size Tip             = D0
 type instance Size (Bin s k v l r) = s
 
 -- CompCase
-type CompCase a b ifLT ifGT ifEQ
-    = If (IsLT (Compare a b))
-         ifLT
-         (If (IsGT (Compare a b))
-             ifGT
-             ifEQ)
+type family   CompCase o  ifLT ifGT ifEQ
+type instance CompCase LT ifLT ifGT ifEQ = ifLT
+type instance CompCase GT ifLT ifGT ifEQ = ifGT
+type instance CompCase EQ ifLT ifGT ifEQ = ifEQ
 
 -- Lookup
 type family   Lookup k m
 type instance Lookup k Tip              = Nothing
 type instance Lookup k (Bin s k' v l r)
-    = CompCase k k'
+    = CompCase (Compare k k')
                (Lookup k l)
                (Lookup k r)
                (Just v)
@@ -110,7 +108,7 @@ type instance Lookup k (Bin s k' v l r)
 type family   LookupAssoc k m
 type instance LookupAssoc k Tip              = Nothing
 type instance LookupAssoc k (Bin s k' v l r)
-    = CompCase k k'
+    = CompCase (Compare k k')
                (LookupAssoc k l)
                (LookupAssoc k r)
                (Just (Cons k v))
@@ -138,7 +136,7 @@ type Singleton k v = Bin D1 k v Tip Tip
 type family   Insert k v m
 type instance Insert k v Tip              = Singleton k v
 type instance Insert k v (Bin s k' v' l r)
-    = CompCase k k'
+    = CompCase (Compare k k')
                (Balance k' v' (Insert k v l) r)
                (Balance k' v' l (Insert k v r))
                (Bin s k v l r)
@@ -147,7 +145,7 @@ type instance Insert k v (Bin s k' v' l r)
 type family   Delete k m
 type instance Delete k Tip              = Tip
 type instance Delete k (Bin s k' v l r)
-    = CompCase k k'
+    = CompCase (Compare k k')
                (Balance k' v (Delete k l) r)
                (Balance k' v l (Delete k r))
                (Glue l r)
@@ -158,12 +156,14 @@ type Ratio = D2
 
 type Balance k v l r
     = If ((Size l :+: Size r) :<=: D1)
-         (Bin (Size l :+: Size r :+: D1) k v l r)
+         (Bin (SizeX l r) k v l r)
          (If (Size r :>=: (Delta :*: Size l))
              (RotateL k v l r)
              (If (Size l :>=: (Delta :*: Size r))
                  (RotateR k v l r)
-                 (Bin (Size l :+: Size r :+: D1) k v l r)))
+                 (Bin (SizeX l r) k v l r)))
+
+type SizeX l r = Size l :+: Size r :+: D1
 
 -- Rotate
 type family   RotateL k v l r
@@ -282,12 +282,14 @@ type instance App2 (AdjustWithKey' f) k v = Just (App2 f k v)
 type family   UpdateWithKey f k m
 type instance UpdateWithKey f k Tip              = Tip
 type instance UpdateWithKey f k (Bin s k' v l r)
-    = CompCase k k'
+    = CompCase (Compare k k')
                (Balance k' v (UpdateWithKey f k l) r)
                (Balance k' v l (UpdateWithKey f k r))
-               (If (IsJust (App2 f k' v))
-                   (Bin s k' (FromJust (App2 f k' v)) l r)
-                   (Glue l r))
+               (UpdateWithKey' s k' (App2 f k' v) l r)
+
+type family   UpdateWithKey' s k mv l r
+type instance UpdateWithKey' s k (Just v) l r = Bin s k v l r
+type instance UpdateWithKey' s k Nothing  l r = Glue l r
 
 -- Map
 type MapValue f m = MapWithKey (MapValue' f) m