bimap-0.5.0/Data/0000755000000000000000000000000014237572147011657 5ustar0000000000000000bimap-0.5.0/Test/0000755000000000000000000000000013500611633011707 5ustar0000000000000000bimap-0.5.0/Data/Bimap.hs0000644000000000000000000005170414237572147013252 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE TypeFamilies #-} #endif {-| An implementation of bidirectional maps between values of two key types. A 'Bimap' is essentially a bijection between subsets of its two argument types. Each element of the left-hand type is associated with an element of the right-hand type, and vice-versa, such that the two mappings are inverses. Deleting an element will cause its twin to be deleted, and inserting a pair of elements will cause any overlapping bindings to be deleted. Most functions implicitly consider the left-hand type to be the key, and the right-hand type to be the value. Functions with an @R@ suffix reverse this convention, treating the right-hand type as the key and the left-hand type as the value. -} module Data.Bimap ( -- * Bimap type Bimap(), -- * Query null, size, member, memberR, notMember, notMemberR, pairMember, pairNotMember, lookup, lookupR, (!), (!>), (!?), (!?>), -- * Construction empty, singleton, -- * Update insert, tryInsert, adjust, adjustR, adjustWithKey, adjustWithKeyR, update, updateR, updateWithKey, updateWithKeyR, delete, deleteR, -- * Min\/Max findMin, findMinR, findMax, findMaxR, deleteMin, deleteMinR, deleteMax, deleteMaxR, deleteFindMin, deleteFindMinR, deleteFindMax, deleteFindMaxR, -- * Filter filter, partition, -- * Conversion\/traversal fromList, fromAList, fromAscPairList, fromAscPairListUnchecked, toList, toAscList, toAscListR, keys, keysR, elems, assocs, fold, Data.Bimap.map, mapR, mapMonotonic, mapMonotonicR, toMap, toMapR, -- * Miscellaneous valid, twist, twisted, ) where import Control.DeepSeq (NFData) import Control.Monad.Catch import Data.Function (on) import Data.List (foldl', sort) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Typeable #if __GLASGOW_HASKELL__ >= 708 import qualified Data.BimapExt as GHCExts #endif import GHC.Generics (Generic) import Prelude hiding (filter, lookup, null, pred) import qualified Prelude as P infixr 9 .: (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d (.:) = (.).(.) {-| A bidirectional map between values of types @a@ and @b@. -} data Bimap a b = MkBimap !(M.Map a b) !(M.Map b a) deriving (Generic) instance (Show a, Show b) => Show (Bimap a b) where show x = "fromList " ++ (show . toList $ x) instance (Eq a, Eq b) => Eq (Bimap a b) where (==) = (==) `on` toAscList instance (Ord a, Ord b) => Ord (Bimap a b) where compare = compare `on` toAscList instance (NFData a, NFData b) => NFData (Bimap a b) #if __GLASGOW_HASKELL__ >= 708 instance (Ord a, Ord b) => GHCExts.IsList (Bimap a b) where type Item (Bimap a b) = (a, b) fromList = fromList toList = toList #endif {-| A 'Bimap' action failed. -} data BimapException = KeyNotFound String deriving(Eq, Show, Typeable) instance Exception BimapException {-| /O(1)/. The empty bimap. /Version: 0.2/-} empty :: Bimap a b empty = MkBimap M.empty M.empty {-| /O(1)/. A bimap with a single element. /Version: 0.2/-} singleton :: a -> b -> Bimap a b singleton x y = MkBimap (M.singleton x y) (M.singleton y x) {-| /O(1)/. Is the bimap empty? /Version: 0.2/-} null :: Bimap a b -> Bool null (MkBimap left _) = M.null left {-| /O(1)/. The number of elements in the bimap. /Version: 0.2/-} size :: Bimap a b -> Int size (MkBimap left _) = M.size left {-| /O(log n)/. Is the specified value a member of the bimap? /Version: 0.2/-} member :: (Ord a, Ord b) => a -> Bimap a b -> Bool member x (MkBimap left _) = M.member x left {-| /O(log n)/. A version of 'member' specialized to the right key. /Version: 0.2/-} memberR :: (Ord a, Ord b) => b -> Bimap a b -> Bool memberR y (MkBimap _ right) = M.member y right {-| /O(log n)/. Is the specified value not a member of the bimap? /Version: 0.2/-} notMember :: (Ord a, Ord b) => a -> Bimap a b -> Bool notMember = not .: member {-| /O(log n)/. A version of 'notMember' specialized to the right key. /Version: 0.2/-} notMemberR :: (Ord a, Ord b) => b -> Bimap a b -> Bool notMemberR = not .: memberR {-| /O(log n)/. Are the two values associated /with each other/ in the bimap? This function is uncurried in its first two arguments, so that it can be used infix. /Version: 0.2/-} pairMember :: (Ord a, Ord b) => (a, b) -> Bimap a b -> Bool pairMember (x, y) (MkBimap left _) = maybe False (== y) (M.lookup x left) {-| /O(log n)/. Are the two values not in the bimap, or not associated with each other? (Complement of 'pairMember'.) /Version: 0.2/-} pairNotMember :: (Ord a, Ord b) => (a, b) -> Bimap a b -> Bool pairNotMember = not .: pairMember {-| /O(log n)/. Insert a pair of values into the bimap, associating them. If either of the values is already in the bimap, any overlapping bindings are deleted. /Version: 0.2/-} insert :: (Ord a, Ord b) => a -> b -> Bimap a b -> Bimap a b insert x y = delete x >>> deleteR y >>> unsafeInsert x y where (>>>) = flip (.) {-| /O(log n)/. Insert a pair of values into the bimap, but only if neither is already in the bimap. /Version: 0.2.2/-} tryInsert :: (Ord a, Ord b) => a -> b -> Bimap a b -> Bimap a b tryInsert x y bi | x `notMember` bi && y `notMemberR` bi = unsafeInsert x y bi | otherwise = bi {-| /O(log n)/. Insert a pair of values into the bimap, without checking for overlapping bindings. If either value is already in the bimap, and is not bound to the other value, the bimap will become inconsistent. -} unsafeInsert :: (Ord a, Ord b) => a -> b -> Bimap a b -> Bimap a b unsafeInsert x y (MkBimap left right) = MkBimap (M.insert x y left) (M.insert y x right) {-| /O(log n)/. Common implementation for 'delete' and 'deleteR'. -} deleteE :: (Ord a, Ord b) => Either a b -> Bimap a b -> Bimap a b deleteE e (MkBimap left right) = MkBimap (perhaps M.delete x left) (perhaps M.delete y right) where perhaps = maybe id x = either Just (`M.lookup` right) e y = either (`M.lookup` left) Just e {-| /O(log n)/. Delete a value and its twin from a bimap. When the value is not a member of the bimap, the original bimap is returned. /Version: 0.2/-} delete :: (Ord a, Ord b) => a -> Bimap a b -> Bimap a b delete = deleteE . Left {-| /O(log n)/ A version of 'delete' specialized to the right key. /Version: 0.2/-} deleteR :: (Ord a, Ord b) => b -> Bimap a b -> Bimap a b deleteR = deleteE . Right {-| /O(log n)/. Update a value at a specific left key with the result of the provided function. When the left key is not a member of the bimap, the original bimap is returned.-} adjust :: (Ord a, Ord b) => (b -> b) -> a -> Bimap a b -> Bimap a b adjust f = adjustWithKey (const f) {-| /O(log n)/. Update a value at a specific right key with the result of the provided function. When the right key is not a member of the bimap, the original bimap is returned.-} adjustR :: (Ord a, Ord b) => (a -> a) -> b -> Bimap a b -> Bimap a b adjustR f b = reverseBimap . adjust f b . reverseBimap where reverseBimap (MkBimap left right) = MkBimap right left {-| /O(log n)/. Adjust a value at a specific left key. When the left key is not a member of the bimap, the original bimap is returned.-} adjustWithKey :: (Ord a, Ord b) => (a -> b -> b) -> a -> Bimap a b -> Bimap a b adjustWithKey f = updateWithKey (\a -> Just . f a) {-| /O(log n)/. Adjust a value at a specific right key. When the right key is not a member of the bimap, the original bimap is returned.-} adjustWithKeyR :: (Ord a, Ord b) => (b -> a -> a) -> b -> Bimap a b -> Bimap a b adjustWithKeyR f b = reverseBimap . adjustWithKey f b . reverseBimap where reverseBimap (MkBimap left right) = MkBimap right left {-| /O(log n)/. The expression (@'update' f a bimap@) updates the right value @b@ at @a@ (if it is in the bimap). If (@f b@) is 'Nothing', the element is deleted. If it is (@'Just' y@), the left key @a@ is bound to the new value @y@.-} update :: (Ord a, Ord b) => (b -> Maybe b) -> a -> Bimap a b -> Bimap a b update f = updateWithKey (const f) {-| /O(log n)/. The expression (@'updateR' f b bimap@) updates the left value @a@ at @b@ (if it is in the bimap). If (@f a@) is 'Nothing', the element is deleted. If it is (@'Just' x@), the right key @b@ is bound to the new value @x@.-} updateR :: (Ord a, Ord b) => (a -> Maybe a) -> b -> Bimap a b -> Bimap a b updateR f b = reverseBimap . update f b . reverseBimap where reverseBimap (MkBimap left right) = MkBimap right left {-| /O(log n)/. The expression (@'updateWithKey' f a bimap@) updates the right value @b@ at @a@ (if it is in the bimap). If (@f a b@) is 'Nothing', the element is deleted. If it is (@'Just' y@), the left key @a@ is bound to the new value @y@.-} updateWithKey :: (Ord a, Ord b) => (a -> b -> Maybe b) -> a -> Bimap a b -> Bimap a b updateWithKey f a (MkBimap left right) = MkBimap left' right' where oldB = M.lookup a left newB = f a =<< oldB oldA = newB >>= (`M.lookup` right) >>= \x -> if x == a then Nothing else Just x left' = maybe id M.delete oldA $ M.updateWithKey f a left right' = maybe id (`M.insert` a) newB $ maybe id M.delete oldB right {-| /O(log n)/. The expression (@'updateWithKeyR' f b bimap@) updates the left value @a@ at @b@ (if it is in the bimap). If (@f b a@) is 'Nothing', the element is deleted. If it is (@'Just' x@), the right key @b@ is bound to the new value @x@.-} updateWithKeyR :: (Ord a, Ord b) => (b -> a -> Maybe a) -> b -> Bimap a b -> Bimap a b updateWithKeyR f b = reverseBimap . updateWithKey f b . reverseBimap where reverseBimap (MkBimap left right) = MkBimap right left {-| /O(log n)/. Lookup a left key in the bimap, returning the associated right key. This function will @return@ the result in the monad, or @fail@ if the value isn't in the bimap. Note that the signature differs slightly from Data.Map's @lookup@. This one is more general - it functions the same way as the "original" if @m@ is cast (or inferred) to Maybe. /Version: 0.2/-} lookup :: (Ord a, Ord b, MonadThrow m) => a -> Bimap a b -> m b lookup x (MkBimap left _) = maybe (throwM $ KeyNotFound "Data.Bimap.lookup") return (M.lookup x left) {-| /O(log n)/. A version of 'lookup' that is specialized to the right key, and returns the corresponding left key. /Version: 0.2/-} lookupR :: (Ord a, Ord b, MonadThrow m) => b -> Bimap a b -> m a lookupR y (MkBimap _ right) = maybe (throwM $ KeyNotFound "Data.Bimap.lookupR") return (M.lookup y right) {-| /O(log n)/. Find the right key corresponding to a given left key. Calls @'error'@ when the key is not in the bimap. /Version: 0.2/-} (!) :: (Ord a, Ord b) => Bimap a b -> a -> b (!) bi x = fromMaybe (error "Data.Bimap.(!): Left key not found") $ lookup x bi {-| /O(log n)/. A version of @(!)@ that is specialized to the right key, and returns the corresponding left key. /Version: 0.2/-} (!>) :: (Ord a, Ord b) => Bimap a b -> b -> a (!>) bi y = fromMaybe (error "Data.Bimap.(!>): Right key not found") $ lookupR y bi {-| /O(log n)/. See 'lookup'. -} (!?) :: (Ord a, Ord b, MonadThrow m) => Bimap a b -> a -> m b (!?) = flip lookup {-| /O(log n)/. See 'lookupR'. -} (!?>) :: (Ord a, Ord b, MonadThrow m) => Bimap a b -> b -> m a (!?>) = flip lookupR {-| /O(n*log n)/. Build a map from a list of pairs. If there are any overlapping pairs in the list, the later ones will override the earlier ones. /Version: 0.2/-} fromList :: (Ord a, Ord b) => [(a, b)] -> Bimap a b fromList = foldl' (flip . uncurry $ insert) empty {-| /O(n*log n)/. Build a map from a list of pairs. Unlike 'fromList', earlier pairs will take precedence over later ones. The name @fromAList@ is a reference to Lisp-style association lists, where associations can be overridden by prepending new ones. Note that when duplicates occur in both the keys and in the values, @fromList xs /= fromAList (reverse xs)@. However, if either contains no duplicates, then the equality holds. /Version: 0.2.2/-} fromAList :: (Ord a, Ord b) => [(a, b)] -> Bimap a b fromAList = foldl' (flip . uncurry $ tryInsert) empty {-| /O(n)/. Convert to a list of associated pairs. /Version: 0.2/-} toList :: Bimap a b -> [(a, b)] toList = toAscList {-| /O(n)/. Build a bimap from a list of pairs, where both the @fst@ and @snd@ halves of the list are in strictly ascending order. This precondition is checked; an invalid list will cause an error. /Version: 0.2.3/-} fromAscPairList :: (Ord a, Ord b) => [(a, b)] -> Bimap a b fromAscPairList xs | isBiAscending xs = fromAscPairListUnchecked xs | otherwise = error "Data.Bimap.fromAscPairList: list not correctly ascending" isBiAscending :: (Ord a, Ord b) => [(a, b)] -> Bool isBiAscending = allAdjacent bothLess where -- True if the binary relation f is true for all adjacent pairs -- in the input list allAdjacent :: (c -> c -> Bool) -> [c] -> Bool allAdjacent f xs = all (uncurry f) $ zip xs (tail xs) -- True if both components of the first pair are strictly less -- than their counterparts in the second pair bothLess (x1, y1) (x2, y2) = (x1 < x2) && (y1 < y2) {-| /O(n)/. Build a bimap from a list of pairs, where both the @fst@ and @snd@ halves of the list are in strictly ascending order. This precondition is /not/ checked; an invalid list will produce a malformed bimap. /Version: 0.2.3/-} fromAscPairListUnchecked :: (Ord a, Ord b) => [(a, b)] -> Bimap a b fromAscPairListUnchecked xs = MkBimap (M.fromAscList xs) (M.fromAscList $ P.map swap xs) where swap (x, y) = (y, x) {-| /O(n)/. Convert to a list of associated pairs, with the left-hand values in ascending order. Since pair ordering is lexical, the pairs will also be in ascending order. /Version: 0.2/-} toAscList :: Bimap a b -> [(a, b)] toAscList (MkBimap left _) = M.toList left {-| /O(n)/. Convert to a list of associated pairs, with the right-hand values first in the pair and in ascending order. Since pair ordering is lexical, the pairs will also be in ascending order. /Version: 0.2/-} toAscListR :: Bimap a b -> [(b, a)] toAscListR = toAscList . twist {-| /O(n)/. Return all associated pairs in the bimap, with the left-hand values in ascending order. /Version: 0.2/-} assocs :: Bimap a b -> [(a, b)] assocs = toList {-| /O(n)/. Return all left-hand keys in the bimap in ascending order. /Version: 0.2/-} keys :: Bimap a b -> [a] keys (MkBimap left _) = M.keys left {-| /O(n)/. Return all right-hand keys in the bimap in ascending order. /Version: 0.2/-} keysR :: Bimap a b -> [b] keysR (MkBimap _ right) = M.keys right {-| /O(n)/. An alias for 'keysR'. /Version: 0.2/-} elems :: Bimap a b -> [b] elems = keysR {-| /O(1)/. Extract only the left-to-right component of a bimap. /Version: 0.2.1/-} toMap :: Bimap a b -> M.Map a b toMap (MkBimap left _) = left {-| /O(1)/. Extract only the right-to-left component of a bimap. /Version: 0.2.1/-} toMapR :: Bimap a b -> M.Map b a toMapR (MkBimap _ right) = right {-| /O(n)/. Filter all association pairs that satisfy the predicate. Note that the predicate will be applied /twice/ for each association in the bimap. /Version: 0.2.4/-} filter :: (Ord a, Ord b) => (a -> b -> Bool) -> Bimap a b -> Bimap a b filter pred (MkBimap left right) = MkBimap (M.filterWithKey pred left) (M.filterWithKey (flip pred) right) {-| /O(n)/. Partition the bimap according to a predicate. The first bimap contains all associations that satisfy the predicate; the second contains all associations that fail the predicate. Note that the predicate will be applied /twice/ for each association in the bimap. /Version: 0.2.4/-} partition :: (Ord a, Ord b) => (a -> b -> Bool) -> Bimap a b -> (Bimap a b, Bimap a b) partition pred (MkBimap left right) = (,) (MkBimap leftA rightA) (MkBimap leftB rightB) where (leftA, leftB) = M.partitionWithKey pred left (rightA, rightB) = M.partitionWithKey (flip pred) right {-| /O(n*log n)/. Test if the internal bimap structure is valid. This should be true for any bimap created using the public interface, unless 'fromAscPairListUnchecked' has been used inappropriately. /Version: 0.2/-} valid :: (Ord a, Ord b) => Bimap a b -> Bool valid (MkBimap left right) = and [ M.valid left, M.valid right , (==) (sort . M.toList $ left ) (sort . P.map flipPair . M.toList $ right) ] where flipPair (x, y) = (y, x) {-| /O(1)/. Reverse the positions of the two element types in the bimap. /Version: 0.2/-} twist :: Bimap a b -> Bimap b a twist (MkBimap left right) = MkBimap right left {-| /O(1)/. Reverse the positions of the two element types in a bimap transformation. /Version: 0.2/-} twisted :: (Bimap a b -> Bimap a b) -> (Bimap b a -> Bimap b a) twisted f = twist . f . twist {-| /O(n)/. Fold the association pairs in the map, such that @'fold' f z == 'foldr' f z . 'assocs'@. /Version: 0.2/-} fold :: (a -> b -> c -> c) -> c -> Bimap a b -> c fold f z = foldr (uncurry f) z . assocs {-| /O(n*log n)/ Map a function over all the left keys in the map. /Version 0.3/-} map :: Ord c => (a -> c) -> Bimap a b -> Bimap c b map f (MkBimap left right) = MkBimap (M.mapKeys f left) (M.map f right) {-| /O(n*log n)/ Map a function over all the right keys in the map. /Version 0.3/-} mapR :: Ord c => (b -> c) -> Bimap a b -> Bimap a c mapR f (MkBimap left right) = MkBimap (M.map f left) (M.mapKeys f right) {-| /O(n)/. Map a strictly increasing function over all left keys in the map. /The precondition is not checked./ /Version 0.3/-} mapMonotonic :: (a -> c) -> Bimap a b -> Bimap c b mapMonotonic f (MkBimap left right) = MkBimap (M.mapKeysMonotonic f left) (M.map f right) {-| /O(n)/. Map a strictly increasing function over all right keys in the map. /The precondition is not checked./ /Version 0.3/-} mapMonotonicR :: (b -> c) -> Bimap a b -> Bimap a c mapMonotonicR f (MkBimap left right) = MkBimap (M.map f left) (M.mapKeysMonotonic f right) {-| /O(log n)/. Delete and find the element with maximal left key. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} deleteFindMax :: (Ord b) => Bimap a b -> ((a, b), Bimap a b) deleteFindMax (MkBimap left right) = ((a, b), MkBimap left' right') where ((a, b), left') = M.deleteFindMax left right' = b `M.delete` right {-| /O(log n)/. Delete and find the element with maximal right key. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} deleteFindMaxR :: (Ord a) => Bimap a b -> ((b, a), Bimap a b) deleteFindMaxR = second twist . deleteFindMax . twist where second f (x, y) = (x, f y) {-| /O(log n)/. Delete the element with maximal left key. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} deleteMax :: (Ord b) => Bimap a b -> Bimap a b deleteMax = snd . deleteFindMax {-| /O(log n)/. Delete the element with maximal right key. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} deleteMaxR :: (Ord a) => Bimap a b -> Bimap a b deleteMaxR = snd . deleteFindMaxR {-| /O(log n)/. Find the element with maximal left key. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} findMax :: Bimap a b -> (a, b) findMax = M.findMax . toMap {-| /O(log n)/. Find the element with maximal right key. The right-hand key is the first entry in the pair. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} findMaxR :: Bimap a b -> (b, a) findMaxR = M.findMax . toMapR {-| /O(log n)/. Delete and find the element with minimal left key. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} deleteFindMin :: (Ord b) => Bimap a b -> ((a, b), Bimap a b) deleteFindMin (MkBimap left right) = ((a, b), MkBimap left' right') where ((a, b), left') = M.deleteFindMin left right' = b `M.delete` right {-| /O(log n)/. Delete and find the element with minimal right key. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} deleteFindMinR :: (Ord a) => Bimap a b -> ((b, a), Bimap a b) deleteFindMinR = second twist . deleteFindMin . twist where second f (x, y) = (x, f y) {-| /O(log n)/. Delete the element with minimal left key. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} deleteMin :: (Ord b) => Bimap a b -> Bimap a b deleteMin = snd . deleteFindMin {-| /O(log n)/. Delete the element with minimal right key. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} deleteMinR :: (Ord a) => Bimap a b -> Bimap a b deleteMinR = snd . deleteFindMinR {-| /O(log n)/. Find the element with minimal left key. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} findMin :: Bimap a b -> (a, b) findMin = M.findMin . toMap {-| /O(log n)/. Find the element with minimal right key. The right-hand key is the first entry in the pair. Calls @'error'@ if the bimap is empty. /Version: 0.2.2/-} findMinR :: Bimap a b -> (b, a) findMinR = M.findMin . toMapR bimap-0.5.0/Data/BimapExt.hs0000644000000000000000000000103314237572147013721 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-| An auxiliary module that exports the 'IsList' class from "GHC.Exts". We use this intermediate module to isolate a safe feature from an otherwise non-safe module, and prevent all of "Data.Bimap" from being marked as not safe just because we are importing "GHC.Exts". The module only exports a class, and the class does not define any methods in an unsafe way. We therefore consider it safe and mark this module as trustworthy. -} module Data.BimapExt ( IsList(..) ) where import GHC.Exts (IsList(..)) bimap-0.5.0/Test/RunTests.hs0000644000000000000000000000052612610510523014032 0ustar0000000000000000#!/usr/bin/env runhaskell {-# LANGUAGE TemplateHaskell #-} {- A stub file that uses Test.Util to extract and splice all the test names from Test.Tests. -} import Test.Tests import Test.Util import System.Exit main :: IO () main = do allPassed <- $( extractTests "Test/Tests.hs" ) if allPassed then exitSuccess else exitFailure bimap-0.5.0/Test/Tests.hs0000644000000000000000000003407113500611633013352 0ustar0000000000000000module Test.Tests where import Data.List (nub, sort) import qualified Data.Set as S import Prelude hiding (null, lookup, filter,map) import qualified Prelude as P import Test.QuickCheck import Control.Applicative((<$>)) import Data.Bimap (.:) = (.).(.) instance (Ord a, Arbitrary a, Ord b, Arbitrary b) => Arbitrary (Bimap a b) where arbitrary = fromList `fmap` arbitrary instance (Ord a, CoArbitrary a, Ord b, CoArbitrary b) => CoArbitrary (Bimap a b) where coarbitrary = coarbitrary . toList -- generator for filter/partition classification functions data FilterFunc a b = FilterFunc String (a -> b -> Bool) instance Show (FilterFunc a b) where show (FilterFunc desc _) = desc instance (Integral a, Arbitrary a, Integral b, Arbitrary b) => Arbitrary (FilterFunc a b) where arbitrary = do pivot <- (arbitrary :: Gen Integer) return $ FilterFunc ("(\\x y -> x - y < " ++ show pivot ++ ")") (\x y -> fromIntegral x - fromIntegral y < pivot) instance (Integral a, CoArbitrary a, Integral b, CoArbitrary b) => CoArbitrary (FilterFunc a b) where coarbitrary _ gen = do x <- arbitrary coarbitrary (x :: Int) gen -- empty bimap has zero size prop_size_empty = size empty == 0 -- empty bimap is null prop_null_empty = null empty -- when converting from a list and back, each pair in the latter -- list was originally in the former list -- (heh, this is probably made redundant by polymorphism) prop_fromList_toList xs = let xs' = toList . fromList $ xs in all (flip elem xs) xs' where _ = xs :: [(Int, Integer)] -- when converting a list to a bimap, each list element either -- ends up in the bimap, or could conceivably have been clobbered prop_fromList_account xs = all (\x -> isMember x || notUnique x) xs where _ = xs :: [(Int, Integer)] bi = fromList xs isMember x = x `pairMember` bi notUnique (x, y) = ((>1) . length . P.filter (== x) . P.map fst $ xs) || ((>1) . length . P.filter (== y) . P.map snd $ xs) -- a bimap created from a list is no larger than the list prop_fromList_size xs = (size $ fromList xs) <= length xs where _ = xs :: [(Int, Integer)] -- a monotone bimap can be reconstituted via fromAscPairList prop_fromAscPairList_reconstitute xs = and [ valid bi' , (bi == bi') ] where xs' = zip (sort $ P.map fst xs) (sort $ P.map snd xs) bi :: Bimap Int Integer bi = fromList xs' bi' = fromAscPairList . toAscList $ bi -- fromAscPairList will never produce an invalid bimap prop_fromAscPairList_check xs = valid bi where xs' = zip (nub $ sort $ P.map fst xs) (nub $ sort $ P.map snd xs) bi :: Bimap Int Integer bi = fromAscPairList xs' -- if a pair is a member of the bimap, then both elements are present -- and associated with each other prop_pairMember bi k v = ((k, v) `pairMember` bi) == and [ k `member` bi , v `memberR` bi , lookup k bi == Just v , lookupR v bi == Just k ] where _ = bi :: Bimap Int Integer -- an inserted pair ends up in the bimap prop_insert_member bi k v = (k, v) `pairMember` (insert k v bi) where _ = bi :: Bimap Int Integer -- if we insert a pair with an existing value, the old value's twin -- is no longer in the bimap prop_clobberL bi b' = (not . null $ bi) && (b' `notMemberR` bi) ==> (a, b) `pairNotMember` insert a b' bi where (a, b) = head . toList $ bi :: (Int, Integer) prop_clobberR bi a' = (not . null $ bi) && (a' `notMember` bi) ==> (a, b) `pairNotMember` insert a' b bi where (a, b) = head . toList $ bi :: (Int, Integer) -- if we politely insert two members, neither of which is present, -- then the two are successfully associated prop_tryInsert_member bi k v = (k, v) `neitherMember` bi ==> pairMember (k, v) (tryInsert k v bi) where _ = bi :: Bimap Int Integer neitherMember (k, v) bi = k `notMember` bi && v `notMemberR` bi -- polite insertion will never remove existing associations prop_tryInsert_not_clobber bi k v = all (flip pairMember $ tryInsert k v bi) (toList bi) where _ = bi :: Bimap Int Integer -- an arbitrary bimap is valid prop_valid bi = valid bi where _ = bi :: Bimap Int Integer -- if x maps to y, then y maps to x prop_member_twin bi = flip all (toList bi) $ \(x, y) -> and [ (bi ! x) `memberR` bi , (bi !> y) `member` bi ] where _ = bi :: Bimap Int Integer -- deleting an element removes it from the map prop_delete bi = flip all (toList bi) $ \(x, y) -> and [ x `notMember` delete x bi , y `notMemberR` deleteR y bi ] where _ = bi :: Bimap Int Integer -- deleting an element removes its twin from the map prop_delete_twin bi = flip all (toList bi) $ \(x, y) -> and [ (bi ! x) `notMemberR` delete x bi , (bi !> y) `notMember` deleteR y bi ] where _ = bi :: Bimap Int Integer -- adjust and fmap are similar prop_adjust_fmap bi a = l === r where l = lookup a $ adjust f a bi :: Maybe Integer r = f <$> lookup a bi _ = bi :: Bimap Int Integer f = (1-) prop_adjustR_fmap bi b = l == r where l = lookupR b $ adjustR f b bi :: Maybe Int r = f <$> lookupR b bi _ = bi :: Bimap Int Integer f = (3*) -- a singleton bimap is valid, has one association, and the two -- given values map to each other prop_singleton x y = let bi = singleton x y in and [ valid bi , (x, y) `pairMember` bi , (bi ! x) == y , (bi !> y) == x , size bi == 1 ] where _ = (x, y) :: (Int, Integer) -- an always-true filter makes no changes prop_filter_true bi = bi == filter (curry $ const True) bi where _ = bi :: Bimap Int Integer -- an always-false filter gives an empty result prop_filter_false bi = null $ filter (curry $ const False) bi where _ = bi :: Bimap Int Integer -- all elements of the projection satisfy the predicate, and all -- elements of the rejection do not prop_partition_agree bi (FilterFunc _ ff) = and [ all ( uncurry ff) (toList projection) , all (not . uncurry ff) (toList rejection) ] where _ = bi :: Bimap Int Integer (projection, rejection) = partition ff bi -- the two halves of a partition are disjoint prop_partition_disjoint bi (FilterFunc _ ff) = S.null $ S.intersection (asSet projection) (asSet rejection) where _ = bi :: Bimap Int Integer (projection, rejection) = partition ff bi asSet = S.fromList . toList -- the two halves of a partition contain the elements of the original -- bimap prop_partition_union bi (FilterFunc _ ff) = (==) (asSet bi) $ S.union (asSet projection) (asSet rejection) where _ = bi :: Bimap Int Integer (projection, rejection) = partition ff bi asSet = S.fromList . toList -- the two halves of a partition agree with individual filters prop_partition_filter bi (FilterFunc _ ff) = and [ projection == filter ( ff) bi , rejection == filter (not .: ff) bi ] where _ = bi :: Bimap Int Integer (projection, rejection) = partition ff bi -- partition and filter produce valid results prop_partition_filter_valid bi (FilterFunc _ ff) = all valid [ projection , rejection , filter ( ff) bi , filter (not .: ff) bi ] where _ = bi :: Bimap Int Integer (projection, rejection) = partition ff bi -- twist is its own inverse prop_twist_twist bi = bi == (twist . twist $ bi) where _ = bi :: Bimap Int Integer -- the property (fromList == fromAList . reverse) only holds -- if either the left or right values are all distinct prop_fromList_fromAList xs = and [ fromList ys == fromAList rys , fromList rys == fromAList ys ] where ys = xs `zip` [1..] :: [(Int, Integer)] rys = reverse ys swap (x, y) = (y, x) -- deleteFindMin and deleteMin agree prop_deleteMin_is_delete bi = not (null bi) ==> snd (deleteFindMin bi) == deleteMin bi where _ = bi :: Bimap Int Integer -- deleteFindMin and findMin agree prop_deleteMin_is_find bi = not (null bi) ==> fst (deleteFindMin bi) == findMin bi where _ = bi :: Bimap Int Integer -- elements removed by deleteFindMin are no longer in the bimap prop_deleteMin_deletes bi = not (null bi) ==> fst (deleteFindMin bi) `pairNotMember` snd (deleteFindMin bi) where _ = bi :: Bimap Int Integer -- findMin finds a member of the map prop_findMin_member bi = not (null bi) ==> findMin bi `pairMember` bi where _ = bi :: Bimap Int Integer -- the minimum of a singleton bimap is its contents prop_singleton_is_findMin x y = findMin bi == (x, y) where bi :: Bimap Int Integer bi = singleton x y -- deleting the minimum of a singleton leaves it empty prop_singleton_deleteMin_empty x y = null (deleteMin bi) where bi :: Bimap Int Integer bi = singleton x y -- the minimum of a bimap is <= all other elements prop_findMin_is_minimal bi = all (\ (a, _) -> a >= x) lst where lst = toList bi _ = bi :: Bimap Int Integer x = fst . findMin $ bi prop_deleteMinR_is_delete bi = not (null bi) ==> snd (deleteFindMinR bi) == deleteMinR bi where _ = bi :: Bimap Int Integer prop_deleteMinR_is_find bi = not (null bi) ==> fst (deleteFindMinR bi) == findMinR bi where _ = bi :: Bimap Int Integer prop_deleteMinR_deletes bi = not (null bi) ==> (swap . fst) (deleteFindMinR bi) `pairNotMember` snd (deleteFindMinR bi) where _ = bi :: Bimap Int Integer prop_findMinR_member bi = not (null bi) ==> swap (findMinR bi) `pairMember` bi where _ = bi :: Bimap Int Integer prop_singleton_is_findMinR x y = findMinR bi == (y, x) where bi :: Bimap Int Integer bi = singleton x y prop_singleton_deleteMinR_empty x y = null (deleteMinR bi) where bi :: Bimap Int Integer bi = singleton x y prop_findMinR_is_minimal bi = all (\ (_, b) -> b >= y) lst where lst = toList bi _ = bi :: Bimap Int Integer y = fst . findMinR $ bi prop_deleteMax_is_delete bi = not (null bi) ==> snd (deleteFindMax bi) == deleteMax bi where _ = bi :: Bimap Int Integer prop_deleteMax_is_find bi = not (null bi) ==> fst (deleteFindMax bi) == findMax bi where _ = bi :: Bimap Int Integer prop_deleteMax_deletes bi = not (null bi) ==> fst (deleteFindMax bi) `pairNotMember` snd (deleteFindMax bi) where _ = bi :: Bimap Int Integer prop_findMax_member bi = not (null bi) ==> findMax bi `pairMember` bi where _ = bi :: Bimap Int Integer prop_singleton_is_findMax x y = findMax bi == (x, y) where bi :: Bimap Int Integer bi = singleton x y prop_singleton_deleteMax_empty x y = null (deleteMax bi) where bi :: Bimap Int Integer bi = singleton x y prop_findMax_is_maximal bi = all (\ (a, _) -> a <= x) lst where lst = toList bi _ = bi :: Bimap Int Integer x = fst . findMax $ bi prop_deleteMaxR_is_delete bi = not (null bi) ==> snd (deleteFindMaxR bi) == deleteMaxR bi where _ = bi :: Bimap Int Integer prop_deleteMaxR_is_find bi = not (null bi) ==> fst (deleteFindMaxR bi) == findMaxR bi where _ = bi :: Bimap Int Integer prop_deleteMaxR_deletes bi = not (null bi) ==> (swap . fst) (deleteFindMaxR bi) `pairNotMember` snd (deleteFindMaxR bi) where _ = bi :: Bimap Int Integer prop_findMaxR_member bi = not (null bi) ==> swap (findMaxR bi) `pairMember` bi where _ = bi :: Bimap Int Integer prop_singleton_is_findMaxR x y = findMaxR bi == (y, x) where bi :: Bimap Int Integer bi = singleton x y prop_singleton_deleteMaxR_empty x y = null (deleteMaxR bi) where bi :: Bimap Int Integer bi = singleton x y prop_findMaxR_is_maximal bi = all (\ (_, b) -> b <= y) lst where lst = toList bi _ = bi :: Bimap Int Integer y = fst . findMaxR $ bi prop_deleteMin_is_valid bi = not (null bi) ==> valid (deleteMin bi) where _ = bi :: Bimap Int Integer prop_deleteFindMin_is_valid bi = not (null bi) ==> valid (snd $ deleteFindMin bi) where _ = bi :: Bimap Int Integer prop_deleteMinR_is_valid bi = not (null bi) ==> valid (deleteMinR bi) where _ = bi :: Bimap Int Integer prop_deleteFindMinR_is_valid bi = not (null bi) ==> valid (snd $ deleteFindMinR bi) where _ = bi :: Bimap Int Integer prop_deleteMax_is_valid bi = not (null bi) ==> valid (deleteMax bi) where _ = bi :: Bimap Int Integer prop_deleteFindMax_is_valid bi = not (null bi) ==> valid (snd $ deleteFindMax bi) where _ = bi :: Bimap Int Integer prop_deleteMaxR_is_valid bi = not (null bi) ==> valid (deleteMaxR bi) where _ = bi :: Bimap Int Integer prop_deleteFindMaxR_is_valid bi = not (null bi) ==> valid (snd $ deleteFindMaxR bi) where _ = bi :: Bimap Int Integer prop_map_preserve_keys bi = (Data.List.sort $ P.map f $ keys bi) == (keys $ map f bi) where f = (4/) -- This is an arbitrary function _ = bi :: Bimap Double Integer prop_map_preserve_lookup bi v = (lookup (f v) $ map f bi) == (lookup v bi :: Maybe Integer) where f = (1-) _ = bi :: Bimap Int Integer prop_map_preserve_right_keys bi = (Data.List.sort $ P.map f $ keysR bi) == (keysR $ mapR f bi) where f = (4/) -- This is an arbitrary function _ = bi :: Bimap Int Double prop_map_preserve_lookupR bi v = (lookup v $ mapR f bi) == (f <$> lookup v bi :: Maybe Integer) where f = (1-) _ = bi :: Bimap Int Integer prop_mapMonotonic_preserve_keys bi = (P.map f $ keys bi) == (keys $ mapMonotonic f bi) where f = (3+) -- This is an arbitrary monotonic function _ = bi :: Bimap Double Integer prop_mapMonotonic_preserve_lookup bi v = (lookup (f v) $ mapMonotonic f bi) == (lookup v bi :: Maybe Integer) where f = (2*) _ = bi :: Bimap Int Integer prop_mapMontonic_preserve_right_keys bi = (P.map f $ keysR bi) == (keysR $ mapMonotonicR f bi) where f = (^2) -- This is an arbitrary monotonic function _ = bi :: Bimap Int Double prop_mapMonotonic_preserve_lookupR bi v = (lookup v $ mapMonotonicR f bi) == (f <$> lookup v bi :: Maybe Integer) where f = (1-) _ = bi :: Bimap Int Integer bimap-0.5.0/Test/Util.hs0000644000000000000000000000257512610510743013172 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Test.Util ( extractTests, ) where import Control.Arrow import Data.List import Language.Haskell.TH import Language.Haskell.TH.Syntax import Test.QuickCheck import Text.Printf {- Use 'propertyNames' to extract all QuickCheck test names from a file. -} fileProperties :: FilePath -> IO [String] fileProperties = fmap propertyNames . readFile {- Find all the tokens in a file that 1) are the first token on a line, and 2) begin with "prop_". -} propertyNames :: String -> [String] propertyNames = lines >>> map firstToken >>> filter isProperty >>> nub where firstToken = fst . head . lex isProperty = isPrefixOf "prop_" resultIsSuccess Success {} = True resultIsSuccess _ = False mkCheck' name = [| printf "%-25s : " name >> quickCheckResult $(varE (mkName name)) >>= return . resultIsSuccess |] mkChecks' [] = undefined mkChecks' [name] = mkCheck' name mkChecks' (name:ns) = [| do this <- $(mkCheck' name) rest <- $(mkChecks' ns) return $ this && rest |] {- Extract the names of QuickCheck tests from a file, and splice in a sequence of calls to them. The module doing the splicing must also import the file being processed. -} extractTests :: FilePath -> Q Exp extractTests = (mkChecks' =<<) . runIO . fileProperties bimap-0.5.0/HISTORY0000644000000000000000000000174112610573574012073 0ustar0000000000000000Version 0.3.1 (17 October 2015) * Added update and adjust functions (thanks to koral) Version 0.3.0 (12 Mar 2015) * Added map functions Version 0.2.4 (25 Aug 2008) * added filter and partition Version 0.2.3 (1 Jul 2008) * added fromAscPairList and fromAscPairListUnchecked (thanks to Janis Voigtländer) * more tests for min/max functions (thanks to Jochem Berndsen) Version 0.2.2 (18 Jun 2008) * added min/max functions (thanks to Jochem Berndsen) * added tryInsert * added fromAList * more tests for existing functionality Version 0.2.1 (6 Feb 2008) * removed MTL dependency * removed Control.Arrow dependency * now Haskell 98, modulo "foldl'" and hierarchical modules * added toMap and toMapR * added big-O comments * added "version" info in function comments Version 0.2 (5 Feb 2008) * large, incompatible interface overhaul * GHC 6.8 support * Eq instance Version 0.1 (4 Feb 2008) * initial release * Data.Bimap and test suite bimap-0.5.0/LICENSE0000644000000000000000000000277512610502573012013 0ustar0000000000000000Copyright Stuart Cook and contributors 2008 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Stuart Cook nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. bimap-0.5.0/Setup.hs0000644000000000000000000000005612612322012012416 0ustar0000000000000000import Distribution.Simple main = defaultMain bimap-0.5.0/bimap.cabal0000644000000000000000000000354114240055072013050 0ustar0000000000000000cabal-version: >= 1.10 name: bimap version: 0.5.0 synopsis: Bidirectional mapping between two key types description: A data structure representing a bidirectional mapping between two key types. Each value in the bimap is associated with exactly one value of the opposite type. category: Data license: BSD3 license-file: LICENSE copyright: Stuart Cook and contributors 2008, Joel Williamson 2015 author: Stuart Cook and contributors 2008, Joel Williamson 2015 maintainer: Joel Williamson homepage: https://github.com/joelwilliamson/bimap build-type: Simple tested-with: GHC <= 8.6.4 && >= 7.0 extra-source-files: HISTORY Library build-depends: base >= 4 && <5, containers, deepseq, exceptions if impl(ghc < 7.6.1) build-depends: ghc-prim default-extensions: CPP DeriveGeneric TypeFamilies else default-extensions: CPP TypeFamilies default-language: Haskell98 ghc-options: -Wall exposed-modules: Data.Bimap if impl(ghc >= 7.8) other-modules: Data.BimapExt test-suite tests type: exitcode-stdio-1.0 main-is: Test/RunTests.hs other-modules: Test.Tests Test.Util build-depends: base >= 4 && < 5, containers, deepseq, exceptions, QuickCheck >= 2 && < 3, template-haskell >= 2 && < 3 if impl(ghc < 7.6.1) build-depends: ghc-prim default-extensions: TemplateHaskell default-language: Haskell98 source-repository head type: git location: https://github.com/joelwilliamson/bimap.git