HsJudy (empty) → 0.1
raw patch · 17 files changed
+1977/−0 lines, 17 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers
Files
- HsJudy.cabal +44/−0
- Judy/BitSet.hs +238/−0
- Judy/CollectionsM.hs +197/−0
- Judy/Freeze.hs +6/−0
- Judy/Hash.hs +229/−0
- Judy/HashIO.hs +43/−0
- Judy/IntMap.hs +315/−0
- Judy/MiniGC.hs +102/−0
- Judy/Private.hs +175/−0
- Judy/Private.hsc +170/−0
- Judy/Private_hsc.c +31/−0
- Judy/Refeable.hs +39/−0
- Judy/StrMap.hs +224/−0
- Judy/Stringable.hs +43/−0
- LICENSE +28/−0
- README +90/−0
- Setup.hs +3/−0
+ HsJudy.cabal view
@@ -0,0 +1,44 @@+name: HsJudy+version: 0.1+Category: Data+Synopsis: Judy bindings, and some nice APIs+Description: Judy[1] bindings (a C library that implements fast sparse dynamic+ arrays) for Haskell presenting APIs conforming as much as possible to the+ existent Haskell library interfaces, like Data.Map and Data.Array.MArray.+ This binding for the Judy library includes all its four types: mapping from+ words to bits (Judy1), from words to values (JudyL), from strings to values+ (JudyHS) and from array-of-bytes to values (JudyHS).+license: BSD3+license-file: LICENSE+author: Caio Marcelo de Oliveira Filho, John Meacham+maintainer: Caio Marcelo de Oliveira Filho <cmarcelo@gmail.com>+homepage: http://www.pugscode.org/+cabal-version: >= 1.2+tested-with: GHC==6.8.2+build-type: Simple++data-files: README++flag small_base+ description: Choose the new smaller, split-up base package.++Library+ if flag(small_base)+ Build-Depends: base, containers+ else+ Build-Depends: base < 3+ build-depends: bytestring>=0.9.0.1+ exposed-modules: Judy.BitSet Judy.Freeze Judy.Hash Judy.IntMap Judy.StrMap+ Judy.CollectionsM Judy.HashIO Judy.Refeable Judy.Stringable+ other-modules: Judy.Private Judy.MiniGC++ include-dirs: . ../judy/Judy-1.0.3/src+-- FIXME: make Cabal work nicely with _hsc files; now I think it works, but doesn't clean _hsc files+ c-sources: Judy/Private_hsc.c+++ extensions: ForeignFunctionInterface, TypeSynonymInstances, MagicHash,+ IncoherentInstances, UndecidableInstances+ ghc-options: -fglasgow-exts -Wall -O2 -static ../judy/Judy-1.0.3/src/Judy1/*.o+ ../judy/Judy-1.0.3/src/JudyL/*.o ../judy/Judy-1.0.3/src/JudySL/*.o+ ../judy/Judy-1.0.3/src/JudyHS/*.o ../judy/Judy-1.0.3/src/JudyCommon/*.o
+ Judy/BitSet.hs view
@@ -0,0 +1,238 @@+{-# OPTIONS -fallow-undecidable-instances -fallow-incoherent-instances #-}++{-# INCLUDE "Judy.h" #-}++module Judy.BitSet where++import Data.Typeable+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import Foreign.Storable+import Foreign.Ptr+import System.IO.Unsafe++import Judy.Private+import Judy.Freeze+import Judy.HashIO+++newtype HashIO a => BitSet a = BitSet { judy :: ForeignPtr Judy1 }+ deriving (Eq, Ord, Typeable)++instance Show (BitSet a) where+ show (BitSet bs) = "<BitSet " ++ show bs ++ ">"+++-- | Swap contents of two sets.+swapBitSets :: BitSet a -> BitSet a -> IO ()+swapBitSets (BitSet j1) (BitSet j2) = do+ withForeignPtr j1 $ \p1 -> do+ withForeignPtr j2 $ \p2 -> do+ v1 <- peek p1+ v2 <- peek p2+ poke p1 v2+ poke p2 v1++-- | Create a set.+new :: HashIO a => IO (BitSet a)+new = do+ fp <- mallocForeignPtr+ addForeignPtrFinalizer judy1_free_ptr fp+ withForeignPtr fp $ flip poke nullPtr+ return $ BitSet fp++-- | Add a value to the set.+insert :: HashIO a => a -> BitSet a -> IO ()+insert v (BitSet j) = withForeignPtr j $ \j' -> do+ v' <- hashIO v+ judy1Set j' v' judyError+ if v' == jerr+ then putStrLn "HsJudy: Not enough memory."+ else return ()++-- | Delete a value in the set.+delete :: HashIO a => a -> BitSet a -> IO ()+delete v (BitSet j) = withForeignPtr j $ \j' -> do+ v' <- hashIO v+ judy1Unset j' v' judyError+ if v' == jerr+ then error "HsJudy: Not enough memory."+ else return ()++-- | Set value in or out the set and return its old value.+set :: HashIO a => BitSet a -> a -> Bool -> IO Bool+set (BitSet k) v True = withForeignPtr k $ \j -> do+ vp <- hashIO v+ r <- judy1Set j vp judyError+ if vp == jerr+ then error "HsJudy: Not enough memory."+ else return $ r == 0+set (BitSet k) v False = withForeignPtr k $ \j -> do+ vp <- hashIO v+ r <- judy1Unset j vp judyError+ if vp == jerr+ then error "HsJudy: Not enough memory."+ else return $ r /= 0++-- this inline was in Meacham original BitSet+-- {-# INLINE get #-}+get :: HashIO a => BitSet a -> a -> IO Bool+get (BitSet j) v = do+ jj <- withForeignPtr j peek+ vp <- hashIO v+ r <- judy1Test jj vp judyError+ return $ r /= 0++-- | Is the value a member of the set?+member :: HashIO a => a -> BitSet a -> IO Bool+member v (BitSet j) = do+ j' <- withForeignPtr j peek+ v' <- hashIO v+ r <- judy1Test j' v' judyError+ return $ r /= 0++-- | Is the set empty?+null :: BitSet a -> IO Bool+null (BitSet j) = do+ j' <- withForeignPtr j peek+ return $ j' == nullPtr++-- | Cardinality of the set.+size :: BitSet a -> IO Int+size (BitSet j) = do+ j' <- withForeignPtr j peek+ r <- judy1Count j' 0 (-1) judyError+ return $ fromEnum r++-- | Make the set empty.+clear :: HashIO a => BitSet a -> IO ()+clear (BitSet j) = withForeignPtr j $ \j' -> judy1FreeArray j' judyError >> return ()++-- | Convert the set to a list of elements.+toList :: (Enum a) => BitSet t -> IO [a]+toList (BitSet j) = do+ j' <- withForeignPtr j peek+ alloca $ \vp -> do+ poke vp (-1)+ let f 0 xs = return xs+ f _ xs = do+ v <- peek vp+ v' <- unHashIO v+ r <- judy1Prev j' vp judyError+ f r (v':xs)+ r <- judy1Last j' vp judyError+ f r []++-- | Create a set from a list of elements.+-- FIXME: should I create the list here maybe?+fromList :: HashIO a => [a] -> BitSet a -> IO ()+fromList vs bs = mapM_ (\v -> insert v bs) vs++++-- FIXME: Is this other implementation faster than mapM_?+{-setList :: [a] -> Bool -> BitSet a -> IO ()+setList vs True (BitSet bs) = withForeignPtr bs $ \j -> mapM_ (\v -> do+ vp <- newStablePtr v+ judy1Set j (ptrToWordPtr (castStablePtrToPtr vp)) judyError+ ) vs+setList vs False (BitSet bs) = withForeignPtr bs $ \j -> mapM_ (\v -> do+ vp <- newStablePtr v+ judy1Unset j (ptrToWordPtr (castStablePtrToPtr vp)) judyError+ ) vs++-}++++++-- Pure access routines from original BitSet code++instance HashIO a => Freezable (BitSet a) where+ freeze = freezeBitSet++-- | Create a frozen, immutable version of a bitset, the original mutable version is cleared.+freezeBitSet :: HashIO a => BitSet a -> IO (Frozen (BitSet a))+freezeBitSet bs = do+ nbs <- new+ swapBitSets bs nbs+ return (Frozen nbs)++memberF :: HashIO a => a -> Frozen (BitSet a) -> Bool+memberF v (Frozen bs) = unsafePerformIO $ get bs v++fromListF :: HashIO a => [a] -> Frozen (BitSet a)+fromListF vs = Frozen $ unsafePerformIO $ do+ bs <- new+ fromList vs bs+ return bs++toListF :: (Enum a) => Frozen (BitSet t) -> [a]+toListF (Frozen (BitSet j)) = unsafePerformIO $ do+ j' <- withForeignPtr j peek+ alloca $ \vp -> do+ poke vp (-1)+ let f 0 xs = return xs+ f _ xs = do+ v <- peek vp+ v' <- unHashIO v+ r <- judy1Prev j' vp judyError+ f r (v':xs)+ r <- judy1Last j' vp judyError+ f r []++-- TODO: See if ListFrom and RevList are needed+-- compare my toListF with toListFrom (it have more unsafePerformIO's =P)++{-+toList :: Frozen (BitSet a) -> [Value]+toList = toListFrom 0++toListFrom :: Value -> Frozen BitSet -> [Value]+toListFrom iwp (Frozen (BitSet bs)) = unsafePerformIO $ do+ jj <- withForeignPtr bs peek+ (r,v) <- alloca $ \wp -> do+ poke wp iwp+ r <- judy1First jj wp judyError+ v <- peek wp+ return (r,v)+ let f 0 _ = []+ f _ v = v:unsafePerformIO (g v)+ g v = do+ (r,v) <- alloca $ \wp -> do+ poke wp v+ r <- judy1Next jj wp judyError+ v <- peek wp+ touchForeignPtr bs+ return (r,v)+ return (f r v)+ return (f r v)+++toRevList :: Frozen BitSet -> [Value]+toRevList = toRevListFrom (-1)++toRevListFrom :: Value -> Frozen BitSet -> [Value]+toRevListFrom iwp (Frozen (BitSet bs)) = unsafePerformIO $ do+ withForeignPtr bs $ \j -> do+ jj <- peek j+ (r,v) <- alloca $ \wp -> do+ poke wp iwp+ r <- judy1Last jj wp judyError+ v <- peek wp+ return (r,v)+ let f 0 _ = []+ f _ v = v:unsafePerformIO (g v)+ g v = do+ (r,v) <- alloca $ \wp -> do+ poke wp v+ r <- judy1Prev jj wp judyError+ v <- peek wp+ touchForeignPtr bs+ return (r,v)+ return (f r v)+ return (f r v)++-}+
+ Judy/CollectionsM.hs view
@@ -0,0 +1,197 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}++module Judy.CollectionsM (+ MapM (..),+ MapF (..)+) where++-- import Judy.Freeze+-- import Foreign+import Data.IORef+import qualified Data.Map as DM+import qualified Data.HashTable as HT++import Prelude hiding (lookup)++-- import Prelude (Bool(..), Int, Maybe(..),+-- (==), (.), (+), ($), (-), (&&), (||),+-- Eq, Ord,+-- error, const, not, fst, snd, maybe, head, otherwise, curry, uncurry, flip,+-- min, max, Show)++-- import Prelude hiding (sum,concat,lookup,map,filter,foldr,foldr1,foldl,null,reverse,(++),minimum,maximum,all,elem,concatMap,drop,head,tail,init)++{-+class Monad m => CollectionM c i o m | c -> i o m where+ -- From Foldable+ null :: c -> m Bool+ size :: c -> m Int++ empty :: m c+ isSingleton :: c -> m Bool+ -- FIXME: create a new structure? or delete inplace? or have both options?+ filter :: (o -> Bool) -> c -> m c+ insert :: i -> c -> m ()+ singleton :: i -> m c++ -- FIXME: Foldable here+ insertMany :: [i] -> c -> m ()+ isSingleton :: c -> m Bool+-}++class Monad m => MapM c k a m | c -> k a m where+ new :: m c+ --delete :: k -> c -> m ()+ delete :: k -> c -> m Bool+ member :: k -> c -> m Bool+ lookup :: k -> c -> m (Maybe a)+ insert :: k -> a -> c -> m ()+ alter :: Eq a => (Maybe a -> Maybe a) -> k -> c -> m (Maybe a)++ -- Generalize more... (fromFoldable, fromListWith, and both)+ --fromFoldableWith :: Foldable l (k,a) => (a -> a -> a) -> l -> m c+ fromList :: [(k,a)] -> m c+ toList :: c -> m [(k,a)]++ elems :: c -> m [a]+ keys :: c -> m [k]++ mapToList :: (k -> a -> b) -> c -> m [b]++ swapMaps :: c -> c -> m ()++++--map :: ... -> m c, using updates++-- Should it create the new value or not+--lookupWithDefault :: (MapM c k a m) -> k -> c -> m+++ --union :: c -> c -> m c+ --intersection :: c -> c -> m c+ --difference :: c -> c -> c+ --isSubset :: c -> c -> m Bool++ --insertWith :: (a -> a -> a) -> k -> a -> c -> m ()++ -- FIXME: create a new structure? or delete inplace? or have both?+ --mapWithKey :: (k -> a -> a) -> c -> m c+ --unionWith :: (a -> a -> a) -> c -> c -> m c+ --intersectionWith :: (a -> a -> a) -> c -> c -> m c+ --differenceWith :: (a -> a -> Maybe a) -> c -> c -> m c+ --isSubmapBy :: (a -> a -> Bool) -> c -> c -> m Bool++class MapF c k a | c -> k a where+ memberF :: k -> c -> Bool+ lookupF :: k -> c -> Maybe a+ fromListF :: [(k,a)] -> c+ toListF :: c -> [(k, a)]++instance (Ord k) => MapM (IORef (DM.Map k a)) k a IO where+ new = newIORef DM.empty+ delete k m = do+ modifyIORef m (\x -> DM.delete k x)+ return True+ member k m = do+ m' <- readIORef m+ return $ DM.member k m'+ lookup k m = do+ m' <- readIORef m+ return $ DM.lookup k m'+ insert k a m = modifyIORef m (\x -> DM.insert k a x)+ alter f k m = do+ m' <- readIORef m+ case DM.lookup k m' of+ Nothing -> case (f Nothing) of+ Nothing -> return Nothing+ Just y -> (insert k y m) >> (return $ Just y)+ Just x -> case (f (Just x)) of+ Nothing -> (delete k m) >> (return Nothing)+ Just y -> (insert k y m) >> (return $ Just y)+ fromList = newIORef . DM.fromList+ toList m = do+ m' <- readIORef m+ return $ DM.toList m'+ elems m = do+ m' <- readIORef m+ return $ DM.elems m'+ keys m = do+ m' <- readIORef m+ return $ DM.keys m'+ mapToList f m = do+ m' <- readIORef m+ let l = DM.toList m'+ let f' (k,a) = f k a+ return $ map f' l+ swapMaps x y = do+ x' <- readIORef x+ y' <- readIORef y+ writeIORef x y'+ writeIORef y x'++instance MapM (HT.HashTable String a) String a IO where+ new = HT.new (==) HT.hashString+ delete k m = (HT.delete m k) >> (return True)+ member k m = do+ x <- HT.lookup m k+ return $ case x of+ Nothing -> False+ Just _ -> True+ lookup = flip HT.lookup+ insert k a m = HT.insert m k a+ alter f k m = do+ x <- HT.lookup m k+ case x of+ Nothing -> case (f Nothing) of+ Nothing -> return Nothing+ Just y -> (HT.insert m k y) >> (return $ Just y)+ Just y -> case (f $ Just y) of+ Nothing -> (HT.delete m k) >> (return Nothing)+ Just z -> (HT.insert m k z) >> (return $ Just z)+ fromList = HT.fromList HT.hashString+ toList = HT.toList+ elems = (fmap (map snd)) . HT.toList+ keys = (fmap (map fst)) . HT.toList+ mapToList f = (fmap (map f')) . HT.toList+ where f' (a,b) = f a b+ swapMaps x y = do+ x' <- HT.toList x+ y' <- HT.toList y+ mapM_ (\(a,_) -> HT.delete x a) x'+ mapM_ (\(a,_) -> HT.delete y a) y'+ mapM_ (\(a,b) -> HT.insert x a b) y'+ mapM_ (\(a,b) -> HT.insert y a b) x'++instance MapM (HT.HashTable Int a) Int a IO where+ new = HT.new (==) HT.hashInt+ delete k m = (HT.delete m k) >> (return True)+ member k m = do+ x <- HT.lookup m k+ return $ case x of+ Nothing -> False+ Just _ -> True+ lookup = flip HT.lookup+ insert k a m = HT.insert m k a+ alter f k m = do+ x <- HT.lookup m k+ case x of+ Nothing -> case (f Nothing) of+ Nothing -> return Nothing+ Just y -> (HT.insert m k y) >> (return $ Just y)+ Just a -> case (f $ Just a) of+ Nothing -> (HT.delete m k) >> (return Nothing)+ Just y -> (HT.insert m k y) >> (return $ Just y)+ fromList = HT.fromList HT.hashInt+ toList = HT.toList+ elems = (fmap (map snd)) . HT.toList+ keys = (fmap (map fst)) . HT.toList+ mapToList f = (fmap (map f')) . HT.toList+ where f' (a,b) = f a b+ swapMaps x y = do+ x' <- HT.toList x+ y' <- HT.toList y+ mapM_ (\(a,_) -> HT.delete x a) x'+ mapM_ (\(a,_) -> HT.delete y a) y'+ mapM_ (\(a,b) -> HT.insert x a b) y'+ mapM_ (\(a,b) -> HT.insert y a b) x'
+ Judy/Freeze.hs view
@@ -0,0 +1,6 @@+module Judy.Freeze(Frozen(),Freezable(..)) where++import Judy.Private++class Freezable a where+ freeze :: a -> IO (Frozen a)
+ Judy/Hash.hs view
@@ -0,0 +1,229 @@+{-# OPTIONS -fallow-undecidable-instances -fallow-incoherent-instances #-}++{-# INCLUDE "Judy.h" #-}++module Judy.Hash (+ Hash (..),++ -- FIXME: need to move to MapM api+ freeze+) where++import Data.Typeable+import Control.Monad (when)+import Foreign.C.String+-- import Foreign.C.Types+-- import Foreign.ForeignPtr+-- import Foreign.Marshal.Alloc+-- import Foreign.Ptr+-- import Foreign.Storable+import Foreign+import Data.Maybe (fromJust)++import Judy.Private+import qualified Judy.CollectionsM as CM+import Judy.Refeable+import Judy.Freeze+import Judy.Stringable+import qualified Judy.MiniGC as GC++import Prelude hiding (map)++-- FIXME: really necessary/useful restrict types here?+newtype (Stringable k, Refeable a) => Hash k a = Hash { judy :: ForeignPtr JudyHS }+ deriving (Eq, Ord, Typeable)++instance (Stringable k, Refeable a) => CM.MapM (Hash k a) k a IO where+ new = new_+ delete = delete_+ member = member_+ lookup = lookup_+ insert = insert_+ alter = alter_+ fromList = fromList_+ toList = toList_+ elems = elems_+ keys = keys_+ mapToList = mapToList_+ swapMaps = swapMaps_++instance (Stringable k, Refeable a) => Freezable (Hash k a) where+ freeze m = do+ m' <- new_+ swapMaps_ m' m+ return (Frozen m')++instance (Stringable k, Refeable a) => CM.MapF (Frozen (Hash k a)) k a where+ memberF k (Frozen m) = unsafePerformIO $ member_ k m+ lookupF k (Frozen m) = unsafePerformIO $ lookup_ k m+ fromListF l = Frozen $ unsafePerformIO $ fromList_ l+ toListF (Frozen m) = unsafePerformIO $ toList_ m++instance Show (Hash k a) where+ show (Hash j) = "<Hash " ++ show j ++ ">"++foreign import ccall "wrapper" mkFin :: (Ptr JudyHS -> IO ()) -> IO (FunPtr (Ptr JudyHS -> IO ()))++finalize :: Bool -> Ptr JudyHS -> IO ()+finalize need j = do+ when need $ do+ j_ <- newForeignPtr_ j+ es <- rawElems (Hash j_)+ mapM_ GC.freeRef es+ v <- judyHSFreeArray j judyError+ --putStrLn $ "\n(FINALIZER CALLED FOR "++ (show j) ++ ": " ++ (show v) ++ ")\n"+ return ()++rawElems :: Hash k a -> IO [Value]+rawElems = internalMap $ \r _ _ -> peek r++dummy :: Refeable a => Hash k a -> a+dummy = undefined+++new_ :: Refeable a => IO (Hash k a)+new_ = do+ fp <- mallocForeignPtr+ withForeignPtr fp $ flip poke nullPtr+ m <- return $ Hash fp++ finalize' <- mkFin $ finalize $ needGC (dummy m)+ addForeignPtrFinalizer finalize' fp+ return m++insert_ :: (Stringable k, Refeable a) => k -> a -> Hash k a -> IO ()+insert_ k v (Hash j) = withForeignPtr j $ \j' -> do+ useAsCSLen k $ \(cp, len) -> do+ -- TODO: maybe there's a better way to convert Int -> Value+ r <- judyHSIns j' cp (fromIntegral len) judyError+ if r == pjerr+ then error "HsJudy: Not enough memory."+ else do+ v' <- toRef v+ poke r v'+ return ()++alter_ :: (Eq a, Stringable k, Refeable a) => (Maybe a -> Maybe a) -> k -> Hash k a -> IO (Maybe a)+alter_ f k m@(Hash j) = do+ j' <- withForeignPtr j peek+ useAsCSLen k $ \(cp, len) -> do+ r <- judyHSGet j' cp (fromIntegral len)+ if r == nullPtr+ then if (f Nothing) == Nothing+ then return Nothing+ else insert_ k (fromJust (f Nothing)) m >> return (f Nothing)+ else do+ v' <- peek r+ v <- fromRef v'+ let fv = f (Just v)+ if fv == Nothing+ then do delete_ k m+ return Nothing+ else if v /= (fromJust fv)+ then do when (needGC (fromJust fv)) $ GC.freeRef v'+ x <- toRef (fromJust fv)+ poke r x+ return fv+ else return fv++lookup_ :: (Stringable k, Refeable a) => k -> Hash k a -> IO (Maybe a)+lookup_ k (Hash j) = do+ j' <- withForeignPtr j peek+ useAsCSLen k $ \(cp, len) -> do+ r <- judyHSGet j' cp (fromIntegral len)+ if r == nullPtr+ then return Nothing+ else do+ v' <- peek r+ v <- fromRef v'+ return $ Just v++member_ :: Stringable k => k -> Hash k a -> IO Bool+member_ k (Hash j) = do+ j' <- withForeignPtr j peek+ useAsCSLen k $ \(cp, len) -> do+ r <- judyHSGet j' cp (fromIntegral len)+ return $ r /= nullPtr++delete_ :: Stringable k => k -> Hash k a -> IO Bool+delete_ k m@(Hash j) = withForeignPtr j $ \j' -> do+ j'' <- peek j'+ useAsCSLen k $ \(cp, len) -> do+ when (needGC (dummy m)) $ do+ r <- judyHSGet j'' cp (fromIntegral len)+ if r == nullPtr+ then return ()+ else do v' <- peek r+ GC.freeRef v'+ return ()+ r <- judyHSDel j' cp (fromIntegral len) judyError+ return $ r /= 0++-- FIXME: may use HashIter type to enforce some safety in its use?+newtype HashIter = HashIter { iter :: ForeignPtr JudyHSIter }+ deriving (Eq, Ord, Typeable)++instance Show HashIter where+ show (HashIter i) = "<Iter "++ show i ++ ">"+++newIter :: IO (HashIter)+newIter = do+ fp <- mallocForeignPtr+ addForeignPtrFinalizer judyHSIter_free_ptr fp+ withForeignPtr fp $ flip poke nullPtr+ return $ HashIter fp++fromList_ :: (Stringable k, Refeable a) => [(k,a)] -> IO (Hash k a)+fromList_ xs = do+ m <- new_+ mapM_ (\(k,a) -> insert_ k a m) xs+ return m++internalMap :: (Ptr Value -> Ptr CString -> Ptr Value -> IO b) -> Hash k a -> IO [b]+internalMap f (Hash j) = do+ jj <- withForeignPtr j peek+ (HashIter i) <- newIter+ withForeignPtr i $ \ii -> alloca $ \cp -> alloca $ \len -> do+ poke len 0+ jp_null cp+ let loop act xs = do+ r <- act jj ii cp len judyError+ if r == nullPtr+ then return xs+ else do x <- f r cp len+ loop judyHSIterNext (x:xs)+ loop judyHSIterFirst []++mapToList_ :: (Stringable k, Refeable a) => (k -> a -> b) -> Hash k a -> IO [b]+mapToList_ f = internalMap $ \r cp len -> do+ l <- peek len+ c <- peek cp+ v <- copyCSLen (c, fromIntegral l)+ d <- peek r+ d' <- fromRef d+ return $ f v d'++toList_ :: (Stringable k, Refeable a) => Hash k a -> IO [(k,a)]+toList_ = mapToList_ $ \k a -> (k, a)++elems_ :: Refeable a => Hash k a -> IO [a]+elems_ = internalMap $ \r _ _ -> do+ d <- peek r+ fromRef d++keys_ :: Stringable k => Hash k a -> IO [k]+keys_ = internalMap $ \_ cp len -> do+ l <- peek len+ c <- peek cp+ v <- copyCSLen (c, fromIntegral l)+ return v+++swapMaps_ :: Hash k a -> Hash k a -> IO ()+swapMaps_ (Hash j1) (Hash j2) = do+ withForeignPtr j1 $ \p1 -> withForeignPtr j2 $ \p2 -> do+ v1 <- peek p1+ v2 <- peek p2+ poke p1 v2+ poke p2 v1
+ Judy/HashIO.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE MagicHash #-}+{-# OPTIONS -fallow-undecidable-instances -fallow-incoherent-instances -fallow-overlapping-instances #-}++module Judy.HashIO (+ HashIO (..),+ UniqueHashIO, -- (..),+ ReversibleHashIO (..)+) where++import Data.HashTable (hashString)++import Judy.Private+import GHC.Exts (unsafeCoerce#)++class HashIO a where+ -- Two step conversion, first from a -> Int then Int -> Value+ hashIO :: a -> IO Value+class HashIO a => UniqueHashIO a+class UniqueHashIO a => ReversibleHashIO a where+ -- Two step conversion, first from Value -> Int then Int -> a+ unHashIO :: Value -> IO a+++instance Enum a => UniqueHashIO a where++instance Enum a => HashIO a where+ hashIO = return . unsafeCoerce# . fromEnum++instance Enum a => ReversibleHashIO a where+ unHashIO = return . toEnum . unsafeCoerce#+++instance HashIO Value where+ hashIO = return++instance UniqueHashIO Value++instance ReversibleHashIO Value where+ unHashIO = return++instance HashIO Integer where+ hashIO = return . fromIntegral . hashString . show+
+ Judy/IntMap.hs view
@@ -0,0 +1,315 @@+{-# OPTIONS -fallow-undecidable-instances -fallow-incoherent-instances #-}++{-# INCLUDE "Judy.h" #-}++module Judy.IntMap (+ IntMap (..),++ freeze,+ toRevList,+ size,+ takeFirstElems, takeFirst,+ takeLastElems, takeLast+) where++import Data.Typeable+import Control.Monad (when)+-- import Foreign.C.String+-- import Foreign.C.Types+-- import Foreign.ForeignPtr+-- import Foreign.Marshal.Alloc+-- import Foreign.Ptr+-- import Foreign.Storable+-- import Foreign.StablePtr+import Foreign+import Data.Maybe (fromJust)++import Judy.Private+import qualified Judy.CollectionsM as CM+import Judy.Refeable+import Judy.HashIO+import Judy.Freeze+import qualified Judy.MiniGC as GC++import Prelude hiding (map)++newtype (ReversibleHashIO k, Refeable a) => IntMap k a = IntMap { judy :: ForeignPtr JudyL }+ deriving (Eq, Ord, Typeable)++instance (ReversibleHashIO k, Refeable a) => CM.MapM (IntMap k a) k a IO where+ new = new_+ delete = delete_+ member = member_+ lookup = lookup_+ insert = insert_+ alter = alter_+ fromList = fromList_+ toList = toList_+ elems = elems_+ keys = keys_+ mapToList = mapToList_+ swapMaps = swapMaps_++instance (ReversibleHashIO k, Refeable a) => Freezable (IntMap k a) where+ freeze m = do+ m' <- new_+ swapMaps_ m' m+ return (Frozen m')++instance (ReversibleHashIO k, Refeable a) => CM.MapF (Frozen (IntMap k a)) k a where+ memberF k (Frozen m) = unsafePerformIO $ member_ k m+ lookupF k (Frozen m) = unsafePerformIO $ lookup_ k m+ fromListF l = Frozen $ unsafePerformIO $ fromList_ l+ toListF (Frozen m) = unsafePerformIO $ toList_ m++instance Show (IntMap k a) where+ show (IntMap j) = "<IntMap " ++ show j ++ ">"++++foreign import ccall "wrapper" mkFin :: (Ptr JudyL -> IO ()) -> IO (FunPtr (Ptr JudyL -> IO ()))++finalize :: Bool -> Ptr JudyL -> IO ()+finalize need j = do+ when need $ do+ j_ <- newForeignPtr_ j+ es <- rawElems (IntMap j_)+ mapM_ GC.freeRef es+ v <- judyLFreeArray j judyError+ --putStrLn $ "\n(FINALIZER CALLED FOR "++ (show j) ++ ": " ++ (show v) ++ ")\n"+ return ()++rawElems :: IntMap k a -> IO [Value]+rawElems = internalMap $ \r _ -> peek r++dummy :: Refeable a => IntMap k a -> a+dummy = undefined++new_ :: Refeable a => IO (IntMap k a)+new_ = do+ fp <- mallocForeignPtr+ withForeignPtr fp $ flip poke nullPtr+ m <- return $ IntMap fp++ finalize' <- mkFin $ finalize $ needGC (dummy m)+ addForeignPtrFinalizer finalize' fp+ return m++insert_ :: (ReversibleHashIO k, Refeable a) => k -> a -> IntMap k a -> IO ()+insert_ k v (IntMap j) = withForeignPtr j $ \j' -> do+ k' <- hashIO k+ r <- judyLIns j' k' judyError+ if r == pjerr+ then error "HsJudy: Not enough memory."+ else do { v' <- toRef v; poke r v'; return () }++alter_ :: (Eq a, ReversibleHashIO k, Refeable a) => (Maybe a -> Maybe a) -> k -> IntMap k a -> IO (Maybe a)+alter_ f k m@(IntMap j) = do+ j' <- withForeignPtr j peek+ k' <- hashIO k+ r <- judyLGet j' k' judyError+ if r == nullPtr+ then if (f Nothing) == Nothing+ then return Nothing+ else insert_ k (fromJust (f Nothing)) m >> return (f Nothing)+ else do+ v' <- peek r+ v <- fromRef v'+ let fv = f (Just v)+ if fv == Nothing+ then do delete_ k m+ return Nothing -- FIXME check delete output+ else if v /= (fromJust fv)+ then do when (needGC (fromJust fv)) $ GC.freeRef v'+ x <- toRef (fromJust fv)+ poke r x+ return fv+ else return fv++lookup_ :: (ReversibleHashIO k, Refeable a) => k -> IntMap k a -> IO (Maybe a)+lookup_ k (IntMap j) = do+ j' <- withForeignPtr j peek+ k' <- hashIO k+ r <- judyLGet j' k' judyError+ if r == nullPtr+ then return Nothing+ else do { v' <- peek r; v <- fromRef v'; return $ Just v }++member_ :: ReversibleHashIO k => k -> IntMap k a -> IO Bool+member_ k (IntMap j) = do+ j' <- withForeignPtr j peek+ k' <- hashIO k+ r <- judyLGet j' k' judyError+ return $ r /= nullPtr++delete_ :: ReversibleHashIO k => k -> IntMap k a -> IO Bool+delete_ k m@(IntMap j) = withForeignPtr j $ \j' -> do+ j'' <- peek j'+ k' <- hashIO k+ when (needGC (dummy m)) $ do+ r <- judyLGet j'' k' judyError+ if r == nullPtr+ then return ()+ else do v' <- peek r+ GC.freeRef v'+ return ()+ r <- judyLDel j' k' judyError+ return $ r /= 0++size :: IntMap k a -> IO Int+size (IntMap j) = withForeignPtr j $ \j' -> do+ jj <- peek j'+ r <- judyLCount jj 0 (-1) judyError+ return $ fromEnum r++++fromList_ :: (ReversibleHashIO k, Refeable a) => [(k,a)] -> IO (IntMap k a)+fromList_ xs = do+ m <- new_+ mapM_ (\(k,a) -> insert_ k a m) xs+ return m++internalMap' :: (Ptr Value -> Ptr Value -> IO b) -> IntMap k a -> IO [b]+internalMap' f (IntMap j) = do+ jj <- withForeignPtr j peek+ alloca $ \vp -> do+ poke vp (0 :: Value)+ let loop act xs = do+ r <- act jj vp judyError+ if r == nullPtr+ then return xs+ else do x <- f r vp+ loop judyLNext (x:xs)+ loop judyLFirst []++withLast :: (Ptr Value -> Ptr Value -> IO b) -> Int -> IntMap k a -> IO [b]+withLast f n (IntMap j) = do+ jj <- withForeignPtr j peek+ alloca $ \vp -> do+ poke vp (-1)+ let loop _ xs 0 = return xs+ loop act xs n' = do+ r <- act jj vp judyError+ if r == nullPtr+ then return xs+ else do x <- f r vp+ loop judyLPrev (x:xs) (n'-1)+ loop judyLLast [] n++takeLast :: (ReversibleHashIO k, Refeable a) => Int -> IntMap k a -> IO [(k,a)]+-- this case is here as a tentative to optimize, in case GHC doesn't do it+takeLast 1 (IntMap j) = do+ jj <- withForeignPtr j peek+ alloca $ \vp -> do+ poke vp (-1)+ r <- judyLLast jj vp judyError+ if r == nullPtr+ then return []+ else do k <- peek vp >>= unHashIO+ v <- peek r >>= fromRef+ return [(k,v)]+-- FIXME: use a less obscure syntax =P+takeLast n m = do+ withLast (\r vp -> do { k <- peek vp >>= unHashIO; v <- peek r >>= fromRef; return (k,v) }) n m++takeLastElems :: Refeable a => Int -> IntMap k a -> IO [a]+takeLastElems n m = do+ withLast (\r _ -> peek r >>= fromRef) n m+++++withFirst :: (Ptr Value -> Ptr Value -> IO b) -> Int -> IntMap k a -> IO [b]+withFirst f n (IntMap j) = do+ jj <- withForeignPtr j peek+ alloca $ \vp -> do+ poke vp (0 :: Value)+ let loop _ xs 0 = return xs+ loop act xs n' = do+ r <- act jj vp judyError+ if r == nullPtr+ then return xs+ else do x <- f r vp+ loop judyLNext (x:xs) (n'-1)+ loop judyLFirst [] n++-- FIXME: For n < size, is better use this approach, but for+-- n ~= size would be better to use LPrev and LLast and dont reverse.+++takeFirst :: (ReversibleHashIO k, Refeable a) => Int -> IntMap k a -> IO [(k,a)]+-- this case is here as a tentative to optimize, in case GHC doesn't do it+takeFirst 1 (IntMap j) = do+ jj <- withForeignPtr j peek+ alloca $ \vp -> do+ poke vp (0 :: Value)+ r <- judyLFirst jj vp judyError+ if r == nullPtr+ then return []+ else do k <- peek vp >>= unHashIO+ v <- peek r >>= fromRef+ return [(k,v)]+-- FIXME: use a less obscure syntax =P+takeFirst n m = do+ l <- withFirst (\r vp -> do { k <- peek vp >>= unHashIO; v <- peek r >>= fromRef; return (k,v) }) n m+ return $ reverse l++takeFirstElems :: Refeable a => Int -> IntMap k a -> IO [a]+takeFirstElems n m = do+ l <- withFirst (\r _ -> peek r >>= fromRef) n m+ return $ reverse l++internalMap :: (Ptr Value -> Ptr Value -> IO b) -> IntMap k a -> IO [b]+internalMap f (IntMap j) = do+ jj <- withForeignPtr j peek+ alloca $ \vp -> do+ poke vp (-1)+ let loop act xs = do+ r <- act jj vp judyError+ if r == nullPtr+ then return xs+ else do x <- f r vp+ loop judyLPrev (x:xs)+ loop judyLLast [] -- Because of list concat we go backwards+ -- to get ordered list right.++mapToList_ :: (ReversibleHashIO k, Refeable a) => (k -> a -> b) -> IntMap k a -> IO [b]+mapToList_ f = internalMap $ \r vp -> do+ k <- peek vp+ k' <- unHashIO k+ v <- peek r+ v' <- fromRef v+ return $ f k' v'++mapToRevList_ :: (ReversibleHashIO k, Refeable a) => (k -> a -> b) -> IntMap k a -> IO [b]+mapToRevList_ f = internalMap' $ \r vp -> do+ k <- peek vp+ k' <- unHashIO k+ v <- peek r+ v' <- fromRef v+ return $ f k' v'++toList_ :: (ReversibleHashIO k, Refeable a) => IntMap k a -> IO [(k,a)]+toList_ = mapToList_ $ \k a -> (k,a)++toRevList :: (ReversibleHashIO k, Refeable a) => IntMap k a -> IO [(k,a)]+toRevList = mapToRevList_ $ \k a -> (k,a)++keys_ :: ReversibleHashIO k => IntMap k a -> IO [k]+keys_ = internalMap $ \_ vp -> do+ k <- peek vp+ unHashIO k++elems_ :: Refeable a => IntMap k a -> IO [a]+elems_ = internalMap $ \r _ -> do+ v <- peek r+ fromRef v++swapMaps_ :: IntMap k a -> IntMap k a -> IO ()+swapMaps_ (IntMap j1) (IntMap j2) = do+ withForeignPtr j1 $ \p1 -> withForeignPtr j2 $ \p2 -> do+ v1 <- peek p1+ v2 <- peek p2+ poke p1 v2+ poke p2 v1
+ Judy/MiniGC.hs view
@@ -0,0 +1,102 @@++{-# INCLUDE "Judy.h" #-}++module Judy.MiniGC (+ judyGC, newRef, freeRef+) where++import Data.Typeable+import Data.Maybe (fromJust)++import Foreign++--import Foreign.Ptr+import Foreign.StablePtr++import Judy.Private++{-# NOINLINE judyGC #-}+judyGC :: GCMap+judyGC = unsafePerformIO newGCMap++newRef :: a -> IO WordPtr+newRef a = do+ --putStr "(new)"+ v <- newStablePtr a+ let v' = ptrToWordPtr $ castStablePtrToPtr v+ alter f v' judyGC+ return v'+ where f Nothing = Just 1+ f (Just n) = Just (n+1)++freeRef :: Value -> IO ()+freeRef v = do+ --putStr "(free? "+ alter f v judyGC+ x <- member v judyGC+ if x+ then return () --do { putStr "no!)"; return () }+ else freeStablePtr $ castPtrToStablePtr $ wordPtrToPtr v+ --else do { putStr "yes)"; freeStablePtr $ castPtrToStablePtr $ wordPtrToPtr v }+ where f Nothing = Nothing+ f (Just 1) = Nothing+ f (Just n) = Just (n-1)++{- Special implementation of (GCMap Value Int) over JudyL for use in GC -}++-- FIXME: clean up a bit++newtype GCMap = GCMap { judy :: ForeignPtr JudyL } deriving (Eq, Ord, Typeable)++instance Show GCMap where+ show (GCMap j) = "<hsjudy gc internal map " ++ show j ++ ">"++newGCMap :: IO GCMap+newGCMap = do+ fp <- mallocForeignPtr+ addForeignPtrFinalizer judyL_free_ptr fp+ withForeignPtr fp $ flip poke nullPtr+ return $ GCMap fp++insert :: Value -> Int -> GCMap -> IO ()+insert k v (GCMap j) = withForeignPtr j $ \j' -> do+ r <- judyLIns j' k judyError+ if r == pjerr+ then error "HsJudy: Not enough memory."+ else poke r (toEnum v)++alter :: (Maybe Int -> Maybe Int) -> Value -> GCMap -> IO ()+alter f k m@(GCMap j) = do+ j' <- withForeignPtr j peek+ r <- judyLGet j' k judyError+ if r == nullPtr+ then if (f Nothing) == Nothing+ then return ()+ else insert k (fromJust (f Nothing)) m+ else do+ v' <- peek r+ let v = (fromEnum v')+ let fv = (f (Just v))+ if fv == Nothing+ then delete k m >> return ()+ else poke r $ toEnum $ fromJust fv++-- -- Not used; dead code+-- lookup :: Value -> GCMap -> IO (Maybe Int)+-- lookup k (GCMap j) = do+-- j' <- withForeignPtr j peek+-- r <- judyLGet j' k judyError+-- if r == nullPtr+-- then return Nothing+-- else do { v' <- peek r; return $ Just $ fromEnum v' }++member :: Value -> GCMap -> IO Bool+member k (GCMap j) = do+ j' <- withForeignPtr j peek+ r <- judyLGet j' k judyError+ return $ r /= nullPtr++delete :: Value -> GCMap -> IO Bool+delete k (GCMap j) = withForeignPtr j $ \j' -> do+ r <- judyLDel j' k judyError+ return $ r /= 0
+ Judy/Private.hs view
@@ -0,0 +1,175 @@+{-# INCLUDE "Judy/Private_hsc.h" #-}+{-# LINE 1 "Judy/Private.hsc" #-}+-- | Low-level FFI+{-# LINE 2 "Judy/Private.hsc" #-}+module Judy.Private where++import Foreign+++{-# LINE 7 "Judy/Private.hsc" #-}+import Data.Word++{-# LINE 11 "Judy/Private.hsc" #-}++import Foreign.C.Types+import Foreign.C.String++{-# INCLUDE "Judy.h" #-}+++{-# LINE 18 "Judy/Private.hsc" #-}++{-# LINE 19 "Judy/Private.hsc" #-}+++{-# LINE 21 "Judy/Private.hsc" #-}+type Value = WordPtr++{-# LINE 34 "Judy/Private.hsc" #-}++newtype JError = JError (Ptr ())+--foreign import ccall unsafe "judy_error" judyError :: JError+-- #def JError_t *judy_error(void) { static JError_t err; return &err; }+judyError :: JError+judyError = JError nullPtr++newtype Frozen a = Frozen a++-- FIXME: I don't think this is the right type as I'll be comparing this with+-- results which are Ptr Value. const seems to return a number and i didnt found+-- a way to create Ptr Value =P+--pjerr :: Value+--pjerr = (#const PJERR)++-- Not sure if it's the best way to get this pointer, but works.++{-# LINE 51 "Judy/Private.hsc" #-}+foreign import ccall unsafe "j_pjerr" pjerr :: Ptr Value++jerr :: Value+jerr = (-1)++-- what do we gain from doing that newtype instead of simply doing: type Judy1Array = () ?+newtype Judy1Array = Judy1Array Judy1Array++type Judy1 = Ptr Judy1Array+++{-# LINE 62 "Judy/Private.hsc" #-}+++{-# LINE 64 "Judy/Private.hsc" #-}++-- do we really need this judy1_new? or importing judy1_free?+foreign import ccall unsafe judy1_new :: IO (Ptr Judy1)+foreign import ccall unsafe judy1_free :: Ptr Judy1 -> IO ()++foreign import ccall "&judy1_free" judy1_free_ptr :: FunPtr (Ptr Judy1 -> IO ())++-- TODO: import func descriptions from judy manual++foreign import ccall unsafe "Judy1Set" judy1Set :: Ptr Judy1 -> Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1Unset" judy1Unset :: Ptr Judy1 -> Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1Test" judy1Test :: Judy1 -> Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1FreeArray" judy1FreeArray :: Ptr Judy1 -> JError -> IO Value+foreign import ccall unsafe "Judy1Count" judy1Count :: Judy1 -> Value -> Value -> JError -> IO Value++foreign import ccall unsafe "Judy1First" judy1First :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1Next" judy1Next :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1Last" judy1Last :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1Prev" judy1Prev :: Judy1 -> Ptr Value -> JError -> IO CInt++foreign import ccall unsafe "Judy1FirstEmpty" judy1FirstEmpty :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1NextEmpty" judy1NextEmpty :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1LastEmpty" judy1LastEmpty :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1PrevEmpty" judy1PrevEmpty :: Judy1 -> Ptr Value -> JError -> IO CInt+++newtype JudyLArray = JudyLArray JudyLArray+type JudyL = Ptr JudyLArray+++{-# LINE 94 "Judy/Private.hsc" #-}++foreign import ccall "&judyL_free" judyL_free_ptr :: FunPtr (Ptr JudyL -> IO ())++foreign import ccall unsafe "JudyLIns" judyLIns :: Ptr JudyL -> Value -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudyLDel" judyLDel :: Ptr JudyL -> Value -> JError -> IO CInt+foreign import ccall unsafe "JudyLGet" judyLGet :: JudyL -> Value -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudyLCount" judyLCount :: JudyL -> Value -> Value -> JError -> IO Value+foreign import ccall unsafe "JudyLByCount" judyLByCount :: JudyL -> Value -> Ptr Value -> JError -> IO (Ptr Value)++foreign import ccall unsafe "JudyLFreeArray" judyLFreeArray :: Ptr JudyL -> JError -> IO Value+foreign import ccall unsafe "JudyLMemUsed" judyLMemUsed :: JudyL -> IO Value++foreign import ccall unsafe "JudyLFirst" judyLFirst :: JudyL -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudyLNext" judyLNext :: JudyL -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudyLLast" judyLLast :: JudyL -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudyLPrev" judyLPrev :: JudyL -> Ptr Value -> JError -> IO (Ptr Value)++foreign import ccall unsafe "JudyLFirstEmpty" judyLFirstEmpty :: JudyL -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "JudyLNextEmpty" judyLNextEmpty :: JudyL -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "JudyLLastEmpty" judyLLastEmpty :: JudyL -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "JudyLPrevEmpty" judyLPrevEmpty :: JudyL -> Ptr Value -> JError -> IO CInt+++newtype JudySLArray = JudySLArray JudySLArray+type JudySL = Ptr JudySLArray++++{-# LINE 122 "Judy/Private.hsc" #-}++-- #def void j_fill(char *p, char x, int len) { int i; for (i=len-1; i!=0; i--) *(p++) = x; p = '\0'; }++{-# LINE 125 "Judy/Private.hsc" #-}++--foreign import ccall "j_fill" j_fill :: CString -> CChar -> CInt -> IO ()+foreign import ccall "j_null" j_null :: CString -> IO ()++foreign import ccall "&judySL_free" judySL_free_ptr :: FunPtr (Ptr JudySL -> IO ())++foreign import ccall "JudySLIns" judySLIns :: Ptr JudySL -> CString -> JError -> IO (Ptr Value)+foreign import ccall "JudySLDel" judySLDel :: Ptr JudySL -> CString -> JError -> IO CInt+foreign import ccall "JudySLGet" judySLGet :: JudySL -> CString -> JError -> IO (Ptr Value)+foreign import ccall "JudySLFreeArray" judySLFreeArray :: Ptr JudySL -> JError -> IO Value++foreign import ccall unsafe "JudySLFirst" judySLFirst :: JudySL -> CString -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudySLNext" judySLNext :: JudySL -> CString -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudySLLast" judySLLast :: JudySL -> CString -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudySLPrev" judySLPrev :: JudySL -> CString -> JError -> IO (Ptr Value)+++newtype JudyHSArray = JudyHSArray JudyHSArray+type JudyHS = Ptr JudyHSArray+++{-# LINE 146 "Judy/Private.hsc" #-}++{-# LINE 147 "Judy/Private.hsc" #-}++++{-# LINE 150 "Judy/Private.hsc" #-}+foreign import ccall "jp_null" jp_null :: Ptr CString -> IO ()++++newtype JudyHSIterType = JudyHSIterType JudyHSIterType+type JudyHSIter = Ptr JudyHSIterType++foreign import ccall "&judyHS_free" judyHS_free_ptr :: FunPtr (Ptr JudyHS -> IO ())+foreign import ccall "&judyHSIter_free" judyHSIter_free_ptr :: FunPtr (Ptr JudyHSIter -> IO ())++foreign import ccall "JudyHSIns" judyHSIns :: Ptr JudyHS -> Ptr CChar -> CULong -> JError -> IO (Ptr Value)+foreign import ccall "JudyHSDel" judyHSDel :: Ptr JudyHS -> Ptr CChar -> Value -> JError -> IO CInt+foreign import ccall "JudyHSGet" judyHSGet :: JudyHS -> Ptr CChar -> Value -> IO (Ptr Value)+foreign import ccall "JudyHSFreeArray" judyHSFreeArray :: Ptr JudyHS -> JError -> IO Value++foreign import ccall "JudyHSIterFirst" judyHSIterFirst :: JudyHS -> Ptr JudyHSIter -> Ptr CString -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall "JudyHSIterNext" judyHSIterNext :: JudyHS -> Ptr JudyHSIter -> Ptr CString -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall "JudyHSIterLast" judyHSIterLast :: JudyHS -> Ptr JudyHSIter -> Ptr CString -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall "JudyHSIterPrev" judyHSIterPrev :: JudyHS -> Ptr JudyHSIter -> Ptr CString -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall "JudyHSFreeIter" judyHSFreeIter :: Ptr JudyHSIter -> JError -> IO Value+
+ Judy/Private.hsc view
@@ -0,0 +1,170 @@+-- | Low-level FFI+module Judy.Private where++import Foreign++#if __GLASGOW_HASKELL__ >= 605+import Data.Word+#else+import GHC.Exts+#endif++import Foreign.C.Types+import Foreign.C.String++{-# INCLUDE "Judy.h" #-}++#include <Judy.h>+#include <stdlib.h>++#if __GLASGOW_HASKELL__ >= 605+type Value = WordPtr+#else+type Value = (#type Word_t)++{-# INLINE ptrToWordPtr #-}+ptrToWordPtr :: Ptr () -> Value+ptrToWordPtr = unsafeCoerce##++{-# INLINE wordPtrToPtr #-}+wordPtrToPtr :: Value -> Ptr ()+wordPtrToPtr = unsafeCoerce##++#endif++newtype JError = JError (Ptr ())+--foreign import ccall unsafe "judy_error" judyError :: JError+-- #def JError_t *judy_error(void) { static JError_t err; return &err; }+judyError :: JError+judyError = JError nullPtr++newtype Frozen a = Frozen a++-- FIXME: I don't think this is the right type as I'll be comparing this with+-- results which are Ptr Value. const seems to return a number and i didnt found+-- a way to create Ptr Value =P+--pjerr :: Value+--pjerr = (#const PJERR)++-- Not sure if it's the best way to get this pointer, but works.+#def void *j_pjerr(void) { return PJERR; }+foreign import ccall unsafe "j_pjerr" pjerr :: Ptr Value++jerr :: Value+jerr = (-1)++-- what do we gain from doing that newtype instead of simply doing: type Judy1Array = () ?+newtype Judy1Array = Judy1Array Judy1Array++type Judy1 = Ptr Judy1Array++#def void *judy1_new(void) { return calloc(1,sizeof(void *)); }++#def void judy1_free(void *ptr) { Judy1FreeArray(ptr, PJE0); }++-- do we really need this judy1_new? or importing judy1_free?+foreign import ccall unsafe judy1_new :: IO (Ptr Judy1)+foreign import ccall unsafe judy1_free :: Ptr Judy1 -> IO ()++foreign import ccall "&judy1_free" judy1_free_ptr :: FunPtr (Ptr Judy1 -> IO ())++-- TODO: import func descriptions from judy manual++foreign import ccall unsafe "Judy1Set" judy1Set :: Ptr Judy1 -> Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1Unset" judy1Unset :: Ptr Judy1 -> Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1Test" judy1Test :: Judy1 -> Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1FreeArray" judy1FreeArray :: Ptr Judy1 -> JError -> IO Value+foreign import ccall unsafe "Judy1Count" judy1Count :: Judy1 -> Value -> Value -> JError -> IO Value++foreign import ccall unsafe "Judy1First" judy1First :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1Next" judy1Next :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1Last" judy1Last :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1Prev" judy1Prev :: Judy1 -> Ptr Value -> JError -> IO CInt++foreign import ccall unsafe "Judy1FirstEmpty" judy1FirstEmpty :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1NextEmpty" judy1NextEmpty :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1LastEmpty" judy1LastEmpty :: Judy1 -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "Judy1PrevEmpty" judy1PrevEmpty :: Judy1 -> Ptr Value -> JError -> IO CInt+++newtype JudyLArray = JudyLArray JudyLArray+type JudyL = Ptr JudyLArray++#def void judyL_free(void *ptr) { JudyLFreeArray(ptr, PJE0); }++foreign import ccall "&judyL_free" judyL_free_ptr :: FunPtr (Ptr JudyL -> IO ())++foreign import ccall unsafe "JudyLIns" judyLIns :: Ptr JudyL -> Value -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudyLDel" judyLDel :: Ptr JudyL -> Value -> JError -> IO CInt+foreign import ccall unsafe "JudyLGet" judyLGet :: JudyL -> Value -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudyLCount" judyLCount :: JudyL -> Value -> Value -> JError -> IO Value+foreign import ccall unsafe "JudyLByCount" judyLByCount :: JudyL -> Value -> Ptr Value -> JError -> IO (Ptr Value)++foreign import ccall unsafe "JudyLFreeArray" judyLFreeArray :: Ptr JudyL -> JError -> IO Value+foreign import ccall unsafe "JudyLMemUsed" judyLMemUsed :: JudyL -> IO Value++foreign import ccall unsafe "JudyLFirst" judyLFirst :: JudyL -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudyLNext" judyLNext :: JudyL -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudyLLast" judyLLast :: JudyL -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudyLPrev" judyLPrev :: JudyL -> Ptr Value -> JError -> IO (Ptr Value)++foreign import ccall unsafe "JudyLFirstEmpty" judyLFirstEmpty :: JudyL -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "JudyLNextEmpty" judyLNextEmpty :: JudyL -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "JudyLLastEmpty" judyLLastEmpty :: JudyL -> Ptr Value -> JError -> IO CInt+foreign import ccall unsafe "JudyLPrevEmpty" judyLPrevEmpty :: JudyL -> Ptr Value -> JError -> IO CInt+++newtype JudySLArray = JudySLArray JudySLArray+type JudySL = Ptr JudySLArray+++#def void judySL_free(void *ptr) { JudySLFreeArray(ptr, PJE0); }++-- #def void j_fill(char *p, char x, int len) { int i; for (i=len-1; i!=0; i--) *(p++) = x; p = '\0'; }+#def void j_null(char *p) { p = '\0'; }++--foreign import ccall "j_fill" j_fill :: CString -> CChar -> CInt -> IO ()+foreign import ccall "j_null" j_null :: CString -> IO ()++foreign import ccall "&judySL_free" judySL_free_ptr :: FunPtr (Ptr JudySL -> IO ())++foreign import ccall "JudySLIns" judySLIns :: Ptr JudySL -> CString -> JError -> IO (Ptr Value)+foreign import ccall "JudySLDel" judySLDel :: Ptr JudySL -> CString -> JError -> IO CInt+foreign import ccall "JudySLGet" judySLGet :: JudySL -> CString -> JError -> IO (Ptr Value)+foreign import ccall "JudySLFreeArray" judySLFreeArray :: Ptr JudySL -> JError -> IO Value++foreign import ccall unsafe "JudySLFirst" judySLFirst :: JudySL -> CString -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudySLNext" judySLNext :: JudySL -> CString -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudySLLast" judySLLast :: JudySL -> CString -> JError -> IO (Ptr Value)+foreign import ccall unsafe "JudySLPrev" judySLPrev :: JudySL -> CString -> JError -> IO (Ptr Value)+++newtype JudyHSArray = JudyHSArray JudyHSArray+type JudyHS = Ptr JudyHSArray++#def void judyHS_free(void *ptr) { JudyHSFreeArray(ptr, PJE0); }+#def void judyHSIter_free(void *ptr) { JudyHSFreeIter(ptr, PJE0); }+++#def void jp_null(char **p) { p = NULL; }+foreign import ccall "jp_null" jp_null :: Ptr CString -> IO ()++++newtype JudyHSIterType = JudyHSIterType JudyHSIterType+type JudyHSIter = Ptr JudyHSIterType++foreign import ccall "&judyHS_free" judyHS_free_ptr :: FunPtr (Ptr JudyHS -> IO ())+foreign import ccall "&judyHSIter_free" judyHSIter_free_ptr :: FunPtr (Ptr JudyHSIter -> IO ())++foreign import ccall "JudyHSIns" judyHSIns :: Ptr JudyHS -> Ptr CChar -> CULong -> JError -> IO (Ptr Value)+foreign import ccall "JudyHSDel" judyHSDel :: Ptr JudyHS -> Ptr CChar -> Value -> JError -> IO CInt+foreign import ccall "JudyHSGet" judyHSGet :: JudyHS -> Ptr CChar -> Value -> IO (Ptr Value)+foreign import ccall "JudyHSFreeArray" judyHSFreeArray :: Ptr JudyHS -> JError -> IO Value++foreign import ccall "JudyHSIterFirst" judyHSIterFirst :: JudyHS -> Ptr JudyHSIter -> Ptr CString -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall "JudyHSIterNext" judyHSIterNext :: JudyHS -> Ptr JudyHSIter -> Ptr CString -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall "JudyHSIterLast" judyHSIterLast :: JudyHS -> Ptr JudyHSIter -> Ptr CString -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall "JudyHSIterPrev" judyHSIterPrev :: JudyHS -> Ptr JudyHSIter -> Ptr CString -> Ptr Value -> JError -> IO (Ptr Value)+foreign import ccall "JudyHSFreeIter" judyHSFreeIter :: Ptr JudyHSIter -> JError -> IO Value+
+ Judy/Private_hsc.c view
@@ -0,0 +1,31 @@+#include "Private_hsc.h"+#line 6 "Private.hsc"+#if __GLASGOW_HASKELL__ >= 605+#line 8 "Private.hsc"+#else +#line 10 "Private.hsc"+#endif +#line 20 "Private.hsc"+#if __GLASGOW_HASKELL__ >= 605+#line 22 "Private.hsc"+#else +#line 33 "Private.hsc"+#endif +#line 50 "Private.hsc"+void *j_pjerr(void) { return PJERR; }+#line 61 "Private.hsc"+void *judy1_new(void) { return calloc(1,sizeof(void *)); }+#line 63 "Private.hsc"+void judy1_free(void *ptr) { Judy1FreeArray(ptr, PJE0); }+#line 93 "Private.hsc"+void judyL_free(void *ptr) { JudyLFreeArray(ptr, PJE0); }+#line 121 "Private.hsc"+void judySL_free(void *ptr) { JudySLFreeArray(ptr, PJE0); }+#line 124 "Private.hsc"+void j_null(char *p) { p = '\0'; }+#line 145 "Private.hsc"+void judyHS_free(void *ptr) { JudyHSFreeArray(ptr, PJE0); }+#line 146 "Private.hsc"+void judyHSIter_free(void *ptr) { JudyHSFreeIter(ptr, PJE0); }+#line 149 "Private.hsc"+void jp_null(char **p) { p = NULL; }
+ Judy/Refeable.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS -fallow-undecidable-instances -fallow-incoherent-instances #-}+{-# LANGUAGE MagicHash, UndecidableInstances, IncoherentInstances #-}+module Judy.Refeable (+ Refeable (..)+) where++++import Foreign.StablePtr++import Foreign.Ptr++import Judy.Private+import qualified Judy.MiniGC as GC+import GHC.Exts (unsafeCoerce#)++-- FIXME: It results in an illegal instruction if I take the "Dummy a"+-- out of "Refeable a" context. Maybe something arch related, dunno. =P++--class Dummy a+--instance Dummy a++class Refeable a where+ toRef :: a -> IO Value+ toRef = GC.newRef+ fromRef :: Value -> IO a+ fromRef = deRefStablePtr . castPtrToStablePtr . wordPtrToPtr+ needGC :: a -> Bool+ needGC _ = True++--instance Dummy a => Refeable a where+instance Refeable a where++instance Refeable Int where+ toRef i = return $ unsafeCoerce# i+ fromRef v = return $ unsafeCoerce# v+ needGC _ = False++
+ Judy/StrMap.hs view
@@ -0,0 +1,224 @@+{-# OPTIONS -fallow-undecidable-instances -fallow-incoherent-instances #-}++{-# INCLUDE "Judy.h" #-}++module Judy.StrMap (+ StrMap (..),++ freeze,+ toRevList+) where++import Data.Typeable+import Control.Monad (when)+import Foreign.C.String+-- import Foreign.C.Types+-- import Foreign.ForeignPtr+-- import Foreign.Marshal.Alloc+-- import Foreign.Ptr+-- import Foreign.Storable+-- import Foreign.StablePtr+import Foreign+import Data.Maybe (fromJust)++import Judy.Private+import qualified Judy.CollectionsM as CM+import Judy.Refeable+import Judy.Stringable+import Judy.Freeze+import qualified Judy.MiniGC as GC++import Prelude hiding (map)++newtype (Stringable k, Refeable a) => StrMap k a = StrMap { judy :: ForeignPtr JudySL }+ deriving (Eq, Ord, Typeable)++instance (Stringable k, Refeable a) => CM.MapM (StrMap k a) k a IO where+ new = new_+ delete = delete_+ member = member_+ lookup = lookup_+ insert = insert_+ alter = alter_+ fromList = fromList_+ toList = toList_+ elems = elems_+ keys = keys_+ mapToList = mapToList_+ swapMaps = swapMaps_++instance (Stringable k, Refeable a) => Freezable (StrMap k a) where+ freeze m = do+ m' <- new_+ swapMaps_ m' m+ return (Frozen m')++instance (Stringable k, Refeable a) => CM.MapF (Frozen (StrMap k a)) k a where+ memberF k (Frozen m) = unsafePerformIO $ member_ k m+ lookupF k (Frozen m) = unsafePerformIO $ lookup_ k m+ fromListF l = Frozen $ unsafePerformIO $ fromList_ l+ toListF (Frozen m) = unsafePerformIO $ toList_ m++instance Show (StrMap k a) where+ show (StrMap j) = "<StrMap " ++ show j ++ ">"++foreign import ccall "wrapper" mkFin :: (Ptr JudySL -> IO ()) -> IO (FunPtr (Ptr JudySL -> IO ()))++finalize :: Bool -> Ptr JudySL -> IO ()+finalize need j = do+ --putStrLn $ show $ need+ when need $ do+ j_ <- newForeignPtr_ j+ es <- rawElems (StrMap j_)+ mapM_ GC.freeRef es+ v <- judySLFreeArray j judyError+ --putStrLn $ "\n(FINALIZER CALLED FOR "++ (show j) ++ ": " ++ (show v) ++ ")\n"+ return ()++rawElems :: StrMap k a -> IO [Value]+rawElems = internalMap $ \r _ -> peek r++dummy :: Refeable a => StrMap k a -> a+dummy = undefined++new_ :: Refeable a => IO (StrMap k a)+new_ = do+ fp <- mallocForeignPtr+ withForeignPtr fp $ flip poke nullPtr+ m <- return $ StrMap fp++ -- putStrLn $ show $ needGC $ dummy m+ finalize' <- mkFin $ finalize $ needGC $ dummy m+ addForeignPtrFinalizer finalize' fp+ return m++insert_ :: (Stringable k, Refeable a) => k -> a -> StrMap k a -> IO ()+insert_ k v (StrMap j) = withForeignPtr j $ \j' -> do+ useAsCS k $ \k' -> do+ r <- judySLIns j' k' judyError+ if r == pjerr+ then error "HsJudy: Not enough memory."+ else do { v' <- toRef v; poke r v'; return () }++alter_ :: (Eq a, Stringable k, Refeable a) => (Maybe a -> Maybe a) -> k -> StrMap k a -> IO (Maybe a)+alter_ f k m@(StrMap j) = do+ j' <- withForeignPtr j peek+ useAsCS k $ \k' -> do+ r <- judySLGet j' k' judyError+ if r == nullPtr+ then if (f Nothing) == Nothing+ then return Nothing+ else insert_ k (fromJust (f Nothing)) m >> return (f Nothing)+ else do+ v' <- peek r+ v <- fromRef v'+ let fv = f (Just v)+ if fv == Nothing+ then do delete_ k m+ return Nothing+ else if v /= (fromJust fv)+ then do when (needGC (fromJust fv)) $ GC.freeRef v'+ x <- toRef (fromJust fv)+ poke r x+ return fv+ else return fv++lookup_ :: (Stringable k, Refeable a) => k -> StrMap k a -> IO (Maybe a)+lookup_ k (StrMap j) = do+ j' <- withForeignPtr j peek+ useAsCS k $ \k' -> do+ r <- judySLGet j' k' judyError+ if r == nullPtr+ then return Nothing+ else do { v' <- peek r; v <- fromRef v'; return $ Just v }++member_ :: Stringable k => k -> StrMap k a -> IO Bool+member_ k (StrMap j) = do+ j' <- withForeignPtr j peek+ useAsCS k $ \k' -> do+ r <- judySLGet j' k' judyError+ return $ r /= nullPtr++delete_ :: (Stringable k, Refeable a) => k -> StrMap k a -> IO Bool+delete_ k m@(StrMap j) = withForeignPtr j $ \j' -> do+ j'' <- peek j'+ useAsCS k $ \k' -> do+ when (needGC (dummy m)) $ do+ r <- judySLGet j'' k' judyError+ if r == nullPtr+ then return ()+ else do v' <- peek r+ GC.freeRef v'+ return ()+ r <- judySLDel j' k' judyError+ return $ r /= 0+++fromList_ :: (Stringable k, Refeable a) => [(k,a)] -> IO (StrMap k a)+fromList_ xs = do+ m <- new_+ mapM_ (\(k,a) -> insert_ k a m) xs+ return m++internalMap' :: (Ptr Value -> CString -> IO b) -> StrMap k a -> IO [b]+internalMap' f (StrMap j) = do+ jj <- withForeignPtr j peek+ alloca $ \vp -> do+ poke vp 0+ let loop act xs = do+ r <- act jj vp judyError+ if r == nullPtr+ then return xs+ else do x <- f r vp+ loop judySLNext (x:xs)+ loop judySLFirst []++internalMap :: (Ptr Value -> CString -> IO b) -> StrMap k a -> IO [b]+internalMap f (StrMap j) = do+ jj <- withForeignPtr j peek+ alloca $ \vp -> do+ poke vp (-1)+ let loop act xs = do+ r <- act jj vp judyError+ if r == nullPtr+ then return xs+ else do x <- f r vp+ loop judySLPrev (x:xs)+ loop judySLLast []+++mapHelper_ :: (Stringable k, Refeable a) => (k -> a -> b) -> Ptr Value -> CString -> IO b+mapHelper_ f r vp = do+ k <- copyCS vp+ v <- peek r >>= fromRef+ return $ f k v++mapToList_ :: (Stringable k, Refeable a) => (k -> a -> b) -> StrMap k a -> IO [b]+mapToList_ f = internalMap (mapHelper_ f)++mapToRevList_ :: (Stringable k, Refeable a) => (k -> a -> b) -> StrMap k a -> IO [b]+mapToRevList_ f = internalMap' (mapHelper_ f)++toList_ :: (Stringable k, Refeable a) => StrMap k a -> IO [(k,a)]+toList_ = mapToList_ $ \k a -> (k,a)++toRevList :: (Stringable k, Refeable a) => StrMap k a -> IO [(k,a)]+toRevList = mapToRevList_ $ \k a -> (k,a)++keys_ :: Stringable k => StrMap k a -> IO [k]+keys_ = internalMap $ \_ vp -> do+ k <- copyCS vp+ return k++elems_ :: Refeable a => StrMap k a -> IO [a]+elems_ = internalMap $ \r _ -> do+ v <- peek r+ fromRef v++swapMaps_ :: StrMap k a -> StrMap k a -> IO ()+swapMaps_ (StrMap j1) (StrMap j2) = do+ withForeignPtr j1 $ \p1 -> withForeignPtr j2 $ \p2 -> do+ v1 <- peek p1+ v2 <- peek p2+ poke p1 v2+ poke p2 v1
+ Judy/Stringable.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Judy.Stringable (+ Stringable (..)+) where++import Foreign.C.String+import qualified Data.ByteString as B (ByteString, useAsCString, useAsCStringLen)+import Data.ByteString.Unsafe as BU (unsafePackCString, unsafePackCStringLen)+-- TODO: See if its possible to use Storable, ie. to let any Storable type be "stringable".++class Stringable k where+ toString :: k -> String+ fromString :: String -> k++ useAsCS :: k -> (CString -> IO a) -> IO a+ useAsCS k = withCAString (toString k)+ useAsCSLen :: k -> (CStringLen -> IO a) -> IO a+ useAsCSLen k = withCAStringLen (toString k)++ copyCS :: CString -> IO k+ copyCS c = peekCAString c >>= return . fromString+ copyCSLen :: CStringLen -> IO k+ copyCSLen c = peekCAStringLen c >>= return . fromString++instance Stringable String where+ toString = id+ fromString = id++instance Stringable B.ByteString where+ toString = undefined+ fromString = undefined++ useAsCS = B.useAsCString+ useAsCSLen = B.useAsCStringLen++ copyCS = BU.unsafePackCString+ copyCSLen = BU.unsafePackCStringLen++--instance Stringable Int where+-- toString = show+-- fromString = read
+ LICENSE view
@@ -0,0 +1,28 @@+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
+ README view
@@ -0,0 +1,90 @@+This code is part of my summer of code project. Please, before changing+something get in touch with me (cmarcelo at gmail || cmarcelo at #perl6).++I pasted my summer of code application, which describes roughly what's this+going to be. As time pass it'll become more proper README file =)++------8<--------++Fast Mutable Collection Types for Haskell+=========================================++# Synopsis+Develop Judy[1] bindings (a C library that implements fast sparse dynamic+arrays) for Haskell presenting APIs conforming as much as possible to the+existent Haskell library interfaces, like Data.Map and Data.Array.MArray.+++# Benefits to the community+Creating Judy bindings was suggested in the Haskell mailing list[2], and all+Haskell software that uses common data structures like Maps and Arrays would+benefit from a faster implementation.++The project idea[3] was suggested by a Pugs (Perl 6 implementation in Haskell)+developer, so these bindings could also benefit the Perl6 community.+++# Deliverables+A binding for the Judy library, including all its four types: mapping from+words to bits (Judy1), from words to values (JudyL), from strings to values+(JudyHS) and from array-of-bytes to values (JudyHS).++The API for the binding will match existing APIs of similar functionality in+Haskell libraries, allowing minimal effort to change a program to use these new+implementations. When possible, try to reduce this effort to just changing an+import clause in the Haskell program.+++# Project Details+Some work[4] has already been done in Judy1 (mapping from words to bits)+bindings for Haskell, and this would be a good place to start. The project+divides naturally in three phases:++* Implement communication between Haskell and the library. This involves+using the Haskell's foreign function interface (FFI). The binding should+allow Haskell data types to be used as values.++* Design an API based on existing Haskell libraries. This involves studying the+Haskell API and seeing which ones would have Judy-based support, good+candidates are Map, IntSet and IntMap. Doing an interface for DiffArray was+suggested, too. It's possible that no Haskell API matches some+functionality (like 'unbounded' Arrays); in that case new interfaces will+be created.++* Benchmark. Measure speed of the new bindings against that of previous+implementations. Other nice tests would be measuring the performance impact+in any entries of 'The Great Computer Language Shootout'[5], in the Pugs[6]+project and in RBR[7] (bioinformatics related software).+++# Bio+I'm a 5th-year computer engineering undergraduate at Campinas State University+(Unicamp), in Brazil. I've been involved with free software for almost 10 years+now, beginning as a Linux user and progressing from there.++In 2006 I started to study the Haskell programming language on my own, reading+tutorials and articles, the mailing list and spending time on Haskell's IRC+channel. This semester I'm developing a Compiler Construction Lab project in+Haskell.++The school semester ends by early July, so until then I'll be splitting my time+between the project and some university courses. Once 'summer' vacation+(actually here in Brazil it will be winter) begins I'll be able to fully+dedicate myself to the project.++I have already begun studying Haskell and doing some experiments with+Haskell<->C FFI. This project would be a great opportunity for me to learn more+about the language, which I consider to be one of the most elegant, and+possibly contribute something very concrete to the Haskell community.+++# References+[1]: http://judy.sf.net+[2]: 'Re: [Haskell-cafe] Re: Hashtable woes', by John Tromp, 25 Jan 2006.+[3]: http://hackage.haskell.org/trac/summer-of-code/ticket/61+[4]: http://repetae.net/repos/HsJudy/+[5]: http://haskell.org/hawiki/KnucleotideEntry+[6]: http://www.pugscode.org+[7]: http://www.ii.uib.no/~ketil/bioinformatics/tools.html++
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks