Merge pull request #141 from phadej/ord

Ord instances

Author: tibbe

CHANGES.md

@@ -1,3 +1,7 @@
+## next
+
+ * Add `Ord/Ord1/Ord2` instances.
+
 ## 0.2.8.0
 
  * Add `Eq1/2`, `Show1/2`, `Read1` instances with `base-4.9`

Data/HashMap/Base.hs

@@ -118,6 +118,7 @@ import Data.Hashable (Hashable)
 import Data.HashMap.PopCount (popCount)
 import Data.HashMap.Unsafe (runST)
 import Data.HashMap.UnsafeShift (unsafeShiftL, unsafeShiftR)
+import Data.HashMap.List (isPermutationBy, unorderedCompare)
 import Data.Typeable (Typeable)
 
 #if __GLASGOW_HASKELL__ >= 707
@@ -278,26 +279,34 @@ equal eqk eqv t1 t2 = go (toList' t1 []) (toList' t2 [])
 
     leafEq (L k v) (L k' v') = eqk k k' && eqv v v'
 
--- Note: previous implemenation isPermutation = null (as // bs)
--- was O(n^2) too.
---
--- This assumes lists are of equal length
-isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool
-isPermutationBy f = go
-  where
-    f' = flip f
+#if MIN_VERSION_base(4,9,0)
+instance Ord2 HashMap where
+    liftCompare2 = cmp
 
-    go [] [] = True
-    go (x : xs) (y : ys)
-        | f x y     = go xs ys
-        | otherwise = go (deleteBy f' y xs) (deleteBy f x ys)
-    go [] (_ : _) = False
-    go (_ : _) [] = False
-
--- Data.List.deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]
-deleteBy                :: (a -> b -> Bool) -> a -> [b] -> [b]
-deleteBy _  _ []        = []
-deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys
+instance Ord k => Ord1 (HashMap k) where
+    liftCompare = cmp compare
+#endif
+
+instance (Ord k, Ord v) => Ord (HashMap k v) where
+    compare = cmp compare compare
+
+cmp :: (k -> k' -> Ordering) -> (v -> v' -> Ordering)
+    -> HashMap k v -> HashMap k' v' -> Ordering
+cmp cmpk cmpv t1 t2 = go (toList' t1 []) (toList' t2 [])
+  where
+    go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)
+      = compare k1 k2 `mappend` leafCompare l1 l2 `mappend` go tl1 tl2
+    go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2)
+      = compare k1 k2 `mappend` compare (A.length ary1) (A.length ary2) `mappend`
+        unorderedCompare leafCompare (A.toList ary1) (A.toList ary2)
+    go (Leaf _ _ : _) (Collision _ _ : _) = LT
+    go (Collision _ _ : _) (Leaf _ _ : _) = GT
+    go [] [] = EQ
+    go [] _  = LT
+    go _  [] = GT
+    go _ _ = error "cmp: Should never happend, toList' includes non Leaf / Collision"
+
+    leafCompare (L k v) (L k' v') = cmpk k k' `mappend` cmpv v v'
 
 -- Same as 'equal' but doesn't compare the values.
 equalKeys :: (k -> k' -> Bool) -> HashMap k v -> HashMap k' v' -> Bool

Data/HashMap/List.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}
+-- | Extra list functions
+--
+-- In separate module to aid testing.
+module Data.HashMap.List
+    ( isPermutationBy
+    , deleteBy
+    , unorderedCompare
+    ) where
+
+import Data.Maybe (fromMaybe)
+import Data.List (sortBy)
+import Data.Monoid
+import Prelude
+
+-- Note: previous implemenation isPermutation = null (as // bs)
+-- was O(n^2) too.
+--
+-- This assumes lists are of equal length
+isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+isPermutationBy f = go
+  where
+    f' = flip f
+
+    go [] [] = True
+    go (x : xs) (y : ys)
+        | f x y         = go xs ys
+        | otherwise     = fromMaybe False $ do
+            xs' <- deleteBy f' y xs
+            ys' <- deleteBy f x ys
+            return (go xs' ys')
+    go [] (_ : _) = False
+    go (_ : _) [] = False
+
+-- The idea:
+--
+-- Homogeonous version
+--
+-- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
+-- uc c as bs = compare (sortBy c as) (sortBy c bs)
+--
+-- But as we have only (a -> b -> Ordering), we cannot directly compare
+-- elements from the same list.
+--
+-- So when comparing elements from the list, we count how many elements are
+-- "less and greater" in the other list, and use the count as a metric.
+--
+unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering
+unorderedCompare c as bs = go (sortBy cmpA as) (sortBy cmpB bs)
+  where
+    go [] [] = EQ
+    go [] (_ : _) = LT
+    go (_ : _) [] = GT
+    go (x : xs) (y : ys) = c x y `mappend` go xs ys
+
+    cmpA a a' = compare (inB a) (inB a')
+    cmpB b b' = compare (inA b) (inA b')
+
+    inB a = (length $ filter (\b -> c a b == GT) bs, negate $ length $ filter (\b -> c a b == LT) bs)
+    inA b = (length $ filter (\a -> c a b == LT) as, negate $ length $ filter (\a -> c a b == GT) as)
+
+-- Returns Nothing is nothing deleted
+deleteBy              :: (a -> b -> Bool) -> a -> [b] -> Maybe [b]
+deleteBy _  _ []      = Nothing
+deleteBy eq x (y:ys)  = if x `eq` y then Just ys else fmap (y :) (deleteBy eq x ys)

Data/HashSet.hs

@@ -123,6 +123,15 @@ instance Eq1 HashSet where
     liftEq eq (HashSet a) (HashSet b) = equalKeys eq a b
 #endif
 
+instance (Ord a) => Ord (HashSet a) where
+    compare (HashSet a) (HashSet b) = compare a b
+    {-# INLINE compare #-}
+
+#if MIN_VERSION_base(4,9,0)
+instance Ord1 HashSet where
+    liftCompare c (HashSet a) (HashSet b) = liftCompare2 c compare a b
+#endif
+
 instance Foldable.Foldable HashSet where
     foldr = Data.HashSet.foldr
     {-# INLINE foldr #-}

tests/HashMapProperties.hs

@@ -40,6 +40,25 @@ pEq xs = (M.fromList xs ==) `eq` (HM.fromList xs ==)
 pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool
 pNeq xs = (M.fromList xs /=) `eq` (HM.fromList xs /=)
 
+-- We cannot compare to `Data.Map` as ordering is different.
+pOrd1 :: [(Key, Int)] -> Bool
+pOrd1 xs = compare x x == EQ
+  where
+    x = HM.fromList xs
+
+pOrd2 :: [(Key, Int)] -> [(Key, Int)] -> [(Key, Int)] -> Bool
+pOrd2 xs ys zs = case (compare x y, compare y z) of
+    (EQ, o)  -> compare x z == o
+    (o,  EQ) -> compare x z == o
+    (LT, LT) -> compare x z == LT
+    (GT, GT) -> compare x z == GT
+    (LT, GT) -> True -- ys greater than xs and zs.
+    (GT, LT) -> True
+  where
+    x = HM.fromList xs
+    y = HM.fromList ys
+    z = HM.fromList zs
+
 pReadShow :: [(Key, Int)] -> Bool
 pReadShow xs = M.fromList xs == read (show (M.fromList xs))
 
@@ -254,6 +273,8 @@ tests =
       testGroup "instances"
       [ testProperty "==" pEq
       , testProperty "/=" pNeq
+      , testProperty "compare reflexive" pOrd1
+      , testProperty "compare transitive" pOrd2
       , testProperty "Read/Show" pReadShow
       , testProperty "Functor" pFunctor
       , testProperty "Foldable" pFoldable

tests/HashSetProperties.hs

@@ -34,6 +34,25 @@ pEq xs = (Set.fromList xs ==) `eq` (S.fromList xs ==)
 pNeq :: [Key] -> [Key] -> Bool
 pNeq xs = (Set.fromList xs /=) `eq` (S.fromList xs /=)
 
+-- We cannot compare to `Data.Map` as ordering is different.
+pOrd1 :: [Key] -> Bool
+pOrd1 xs = compare x x == EQ
+  where
+    x = S.fromList xs
+
+pOrd2 :: [Key] -> [Key] -> [Key] -> Bool
+pOrd2 xs ys zs = case (compare x y, compare y z) of
+    (EQ, o)  -> compare x z == o
+    (o,  EQ) -> compare x z == o
+    (LT, LT) -> compare x z == LT
+    (GT, GT) -> compare x z == GT
+    (LT, GT) -> True -- ys greater than xs and zs.
+    (GT, LT) -> True
+  where
+    x = S.fromList xs
+    y = S.fromList ys
+    z = S.fromList zs
+
 pReadShow :: [Key] -> Bool
 pReadShow xs = Set.fromList xs == read (show (Set.fromList xs))
 

tests/List.hs

@@ -0,0 +1,68 @@
+module Main (main) where
+
+import Data.HashMap.List
+import Data.List (nub, sort, sortBy)
+import Data.Ord (comparing)
+
+import Test.Framework (Test, defaultMain, testGroup)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.QuickCheck ((==>), (===), property, Property)
+
+tests :: Test
+tests = testGroup "Data.HashMap.List"
+    [ testProperty "isPermutationBy" pIsPermutation
+    , testProperty "isPermutationBy of different length" pIsPermutationDiffLength
+    , testProperty "pUnorderedCompare" pUnorderedCompare
+    , testGroup "modelUnorderedCompare"
+        [ testProperty "reflexive" modelUnorderedCompareRefl
+        , testProperty "anti-symmetric" modelUnorderedCompareAntiSymm
+        , testProperty "transitive" modelUnorderedCompareTrans
+        ]
+    ]
+
+pIsPermutation :: [Char] -> [Int] -> Bool
+pIsPermutation xs is = isPermutationBy (==) xs xs'
+  where
+    is' = nub is ++ [maximum (0:is) + 1 ..]
+    xs' = map fst . sortBy (comparing snd) $ zip xs is'
+
+pIsPermutationDiffLength :: [Int] -> [Int] -> Property
+pIsPermutationDiffLength xs ys =
+    length xs /= length ys ==> isPermutationBy (==) xs ys === False
+
+-- | Homogenous version of 'unorderedCompare'
+--
+-- *Compare smallest non-equal elements of the two lists*.
+modelUnorderedCompare :: Ord a => [a] -> [a] -> Ordering
+modelUnorderedCompare as bs = compare (sort as) (sort bs)
+
+modelUnorderedCompareRefl :: [Int] -> Property
+modelUnorderedCompareRefl xs = modelUnorderedCompare xs xs === EQ
+
+modelUnorderedCompareAntiSymm :: [Int] -> [Int] -> Property
+modelUnorderedCompareAntiSymm xs ys = case a of
+    EQ -> b === EQ
+    LT -> b === GT
+    GT -> b === LT
+  where
+    a = modelUnorderedCompare xs ys
+    b = modelUnorderedCompare ys xs
+
+modelUnorderedCompareTrans :: [Int] -> [Int] -> [Int] -> Property
+modelUnorderedCompareTrans xs ys zs =
+    case (modelUnorderedCompare xs ys, modelUnorderedCompare ys zs) of
+        (EQ, yz) -> xz === yz
+        (xy, EQ) -> xz === xy
+        (LT, LT) -> xz === LT
+        (GT, GT) -> xz === GT
+        (LT, GT) -> property True
+        (GT, LT) -> property True
+  where
+    xz = modelUnorderedCompare xs zs
+
+pUnorderedCompare :: [Int] -> [Int] -> Property
+pUnorderedCompare xs ys =
+    unorderedCompare compare xs ys === modelUnorderedCompare xs ys
+
+main :: IO ()
+main = defaultMain [tests]

unordered-containers.cabal

@@ -34,6 +34,7 @@ library
   other-modules:
     Data.HashMap.Array
     Data.HashMap.Base
+    Data.HashMap.List
     Data.HashMap.PopCount
     Data.HashMap.Unsafe
     Data.HashMap.UnsafeShift
@@ -103,6 +104,23 @@ test-suite hashset-properties
   ghc-options: -Wall
   cpp-options: -DASSERTS
 
+test-suite list-tests
+  hs-source-dirs: tests .
+  main-is: List.hs
+  other-modules:
+    Data.HashMap.List
+  type: exitcode-stdio-1.0
+
+  build-depends:
+    base,
+    containers >= 0.4,
+    QuickCheck >= 2.4.0.1,
+    test-framework >= 0.3.3,
+    test-framework-quickcheck2 >= 0.2.9
+
+  ghc-options: -Wall
+  cpp-options: -DASSERTS
+
 test-suite regressions
   hs-source-dirs: tests
   main-is: Regressions.hs