HsJudy 0.1.1 → 0.2

raw patch · 23 files changed

+1613/−1616 lines, 23 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/Array/Judy/BitSet.hs +238/−0
• Data/Array/Judy/CollectionsM.hs +197/−0
• Data/Array/Judy/Freeze.hs +6/−0
• Data/Array/Judy/Hash.hs +229/−0
• Data/Array/Judy/HashIO.hs +42/−0
• Data/Array/Judy/IntMap.hs +315/−0
• Data/Array/Judy/MiniGC.hs +102/−0
• Data/Array/Judy/Private.hsc +172/−0
• Data/Array/Judy/Refeable.hs +36/−0
• Data/Array/Judy/StrMap.hs +224/−0
• Data/Array/Judy/Stringable.hs +42/−0
• HsJudy.cabal +10/−15
• Judy/BitSet.hs +0/−238
• Judy/CollectionsM.hs +0/−197
• Judy/Freeze.hs +0/−6
• Judy/Hash.hs +0/−229
• Judy/HashIO.hs +0/−41
• Judy/IntMap.hs +0/−315
• Judy/MiniGC.hs +0/−102
• Judy/Private.hsc +0/−170
• Judy/Refeable.hs +0/−36
• Judy/StrMap.hs +0/−224
• Judy/Stringable.hs +0/−43

@@ -0,0 +1,238 @@+{-# LANGUAGE UndecidableInstances, IncoherentInstances #-}++{-# INCLUDE "Judy.h" #-}++module Data.Array.Judy.BitSet where++import Data.Typeable+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import Foreign.Storable+import Foreign.Ptr+import System.IO.Unsafe++import Data.Array.Judy.Private+import Data.Array.Judy.Freeze+import Data.Array.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)++-}+

@@ -0,0 +1,197 @@+{-# LANGUAGE UndecidableInstances, FunctionalDependencies, FlexibleContexts #-}++module Data.Array.Judy.CollectionsM (+    MapM (..),+    MapF (..)+) where++-- import Data.Array.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'

@@ -0,0 +1,6 @@+module Data.Array.Judy.Freeze(Frozen(),Freezable(..)) where++import Data.Array.Judy.Private++class Freezable a where+    freeze :: a -> IO (Frozen a)

@@ -0,0 +1,229 @@+{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, IncoherentInstances #-}++{-# INCLUDE "Judy.h" #-}++module Data.Array.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 Data.Array.Judy.Private+import qualified Data.Array.Judy.CollectionsM as CM+import Data.Array.Judy.Refeable+import Data.Array.Judy.Freeze+import Data.Array.Judy.Stringable+import qualified Data.Array.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

@@ -0,0 +1,42 @@+{-# LANGUAGE MagicHash, FlexibleInstances, OverlappingInstances,IncoherentInstances,+  IncoherentInstances, UndecidableInstances #-}++module Data.Array.Judy.HashIO (+    HashIO (..),+    UniqueHashIO, -- (..),+    ReversibleHashIO (..)+) where++import Data.HashTable (hashString)++import Data.Array.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+

@@ -0,0 +1,315 @@+{-# LANGUAGE UndecidableInstances, IncoherentInstances #-}++{-# INCLUDE "Judy.h" #-}++module Data.Array.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 Data.Array.Judy.Private+import qualified Data.Array.Judy.CollectionsM as CM+import Data.Array.Judy.Refeable+import Data.Array.Judy.HashIO+import Data.Array.Judy.Freeze+import qualified Data.Array.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

@@ -0,0 +1,102 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# INCLUDE "Judy.h" #-}++module Data.Array.Judy.MiniGC (+    judyGC, newRef, freeRef+) where++import Data.Typeable+import Data.Maybe (fromJust)++import Foreign++--import Foreign.Ptr+import Foreign.StablePtr++import Data.Array.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

@@ -0,0 +1,172 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | Low-level FFI+module Data.Array.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+

@@ -0,0 +1,36 @@+{-# LANGUAGE MagicHash, UndecidableInstances, IncoherentInstances, FlexibleInstances  #-}+module Data.Array.Judy.Refeable (+    Refeable (..)+) where++import Foreign.StablePtr++import Foreign.Ptr++import Data.Array.Judy.Private+import qualified Data.Array.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++

@@ -0,0 +1,224 @@+{-# LANGUAGE UndecidableInstances, IncoherentInstances #-}++{-# INCLUDE "Judy.h" #-}++module Data.Array.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 Data.Array.Judy.Private+import qualified Data.Array.Judy.CollectionsM as CM+import Data.Array.Judy.Refeable+import Data.Array.Judy.Stringable+import Data.Array.Judy.Freeze+import qualified Data.Array.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

@@ -0,0 +1,42 @@+{-# LANGUAGE TypeSynonymInstances #-}++module Data.Array.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

@@ -1,8 +1,8 @@ name:                HsJudy-version:             0.1.1+version:             0.2 Category:            Data Synopsis:            Judy bindings, and some nice APIs-Description:         Judy[1] bindings (a C library that implements fast sparse dynamic+Description:         Judy 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@@ -19,20 +19,15 @@  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+        Build-Depends: base, containers, bytestring>=0.9.0.1++        exposed-modules:     Data.Array.Judy.BitSet Data.Array.Judy.Freeze Data.Array.Judy.Hash Data.Array.Judy.IntMap Data.Array.Judy.StrMap+                             Data.Array.Judy.CollectionsM Data.Array.Judy.HashIO Data.Array.Judy.Refeable Data.Array.Judy.Stringable+        other-modules:       Data.Array.Judy.Private Data.Array.Judy.MiniGC+        -- Tell Cabal to link to the C library, wheresoever it is.         extra-libraries:     Judy -        extensions:          ForeignFunctionInterface, TypeSynonymInstances, MagicHash, MultiParamTypeClasses,-                             IncoherentInstances, UndecidableInstances, DeriveDataTypeable, FlexibleInstances+        extensions:          ForeignFunctionInterface, TypeSynonymInstances, MagicHash, MultiParamTypeClasses, FlexibleContexts,+                             IncoherentInstances, UndecidableInstances, DeriveDataTypeable, FlexibleInstances, FunctionalDependencies         ghc-options:         -Wall -O2

@@ -1,238 +0,0 @@-{-# 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)---}-

@@ -1,197 +0,0 @@-{-# 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'

@@ -1,6 +0,0 @@-module Judy.Freeze(Frozen(),Freezable(..)) where--import Judy.Private--class Freezable a where-    freeze :: a -> IO (Frozen a)

@@ -1,229 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, IncoherentInstances #-}--{-# 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

@@ -1,41 +0,0 @@-{-# LANGUAGE MagicHash, FlexibleInstances, OverlappingInstances, IncoherentInstances #-}--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-

@@ -1,315 +0,0 @@-{-# 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

@@ -1,102 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# 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

@@ -1,170 +0,0 @@--- | 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-

@@ -1,36 +0,0 @@-{-# LANGUAGE MagicHash, UndecidableInstances, IncoherentInstances, FlexibleInstances  #-}-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--

@@ -1,224 +0,0 @@-{-# 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

@@ -1,43 +0,0 @@-{-# 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