packages feed

bimap (empty) → 0.1

raw patch · 8 files changed

+460/−0 lines, 8 filesdep +basedep +mtlbuild-type:Customsetup-changed

Dependencies added: base, mtl

Files

+ Data/Bimap.hs view
@@ -0,0 +1,247 @@+{-|+An implementation of bidirectional maps between values of two+key types. A 'Bimap' is essentially a bijection between subsets of+its two argument types.++For functions with an @L@ or @R@ suffix, the letter indicates whether+the /parameter/ type is specialized to the left or right type of+the bimap.+-}+module Data.Bimap (+    -- * Bimap type+    Bimap(),+    -- * Query+    null,+    size,+    member,+    memberL,+    memberR,+    notMember,+    notMemberL,+    notMemberR,+    pairMember,+    pairNotMember,+    lookup,+    lookupL,+    lookupR,+    (!),+    (!<),+    (!>),+    -- * Construction+    empty,+    singleton,+    -- * Update+    insert,+    delete,+    deleteL,+    deleteR,+    -- * Conversion\/traversal+    fromList,+    toList,+    assocs,+    fold,+    -- * Miscellaneous+    valid,+    twist,+) where++import Control.Arrow ((>>>))+import Control.Monad (liftM)+import Control.Monad.Error () -- Monad instance for Either e+import Data.List (foldl', sort)+import qualified Data.Map as M+import Prelude hiding (lookup, null)+++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)++instance (Show a, Ord a, Show b, Ord b) => Show (Bimap a b) where+    show x = "fromList " ++ (show . toList $ x)++{-| The empty bimap. -}+empty :: Bimap a b+empty = MkBimap M.empty M.empty++{-| A bimap with a single element. -}+singleton :: (Ord a, Ord b)+          => (a, b) -> Bimap a b+singleton xy = unsafeInsert xy empty++{-| Is the bimap empty? -}+null :: Bimap a b -> Bool+null (MkBimap left _) = M.null left++{-| The number of elements in the bimap. -}+size :: Bimap a b -> Int+size (MkBimap left _) = M.size left++{-| Is the specified value a member of the bimap? -}+member :: (Ord a, Ord b)+       => Either a b -> Bimap a b -> Bool+member (Left  x) (MkBimap left  _) = M.member x left+member (Right y) (MkBimap _ right) = M.member y right++{-| A version of 'member' specialized to the left key. -}+memberL :: (Ord a, Ord b) => a -> Bimap a b -> Bool+memberL = member . Left+{-| A version of 'member' specialized to the right key. -}+memberR :: (Ord a, Ord b) => b -> Bimap a b -> Bool+memberR = member . Right++{-| Is the specified value not a member of the bimap? -}+notMember :: (Ord a, Ord b)+          => Either a b -> Bimap a b -> Bool+notMember = not .: member++{-| A version of 'notMember' specialized to the left key. -}+notMemberL :: (Ord a, Ord b) => a -> Bimap a b -> Bool+notMemberL = notMember . Left+{-| A version of 'notMember' specialized to the right key. -}+notMemberR :: (Ord a, Ord b) => b -> Bimap a b -> Bool+notMemberR = notMember . Right++{-| Are the two values associated /with each other/ in the bimap? -}+pairMember :: (Ord a, Ord b)+           => (a, b) -> Bimap a b -> Bool+pairMember (x, y) (MkBimap left _) =+    maybe False (== y) (M.lookup x left)++{-| Are the two values not in the bimap, or not associated with+each other? (Complement of 'pairMember'.) -}+pairNotMember :: (Ord a, Ord b)+              => (a, b) -> Bimap a b -> Bool+pairNotMember = not .: pairMember++{-| 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.+-}+insert :: (Ord a, Ord b)+        => (a, b) -> Bimap a b -> Bimap a b+insert (x, y) = delete (Left x)+            >>> delete (Right y)+            >>> unsafeInsert (x, y)++{-| 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)++{-| Delete a value and its twin from a bimap.+When the value is not a member of the bimap, the original bimap is+returned.+-}+delete :: (Ord a, Ord b)+       => Either a b -> Bimap a b -> Bimap a b+delete e (MkBimap left right) =+    MkBimap+        (perhaps M.delete x $ left)+        (perhaps M.delete y $ right)+    where+    perhaps = maybe id+    x = either Just (flip M.lookup right) e+    y = either (flip M.lookup left) Just  e++{-| A version of 'delete' specialized to the left key. -}+deleteL :: (Ord a, Ord b) => a -> Bimap a b -> Bimap a b+deleteL = delete . Left+{-| A version of 'delete' specialized to the right key. -}+deleteR :: (Ord a, Ord b) => b -> Bimap a b -> Bimap a b+deleteR = delete . Right++{-| Lookup the twin of a value in the bimap, returning both+associated values as a pair.++This function will @return@ the result in the monad, or @fail@ if+the value isn't in the bimap.+-}+lookup :: (Ord a, Ord b, Monad m)+       => Either a b -> Bimap a b -> m (a, b)+lookup (Left x)  (MkBimap left _) =+    maybe (fail "Data.Bimap.lookup: Left key not found")+          (\y -> return (x, y))+          (M.lookup x left)+lookup (Right y) (MkBimap _ right) =+    maybe (fail "Data.Bimap.lookup: Right key not found")+          (\x -> return (x, y))+          (M.lookup y right)++{-| A version of 'lookup' that is specialized to the left key,+and returns only the right key. -}+lookupL :: (Ord a, Ord b, Monad m)+        => a -> Bimap a b -> m b+lookupL = (liftM snd) .: lookup . Left+{-| A version of 'lookup' that is specialized to the right key,+and returns only the left key. -}+lookupR :: (Ord a, Ord b, Monad m)+        => b -> Bimap a b -> m a+lookupR = (liftM fst) .: lookup . Right++{-| Find the pair corresponding to a given value. Calls @'error'@+when the value is not in the bimap.+-}+(!) :: (Ord a, Ord b)+    => Bimap a b -> Either a b -> (a, b)+(!) bi e = either error id (lookup e bi)++{-| A version of '(!)' that is specialized to the left key,+and returns only the right key. -}+(!<) :: (Ord a, Ord b) => Bimap a b -> a -> b+(!<) bi x = snd $ bi ! Left  x+{-| A version of '(!)' that is specialized to the right key,+and returns only the left key. -}+(!>) :: (Ord a, Ord b) => Bimap a b -> b -> a+(!>) bi y = fst $ bi ! Right y++{-| 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.+-}+fromList :: (Ord a, Ord b)+         => [(a, b)] -> Bimap a b+fromList xs = foldl' (flip insert) empty xs++{-| Convert to a list of associated pairs. -}+toList :: Bimap a b -> [(a, b)]+toList (MkBimap left _) = M.toList left++{-| Return all associated pairs in the bimap, with the left-hand+values in ascending order. -}+assocs :: Bimap a b -> [(a, b)]+assocs = toList++{-| Test if the internal bimap structure is valid. -}+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 . map flipPair . M.toList $ right)+    ]+    where+    flipPair (x, y) = (y, x)++{-| Reverse the positions of the two element types in the bimap. -}+twist :: (Ord a, Ord b)+      => Bimap a b -> Bimap b a+twist (MkBimap left right) = MkBimap right left++{-| Fold the association pairs in the map, such that+@'fold' f z == 'foldr' f z . 'assocs'@.+-}+fold :: ((a, b) -> c -> c) -> c -> Bimap a b -> c+fold f z = foldr f z . assocs+++
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Stuart Cook 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.+
+ Setup.lhs view
@@ -0,0 +1,9 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> import System.Cmd+> import System.Exit++> main = defaultMainWithHooks (defaultUserHooks { runTests = suite })+>     where+>     suite _ _ _ _ = system "bash tests.sh" >> return ()+
+ Test/RunTests.hs view
@@ -0,0 +1,13 @@+#!/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++main :: IO ()+main = $( extractTests "Test/Tests.hs" )
+ Test/Tests.hs view
@@ -0,0 +1,81 @@+module Test.Tests where++import Prelude hiding (null)+import Test.QuickCheck++import Data.Bimap+++instance (Ord a, Arbitrary a, Ord b, Arbitrary b)+    => Arbitrary (Bimap a b) where+    arbitrary = fromList `fmap` arbitrary+    coarbitrary = coarbitrary . toList+++prop_size_empty = size empty == 0++prop_null_empty = null empty++-- (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 . filter (== x) . map fst $ xs) ||+        ((>1) . length . filter (== y) . map snd $ xs)++prop_fromList_size xs = (size $ fromList xs) <= length xs+    where+    _ = xs :: [(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) && (Right b' `notMember` bi)+    ==>+    (a, b) `pairNotMember` insert (a, b') bi+    where+    (a, b) = head . toList $ bi :: (Int, Integer)++prop_clobberR bi a' =+    (not . null $ bi) && (Left a' `notMember` bi)+    ==>+    (a, b) `pairNotMember` insert (a', b) bi+    where+    (a, b) = head . toList $ bi :: (Int, Integer)++-- an arbitrary bimap is valid+prop_valid bi = valid bi+    where+    _ = bi :: Bimap Int Integer++prop_member_twin bi = flip all (toList bi) $ \(x, y) -> and+    [ (Right . snd $ bi ! Left  x) `member` bi+    , (Left  . fst $ bi ! Right y) `member` bi+    ]+    where+    _ = bi :: Bimap Int Integer++prop_delete bi = flip all (toList bi) $ \(x, y) -> and+    [ (Left  x) `notMember` delete (Left  x) bi+    , (Right y) `notMember` delete (Right y) bi+    ]+    where+    _ = bi :: Bimap Int Integer++prop_delete_twin bi = flip all (toList bi) $ \(x, y) -> and+    [ (Right . snd $ bi ! Left  x) `notMember` delete (Left  x) bi+    , (Left  . fst $ bi ! Right y) `notMember` delete (Right y) bi+    ]+    where+    _ = bi :: Bimap Int Integer
+ Test/Util.hs view
@@ -0,0 +1,48 @@+{-# 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_"++{- Inspired by & borrowed from: -}+-- http://blog.codersbase.com/2006/09/01/simple-unit-testing-in-haskell/+mkCheck name =+    [| printf "%-25s : " name >> quickCheck $(varE (mkName name)) |]++mkChecks []        = undefined -- if we don't have any tests, then the test suite is undefined right?+mkChecks [name]    = mkCheck name+mkChecks (name:ns) = [| $(mkCheck name) >> $(mkChecks ns) |]++{-+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.cabal view
@@ -0,0 +1,26 @@+cabal-version:       >= 1.2.3.0+name:                bimap+version:             0.1+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+author:              Stuart Cook+maintainer:          scook0@gmail.com+homepage:            http://code.haskell.org/bimap+extra-source-files:+    tests.sh+    Test/Tests.hs+    Test/Util.hs+    Test/RunTests.hs++Library+  build-depends:       base, mtl+  ghc-options:         -Wall -O2+  exposed-modules:+      Data.Bimap+
+ tests.sh view
@@ -0,0 +1,5 @@+#!/bin/bash+# ensure that an error in the test program doesn't accidentally+# produce success+set -o pipefail+(runhaskell Test/RunTests.hs | tee .test.log) && if grep Falsifiable .test.log >/dev/null; then exit 1; fi