Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Initial import

  • Loading branch information...
commit 82ae5045f7a9dbee959d8d6f03f0c6a185f10f82 0 parents
@tibbe authored
113 Data/FullList.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE BangPatterns, CPP #-}
+
+module Data.FullList
+ ( FullList
+
+ -- * Basic interface
+ , singleton
+ , lookup
+ , insert
+ , delete
+ , fold
+ ) where
+
+import Control.DeepSeq (NFData(rnf))
+import Prelude hiding (lookup)
+
+------------------------------------------------------------------------
+-- * The 'FullList' type
+
+data FullList k v = FL !k !v !(List k v)
+
+instance (NFData k, NFData v) => NFData (FullList k v)
+
+data List k v = Nil | Cons !k !v !(List k v)
+
+instance (NFData k, NFData v) => NFData (List k v) where
+ rnf Nil = ()
+ rnf (Cons k v xs) = rnf k `seq` rnf v `seq` rnf xs
+
+-- TODO: Check if evaluation is forced.
+
+------------------------------------------------------------------------
+-- * FullList
+
+singleton :: k -> v -> FullList k v
+singleton k v = FL k v Nil
+
+lookup :: Eq k => k -> FullList k v -> Maybe v
+lookup k (FL k' v xs)
+ | k == k' = Just v
+ | otherwise = lookupL k xs
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE lookup #-}
+#endif
+
+insert :: Eq k => k -> v -> FullList k v -> FullList k v
+insert k v (FL k' v' xs)
+ | k == k' = FL k v xs
+ | otherwise = FL k' v' (insertL k v xs)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE insert #-}
+#endif
+
+delete :: Eq k => k -> FullList k v -> Maybe (FullList k v)
+delete k (FL k' v xs)
+ | k == k' = case xs of
+ Nil -> Nothing
+ Cons k'' v' xs' -> Just $ FL k'' v' xs'
+ | otherwise = Just $ FL k' v (deleteL k xs)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE delete #-}
+#endif
+
+fold :: (k -> v -> a -> a) -> a -> FullList k v -> a
+fold f z (FL k v xs) = f k v (foldL f z xs)
+{-# INLINE fold #-}
+
+------------------------------------------------------------------------
+-- * List
+
+lookupL :: Eq k => k -> List k v -> Maybe v
+lookupL = go
+ where
+ go !_ Nil = Nothing
+ go k (Cons k' v xs)
+ | k == k' = Just v
+ | otherwise = go k xs
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE lookupL #-}
+#endif
+
+-- TODO: Reduce copying by always inserting at the head of the list?
+
+-- | /O(n)/ Insert at the head of the list to avoid copying the whole
+-- list.
+insertL :: Eq k => k -> v -> List k v -> List k v
+insertL = go
+ where
+ go !k v Nil = Cons k v Nil
+ go k v (Cons k' v' xs)
+ | k == k' = Cons k v xs
+ | otherwise = Cons k' v' (go k v xs)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE insertL #-}
+#endif
+
+deleteL :: Eq k => k -> List k v -> List k v
+deleteL = go
+ where
+ go !_ Nil = Nil
+ go k (Cons k' v xs)
+ | k == k' = xs
+ | otherwise = Cons k' v (go k xs)
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE deleteL #-}
+#endif
+
+foldL :: (k -> v -> a -> a) -> a -> List k v -> a
+foldL f = go
+ where
+ go z Nil = z
+ go z (Cons k v xs) = f k v (go z xs)
+{-# INLINE foldL #-}
210 Data/HashMap.hs
@@ -0,0 +1,210 @@
+{-# LANGUAGE BangPatterns, CPP, MagicHash #-}
+
+------------------------------------------------------------------------
+-- |
+-- Module : Data.HashMap
+-- Copyright : 2010 Johan Tibell
+-- License : BSD-style
+-- Maintainer : johan.tibell@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Maps from keys to values. The implementation is based on
+-- /big-endian patricia trees/ which are keyed by the hash value of
+-- the original key. A 'HashMap' is often faster than an tree-based
+-- ordered map when key comparison is expensive, as in the case of
+-- strings.
+--
+-- Many operations have a worst-case complexity of /O(min(n,W))/.
+-- This means that the operation can become linear in the number of
+-- elements with a maximum of /W/ -- the number of bits in an 'Int'
+-- (32 or 64).
+
+module Data.HashMap
+ (
+ HashMap
+
+ -- * Basic interface
+ , size
+ , lookup
+ , empty
+ , insert
+ , delete
+ , toList
+ ) where
+
+import Control.DeepSeq (NFData(rnf))
+import Data.Bits ((.&.), (.|.), complement, shiftR, xor)
+import Data.Hashable (Hashable(hash))
+import qualified Data.FullList as FL
+import Data.Word (Word)
+import Prelude hiding (lookup)
+
+------------------------------------------------------------------------
+-- * The 'HashMap' type
+
+-- | A map from keys to values. A map cannot contain duplicate keys;
+-- each key can map to at most one value.
+data HashMap k v
+ = Nil
+ | Tip {-# UNPACK #-} !Hash
+ {-# UNPACK #-} !(FL.FullList k v)
+ | Bin {-# UNPACK #-} !Prefix
+ {-# UNPACK #-} !Mask
+ !(HashMap k v)
+ !(HashMap k v)
+
+instance (NFData k, NFData v) => NFData (HashMap k v) where
+ rnf Nil = ()
+ rnf (Tip _ xs) = rnf xs
+ rnf (Bin _ _ l r) = rnf l `seq` rnf r `seq` ()
+
+type Prefix = Int
+type Mask = Int
+type Hash = Int
+
+-- | /O(n)/ Return the number of key-value mappings in this map.
+size :: HashMap k v -> Int
+size t = case t of
+ Bin _ _ l r -> size l + size r
+ Tip _ _ -> 1
+ Nil -> 0
+
+-- | /O(min(n,W))/ Return the value to which the specified key is
+-- mapped, or 'Nothing' if this map contains no mapping for the key.
+lookup :: (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
+lookup k0 t = go h0 k0 t
+ where
+ h0 = hash k0
+ go !h !k (Bin _ m l r)
+ | zero h m = go h k l
+ | otherwise = go h k r
+ go h k (Tip h' l)
+ | h == h' = FL.lookup k l
+ | otherwise = Nothing
+ go _ _ Nil = Nothing
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE lookup #-}
+#endif
+
+-- | /O(1)/ Construct an empty 'HashMap'.
+empty :: HashMap k v
+empty = Nil
+
+-- | /O(min(n,W))/ Associate the specified value with the specified
+-- key in this map. If the map previously contained a mapping for the
+-- key, the old value is replaced.
+insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v
+insert k0 v0 t0 = go h0 k0 v0 t0
+ where
+ h0 = hash k0
+ go !h !k v t@(Bin p m l r)
+ | nomatch h p m = join h (Tip h $ FL.singleton k v) p t
+ | zero h m = Bin p m (go h k v l) r
+ | otherwise = Bin p m l (go h k v r)
+ go h k v t@(Tip h' l)
+ | h == h' = Tip h $ FL.insert k v l
+ | otherwise = join h (Tip h $ FL.singleton k v) h' t
+ go h k v Nil = Tip h $ FL.singleton k v
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE insert #-}
+#endif
+
+-- | /O(min(n,W))/ Remove the mapping for the specified key from this
+-- map if present.
+delete :: (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
+delete k0 t = go h0 k0 t
+ where
+ h0 = hash k0
+ go !h !k (Bin p m l r)
+ | nomatch h p m = t
+ | zero h m = bin p m (go h k l) r
+ | otherwise = bin p m l (go h k r)
+ go h k (Tip h' l)
+ | h == h' = case FL.delete k l of
+ Nothing -> Nil
+ Just l' -> Tip h' l'
+ | otherwise = t
+ go _ _ Nil = Nil
+#if __GLASGOW_HASKELL__ >= 700
+{-# INLINABLE delete #-}
+#endif
+
+toList :: HashMap k v -> [(k, v)]
+toList = fold (\k v xs -> (k, v) : xs) []
+
+-- | /O(n)/ 'fold', applied to a binary operator, a starting value
+-- (typically the left-identity of the operator), and a 'HashMap',
+-- reduces the 'HashMap' using the binary operator.
+fold :: (k -> v -> a -> a) -> a -> HashMap k v -> a
+fold f = go
+ where
+ go z (Bin _ _ l r) = go (go z r) l
+ go z (Tip _ l) = FL.fold f z l
+ go z Nil = z
+{-# INLINE fold #-}
+
+------------------------------------------------------------------------
+-- Helpers
+
+join :: Prefix -> HashMap k v -> Prefix -> HashMap k v -> HashMap k v
+join p1 t1 p2 t2
+ | zero p1 m = Bin p m t1 t2
+ | otherwise = Bin p m t2 t1
+ where
+ m = branchMask p1 p2
+ p = mask p1 m
+{-# INLINE join #-}
+
+-- | @bin@ assures that we never have empty trees within a tree.
+bin :: Prefix -> Mask -> HashMap k v -> HashMap k v -> HashMap k v
+bin _ _ l Nil = l
+bin _ _ Nil r = r
+bin p m l r = Bin p m l r
+{-# INLINE bin #-}
+
+------------------------------------------------------------------------
+-- Endian independent bit twiddling
+
+zero :: Hash -> Mask -> Bool
+zero i m = (fromIntegral i :: Word) .&. (fromIntegral m :: Word) == 0
+{-# INLINE zero #-}
+
+nomatch :: Hash -> Prefix -> Mask -> Bool
+nomatch i p m = (mask i m) /= p
+{-# INLINE nomatch #-}
+
+mask :: Hash -> Mask -> Prefix
+mask i m = maskW (fromIntegral i :: Word) (fromIntegral m :: Word)
+{-# INLINE mask #-}
+
+------------------------------------------------------------------------
+-- Big endian operations
+
+maskW :: Word -> Word -> Prefix
+maskW i m = fromIntegral (i .&. (complement (m-1) `xor` m))
+{-# INLINE maskW #-}
+
+branchMask :: Prefix -> Prefix -> Mask
+branchMask p1 p2 =
+ fromIntegral (highestBitMask (
+ fromIntegral p1 `xor` fromIntegral p2 :: Word))
+{-# INLINE branchMask #-}
+
+-- | @highestBitMask@ returns a word where only the highest bit is
+-- set. It is found by first setting all bits in lower positions than
+-- the highest bit and than taking an exclusive or with the original
+-- value. Allthough the function may look expensive, GHC compiles
+-- this into excellent C code that subsequently compiled into highly
+-- efficient machine code. The algorithm is derived from Jorg Arndt's
+-- FXT library.
+highestBitMask :: Word -> Word
+highestBitMask x0
+ = case (x0 .|. shiftR x0 1) of
+ x1 -> case (x1 .|. shiftR x1 2) of
+ x2 -> case (x2 .|. shiftR x2 4) of
+ x3 -> case (x3 .|. shiftR x3 8) of
+ x4 -> case (x4 .|. shiftR x4 16) of
+ x5 -> case (x5 .|. shiftR x5 32) of -- for 64 bit platforms
+ x6 -> (x6 `xor` (shiftR x6 1))
+{-# INLINE highestBitMask #-}
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2010, Johan Tibell
+
+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 Johan Tibell 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.
2  Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
30 unordered-containers.cabal
@@ -0,0 +1,30 @@
+name: unordered-containers
+version: 0.1.0.0
+license: BSD3
+license-file: LICENSE
+author: Johan Tibell
+maintainer: johan.tibell@gmail.com
+copyright: 2010 Johan Tibell
+category: Data
+build-type: Simple
+cabal-version: >=1.2
+
+library
+ exposed-modules:
+ Data.HashMap
+
+ build-depends:
+ base,
+ deepseq == 1.1.*,
+ hashable == 1.0.*
+
+ other-modules:
+ Data.FullList
+
+ ghc-options: -Wall -O2
+ if impl(ghc >= 6.8)
+ ghc-options: -fwarn-tabs
+ if impl(ghc > 6.10)
+ ghc-options: -fregs-graph
+
+ extensions: BangPatterns, CPP
Please sign in to comment.
Something went wrong with that request. Please try again.