diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,11 @@ +[0.4.0]: + +* New streaming interface (experimental) + +[0.3.1]: + +* Deprecate `mapIter`, `iterItems`, `iterKeys`, `iterValues` + [0.3.0]: * ResourceT is no longer compulsory diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -5,6 +5,14 @@ ## History +Version 0.4.0: + +* New streaming interface (experimental) + +Version 0.3.1: + +* Deprecate `mapIter`, `iterItems`, `iterKeys`, `iterValues` + Version 0.3.0: * ResourceT is no longer compulsory diff --git a/examples/comparator.hs b/examples/comparator.hs --- a/examples/comparator.hs +++ b/examples/comparator.hs @@ -4,10 +4,10 @@ module Main where -import Control.Monad.IO.Class (liftIO) -import Data.Default - -import Database.LevelDB +import Control.Monad.IO.Class (liftIO) +import Data.Default +import Database.LevelDB +import qualified Database.LevelDB.Streaming as S customComparator :: Comparator @@ -24,8 +24,8 @@ put db def "yyy" "" put db def "xxx" "" - withIterator db def $ \iter -> do - iterFirst iter - iterItems iter >>= liftIO . print + withIterator db def $ \iter -> liftIO $ + S.toList (S.entrySlice iter S.AllKeys S.Asc) + >>= print return () diff --git a/examples/features.hs b/examples/features.hs --- a/examples/features.hs +++ b/examples/features.hs @@ -4,14 +4,14 @@ -- module Main where -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Resource (release) -import Data.ByteString.Char8 hiding (take) -import Data.Default -import Prelude hiding (putStrLn) - -import Database.LevelDB +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (release) +import Data.ByteString.Char8 hiding (take) +import Data.Default +import Database.LevelDB +import qualified Database.LevelDB.Streaming as S +import Prelude hiding (putStrLn) main :: IO () @@ -59,10 +59,9 @@ return () where - - dumpEntries iter = do - iterFirst iter - iterItems iter >>= liftIO . print + dumpEntries iter = liftIO $ + S.toList (S.entrySlice iter S.AllKeys S.Asc) + >>= print printProperty l p = liftIO $ do putStrLn l diff --git a/leveldb-haskell.cabal b/leveldb-haskell.cabal --- a/leveldb-haskell.cabal +++ b/leveldb-haskell.cabal @@ -1,5 +1,5 @@ name: leveldb-haskell -version: 0.3.1 +version: 0.4.0 synopsis: Haskell bindings to LevelDB homepage: http://github.com/kim/leveldb-haskell bug-reports: http://github.com/kim/leveldb-haskell/issues @@ -45,13 +45,16 @@ , Database.LevelDB.Internal , Database.LevelDB.Iterator , Database.LevelDB.MonadResource + , Database.LevelDB.Streaming , Database.LevelDB.Types + , Data.Stream.Monadic default-language: Haskell2010 build-depends: base >= 3 && < 5 , bytestring , data-default + , exceptions == 0.6.* , filepath , resourcet > 0.3.2 , transformers @@ -73,7 +76,7 @@ , data-default , leveldb-haskell - ghc-options: -Wall -Werror -O -rtsopts + ghc-options: -Wall -O -rtsopts ghc-prof-options: -prof -auto-all hs-source-dirs: examples @@ -115,7 +118,7 @@ , data-default , leveldb-haskell - ghc-options: -Wall -Werror -O -rtsopts + ghc-options: -Wall -O -rtsopts ghc-prof-options: -prof -auto-all hs-source-dirs: examples @@ -136,7 +139,7 @@ , data-default , leveldb-haskell - ghc-options: -Wall -Werror -O -rtsopts + ghc-options: -Wall -O -rtsopts ghc-prof-options: -prof -auto-all hs-source-dirs: examples @@ -145,3 +148,25 @@ buildable: True else buildable: False + +test-suite leveldb-properties + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + + default-language: Haskell2010 + + build-depends: base + , bytestring + , data-default + , directory + , exceptions == 0.6.* + , mtl + , leveldb-haskell + , QuickCheck == 2.7.* + , tasty == 0.10.* + , tasty-quickcheck == 0.8.* + , temporary + , transformers + + ghc-options: -Wall -O -rtsopts -threaded -with-rtsopts=-N diff --git a/src/Data/Stream/Monadic.hs b/src/Data/Stream/Monadic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Stream/Monadic.hs @@ -0,0 +1,661 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} + +-- | +-- Module : Data.Stream.Monadic +-- Copyright : (c) 2014 Kim Altintop +-- License : BSD3 +-- Maintainer : kim.altintop@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- +-- (Mostly mechanical) adaptation of the +-- +-- module from the +-- package to a +-- monadic 'Stream' datatype similar to the one +-- by +-- Michael Snoyman for the +-- package. +-- +-- The intention here is to provide a high-level, "Data.List"-like interface to +-- "Database.LevelDB.Iterator"s with predictable space and time complexity (see +-- "Database.LevelDB.Streaming"), and without introducing a dependency eg. on +-- one of the streaming libraries (all relevant datatypes are fully exported, +-- though, so it should be straightforward to write wrappers for your favourite +-- streaming library). +-- +-- Fusion and inlining rules and strictness annotations have been put in place +-- faithfully, and may need further profiling. Also, some functions (from +-- "Data.List") have been omitted as either no obvious solution exists (notably +-- @mapM@), they didn't seem too useful in the given context (eg. @lookup@), or +-- I was just too lazy. Missing functions may be added upon +-- . + +module Data.Stream.Monadic + ( Step (..) + , Stream (..) + + -- * Conversion with lists + , toList + , fromList + + -- * Basic functions + , append + , cons + , snoc + , head + , last + , tail + , init + , null + , length + + -- * Transformations + , map + -- , mapM + , intersperse + + -- * Folds + , foldl + , foldl' + -- , foldl1 + -- , foldl1' + , foldr + -- , foldr1 + , foldMap + , foldM + , foldM_ + + -- * Special folds + -- , concat + , concatMap + -- , and + -- , or + -- , any + -- , all + -- , sum + -- , product + -- , maximum + -- , minimum + + -- , scanl + -- , scanl1 + + -- * Infinite streams + , iterate + , repeat + , replicate + , cycle + + -- * Unfolding + , unfoldr + , unfoldrM + + -- , isPrefixOf + + -- * Searching streams + -- , elem + -- , lookup + + -- , find + , filter + + -- , index + -- , findIndex + -- , elemIndex + -- , elemIndices + -- , findIndices + + -- * Substreams + , take + , drop + -- , splitAt + , takeWhile + , dropWhile + + -- * Zipping and unzipping + , zip + -- , zip3 + -- , zip4 + , zipWith + -- , zipWith3 + -- , zipWith4 + , unzip + + -- , insertBy + -- , maximumBy + -- , minimumBy + + -- , genericLength + -- , genericTake + -- , genericDrop + -- , genericIndex + -- , genericSplitAt + + -- , enumFromToInt + -- , enumFromToChar + -- , enumDeltaInteger + ) +where + +import Control.Applicative +import Data.Monoid + +import Prelude (Bool (..), Either (..), Eq (..), Functor (..), Int, Maybe (..), + Monad (..), Num (..), Ord (..), error, otherwise, ($), (&&), + (.), (=<<)) + + +data Step a s + = Yield a !s + | Skip !s + | Done + +data Stream m a = forall s. Stream (s -> m (Step a s)) (m s) + +instance Monad m => Functor (Stream m) where + fmap = map + + +toList :: (Functor m, Monad m) => Stream m a -> m [a] +toList (Stream next s0) = unfold =<< s0 + where + unfold !s = do + step <- next s + case step of + Done -> return [] + Skip s' -> unfold s' + Yield x s' -> (x :) <$> unfold s' + +fromList :: Monad m => [a] -> Stream m a +fromList xs = Stream next (return xs) + where + {-# INLINE next #-} + next [] = return Done + next (x:xs') = return $ Yield x xs' + +{-# RULES + "Stream fromList/toList fusion" forall s. + fmap fromList (toList s) = return s + #-} + +append :: (Functor m, Monad m) => Stream m a -> Stream m a -> Stream m a +append (Stream next0 s0) (Stream next1 s1) = Stream next (Left <$> s0) + where + {-# INLINE next #-} + next (Left s) = do + step <- next0 s + case step of + Done -> Skip . Right <$> s1 + Skip s' -> return $ Skip (Left s') + Yield x s' -> return $ Yield x (Left s') + + next (Right s) = do + step <- next1 s + return $ case step of + Done -> Done + Skip s' -> Skip (Right s') + Yield x s' -> Yield x (Right s') +{-# INLINE [0] append #-} + +cons :: (Functor m, Monad m) => a -> Stream m a -> Stream m a +cons w (Stream next0 s0) = Stream next ((,) S2 <$> s0) + where + {-# INLINE next #-} + next (S2, s) = return $ Yield w (S1, s) + next (S1, s) = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (S1, s') + Yield x s' -> Yield x (S1, s') +{-# INLINE [0] cons #-} + +snoc :: (Functor m, Monad m) => Stream m a -> a -> Stream m a +snoc (Stream next0 s0) y = Stream next (Just <$> s0) + where + {-# INLINE next #-} + next Nothing = return Done + next (Just s) = do + step <- next0 s + return $ case step of + Done -> Yield y Nothing + Skip s' -> Skip (Just s') + Yield x s' -> Yield x (Just s') +{-# INLINE [0] snoc #-} + +-- | Unlike 'Data.List.head', this function does not diverge if the 'Stream is +-- empty. Instead, 'Nothing' is returned. +head :: Monad m => Stream m a -> m (Maybe a) +head (Stream next s0) = loop =<< s0 + where + loop !s = do + step <- next s + case step of + Yield x _ -> return $ Just x + Skip s' -> loop s' + Done -> return Nothing +{-# INLINE [0] head #-} + +-- | Unlike 'Data.List.last', this function does not diverge if the 'Stream' is +-- empty. Instead, 'Nothing' is returned. +last :: Monad m => Stream m a -> m (Maybe a) +last (Stream next s0) = loop =<< s0 + where + loop !s = do + step <- next s + case step of + Done -> return Nothing + Skip s' -> loop s' + Yield x s' -> loop' x s' + loop' x !s = do + step <- next s + case step of + Done -> return $ Just x + Skip s' -> loop' x s' + Yield x' s' -> loop' x' s' +{-# INLINE [0] last #-} + +data Switch = S1 | S2 + +-- | Unlike 'Data.List.tail', this function does not diverge if the 'Stream' is +-- empty. Instead, it is the identity in this case. +tail :: (Functor m, Monad m) => Stream m a -> Stream m a +tail (Stream next0 s0) = Stream next ((,) S1 <$> s0) + where + {-# INLINE next #-} + next (S1, s) = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (S1, s') + Yield _ s' -> Skip (S2, s') + + next (S2, s) = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (S2, s') + Yield x s' -> Yield x (S2, s') +{-# INLINE [0] tail #-} + +-- | Unlike 'Data.List.init', this function does not diverge if the 'Stream' is +-- empty. Instead, it is the identity in this case. +init :: (Functor m, Monad m) => Stream m a -> Stream m a +init (Stream next0 s0) = Stream next ((,) Nothing <$> s0) + where + {-# INLINE next #-} + next (Nothing, s) = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (Nothing, s') + Yield x s' -> Skip (Just x , s') + + next (Just x, s) = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (Just x , s') + Yield x' s' -> Yield x (Just x', s') +{-# INLINE [0] init #-} + +null :: Monad m => Stream m a -> m Bool +null (Stream next s0) = loop =<< s0 + where + loop !s = do + step <- next s + case step of + Done -> return True + Yield _ _ -> return False + Skip s' -> loop s' +{-# INLINE [0] null #-} + +length :: Monad m => Stream m a -> m Int +length (Stream next s0) = loop 0 =<< s0 + where + loop !z !s = do + step <- next s + case step of + Done -> return z + Skip s' -> loop z s' + Yield _ s' -> loop (z+1) s' +{-# INLINE [0] length #-} + +filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +filter p (Stream next0 s0) = Stream next s0 + where + {-# INLINE next #-} + next !s = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip s' + Yield x s' | p x -> Yield x s' + | otherwise -> Skip s' +{-# INLINE [0] filter #-} +{-# RULES + "Stream filter/filter fusion" forall p q s. + filter p (filter q s) = filter (\x -> q x && p x) s + #-} + +map :: Monad m => (a -> b) -> Stream m a -> Stream m b +map f (Stream next0 s0) = Stream next s0 + where + {-# INLINE next #-} + next !s = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip s' + Yield x s' -> Yield (f x) s' +{-# INLINE [0] map #-} +{-# RULES + "Stream map/map fusion" forall f g s. + map f (map g s) = map (\x -> f (g x)) s + #-} + +-- 'mapM' is tricky: +-- +-- > mapM :: (Monad m, Monad n) => (a -> n b) -> Stream m a -> n (Stream n b) +-- +-- we would need a constraint which specifies how to lift any monad /m/ into +-- some monad /n/ (or specialise /m/ to 'IO'). +-- +-- alternatively, we may define: +-- +-- > mapM :: Monad m => (a -> m b) -> Stream m a -> m (Stream m b) +-- +-- or rather: +-- +-- > mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b +-- +-- not sure how useful this would be. + + +intersperse :: (Functor m, Monad m) => a -> Stream m a -> Stream m a +intersperse sep (Stream next0 s0) = Stream next ((,,) Nothing S1 <$> s0) + where + {-# INLINE next #-} + next (Nothing, S1, s) = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (Nothing, S1, s') + Yield x s' -> Skip (Just x , S1, s') + + next (Just x, S1, s) = return $ Yield x (Nothing, S2, s) + + next (Nothing, S2, s) = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (Nothing, S2, s') + Yield x s' -> Yield sep (Just x , S1, s') + + next (Just _, S2, _) = error "Data.Stream.Monadic.intersperse: impossible" +{-# INLINE [0] intersperse #-} + +foldMap :: (Monoid m, Functor n, Monad n) => (a -> m) -> Stream n a -> n m +foldMap f (Stream next s0) = loop mempty =<< s0 + where + loop z !s = do + step <- next s + case step of + Done -> return z + Skip s' -> loop z s' + Yield x s' -> loop (z <> f x) s' +{-# INLINE [0] foldMap #-} + +-- | Left-associative fold. +-- +-- Note that the /direction/ of the traversal is not defined here. +foldl :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b +foldl f z0 (Stream next s0) = loop z0 =<< s0 + where + loop z !s = do + step <- next s + case step of + Done -> return z + Skip s' -> loop z s' + Yield x s' -> loop (f z x) s' +{-# INLINE [0] foldl #-} + +-- | Left-associative fold with strict accumulator. +-- +-- Note that the /direction/ of the traversal is not defined here. +foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b +foldl' f z0 (Stream next s0) = loop z0 =<< s0 + where + loop !z !s = do + step <- next s + case step of + Done -> return z + Skip s' -> loop z s' + Yield x s' -> loop (f z x) s' +{-# INLINE [0] foldl' #-} + +-- | Right-associative fold. +-- +-- Note that the /direction/ of the traversal is not defined here. +foldr :: (Functor m, Monad m) => (a -> b -> b) -> b -> Stream m a -> m b +foldr f z (Stream next s0) = loop =<< s0 + where + loop !s = do + step <- next s + case step of + Done -> return z + Skip s' -> loop s' + Yield x s' -> f x <$> loop s' +{-# INLINE [0] foldr #-} + +foldM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m b +foldM f z0 (Stream next s0) = loop z0 =<< s0 + where + loop z !s = do + step <- next s + case step of + Done -> return z + Skip s' -> loop z s' + Yield x s' -> f z x >>= (`loop` s') +{-# INLINE [0] foldM #-} + +foldM_ :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m () +foldM_ f z0 (Stream next s0) = loop z0 =<< s0 + where + loop z !s = do + step <- next s + case step of + Done -> return () + Skip s' -> loop z s' + Yield x s' -> f z x >>= (`loop` s') +{-# INLINE [0] foldM_ #-} + +concatMap :: (Functor m, Monad m) => (a -> Stream m b) -> Stream m a -> Stream m b +concatMap f (Stream next0 s0) = Stream next ((,) Nothing <$> s0) + where + {-# INLINE next #-} + next (Nothing, s) = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (Nothing , s') + Yield x s' -> Skip (Just (f x), s') + + next (Just (Stream g t), s) = do + step <- g =<< t + return $ case step of + Done -> Skip (Nothing , s) + Skip t' -> Skip (Just (Stream g (return t')), s) + Yield x t' -> Yield x (Just (Stream g (return t')), s) +{-# INLINE [0] concatMap #-} + +iterate :: Monad m => (a -> a) -> a -> Stream m a +iterate f x0 = Stream next (return x0) + where + {-# INLINE next #-} + next x = return $ Yield x (f x) +{-# INLINE [0] iterate #-} + +repeat :: Monad m => a -> Stream m a +repeat x = Stream next (return ()) + where + {-# INLINE next #-} + next _ = return $ Yield x () +{-# INLINE [0] repeat #-} +{-# RULES + "map/repeat" forall f x. map f (repeat x) = repeat (f x) + #-} + +replicate :: Monad m => Int -> a -> Stream m a +replicate n x = Stream next (return n) + where + {-# INLINE next #-} + next !i | i <= 0 = return Done + | otherwise = return $ Yield x (i-1) +{-# INLINE [0] replicate #-} +{-# RULES + "map/replicate" forall f n x. map f (replicate n x) = replicate n (f x) + #-} + +-- | Unlike 'Data.List.cycle', this function does not diverge if the 'Stream' is +-- empty. Instead, it is the identity in this case. +cycle :: (Functor m, Monad m) => Stream m a -> Stream m a +cycle (Stream next0 s0) = Stream next ((,) S1 <$> s0) + where + {-# INLINE next #-} + next (S1, s) = do + step <- next0 s + return $ case step of + Done -> Done -- error? + Skip s' -> Skip (S1, s') + Yield x s' -> Yield x (S2, s') + + next (S2, s) = do + step <- next0 s + case step of + Done -> Skip . ((,) S2) <$> s0 + Skip s' -> return $ Skip (S2, s') + Yield x s' -> return $ Yield x (S2, s') +{-# INLINE [0] cycle #-} + +unfoldr :: Monad m => (b -> Maybe (a, b)) -> b -> Stream m a +unfoldr f s0 = Stream next (return s0) + where + {-# INLINE next #-} + next s = return $ case f s of + Nothing -> Done + Just (w, s') -> Yield w s' +{-# INLINE [0] unfoldr #-} + +-- | Build a stream from a monadic seed (or state function). +unfoldrM :: (Functor m, Monad m) => (b -> Maybe (a, m b)) -> m b -> Stream m a +unfoldrM f s0 = Stream next s0 + where + {-# INLINE next #-} + next s = case f s of + Nothing -> return Done + Just (w, s') -> Yield w <$> s' +{-# INLINE [0] unfoldrM #-} + +take :: (Functor m, Monad m) => Int -> Stream m a -> Stream m a +take n0 (Stream next0 s0) = Stream next ((,) n0 <$> s0) + where + {-# INLINE next #-} + next (!n, s) + | n <= 0 = return Done + | otherwise = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (n , s') + Yield x s' -> Yield x (n-1, s') +{-# INLINE [0] take #-} + +drop :: (Functor m, Monad m) => Int -> Stream m a -> Stream m a +drop n0 (Stream next0 s0) = Stream next ((,) (Just (max 0 n0)) <$> s0) + where + {-# INLINE next #-} + next (Just !n, s) + | n == 0 = return $ Skip (Nothing, s) + | otherwise = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (Just n , s') + Yield _ s' -> Skip (Just (n-1), s') + next (Nothing, s) = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (Nothing, s') + Yield x s' -> Yield x (Nothing, s') +{-# INLINE [0] drop #-} + +takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +takeWhile p (Stream next0 s0) = Stream next s0 + where + {-# INLINE next #-} + next !s = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip s' + Yield x s' | p x -> Yield x s' + | otherwise -> Done +{-# INLINE [0] takeWhile #-} + +dropWhile :: (Functor m, Monad m) => (a -> Bool) -> Stream m a -> Stream m a +dropWhile p (Stream next0 s0) = Stream next ((,) S1 <$> s0) + where + {-# INLINE next #-} + next (S1, s) = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (S1, s') + Yield x s' | p x -> Skip (S1, s') + | otherwise -> Yield x (S2, s') + next (S2, s) = do + step <- next0 s + return $ case step of + Done -> Done + Skip s' -> Skip (S2, s') + Yield x s' -> Yield x (S2, s') +{-# INLINE [0] dropWhile #-} + +zip :: (Functor m, Applicative m, Monad m) + => Stream m a + -> Stream m b + -> Stream m (a, b) +zip = zipWith (,) +{-# INLINE zip #-} + +zipWith :: (Functor m, Applicative m, Monad m) + => (a -> b -> c) + -> Stream m a + -> Stream m b + -> Stream m c +zipWith f (Stream nexta sa0) (Stream nextb sb0) = + Stream next ((,,) Nothing <$> sa0 <*> sb0) + where + {-# INLINE next #-} + next (Nothing, sa, sb) = do + step <- nexta sa + return $ case step of + Done -> Done + Skip sa' -> Skip (Nothing, sa', sb) + Yield a sa' -> Skip (Just a , sa', sb) + + next (Just a, sa', sb) = do + step <- nextb sb + return $ case step of + Done -> Done + Skip sb' -> Skip (Just a, sa', sb') + Yield b sb' -> Yield (f a b) (Nothing, sa', sb') +{-# INLINE [0] zipWith #-} + +unzip :: (Functor m, Monad m) => Stream m (a, b) -> m ([a], [b]) +unzip = foldr (\(a,b) ~(as, bs) -> (a:as, b:bs)) ([], []) +{-# INLINE unzip #-} diff --git a/src/Database/LevelDB.hs b/src/Database/LevelDB.hs --- a/src/Database/LevelDB.hs +++ b/src/Database/LevelDB.hs @@ -11,6 +11,6 @@ -- The API closely follows the C-API of LevelDB. -- For more information, see: -module Database.LevelDB (module R) where +module Database.LevelDB (module Database.LevelDB.MonadResource) where -import Database.LevelDB.MonadResource as R +import Database.LevelDB.MonadResource diff --git a/src/Database/LevelDB/Base.hs b/src/Database/LevelDB/Base.hs --- a/src/Database/LevelDB/Base.hs +++ b/src/Database/LevelDB/Base.hs @@ -59,8 +59,8 @@ where import Control.Applicative ((<$>)) -import Control.Exception (bracket, bracketOnError, finally) import Control.Monad (liftM) +import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.ByteString (ByteString) import Data.ByteString.Internal (ByteString (..)) @@ -98,9 +98,8 @@ -- | Run an action with a 'Snapshot' of the database. -withSnapshot :: MonadIO m => DB -> (Snapshot -> IO a) -> m a -withSnapshot db act = liftIO $ - bracket (createSnapshot db) (releaseSnapshot db) act +withSnapshot :: (MonadMask m, MonadIO m) => DB -> (Snapshot -> m a) -> m a +withSnapshot db = bracket (createSnapshot db) (releaseSnapshot db) -- | Create a snapshot of the database. -- diff --git a/src/Database/LevelDB/Iterator.hs b/src/Database/LevelDB/Iterator.hs --- a/src/Database/LevelDB/Iterator.hs +++ b/src/Database/LevelDB/Iterator.hs @@ -15,28 +15,23 @@ , iterEntry , iterFirst , iterGetError - , iterItems , iterKey - , iterKeys , iterLast , iterNext , iterPrev , iterSeek , iterValid , iterValue - , iterValues - , mapIter , releaseIter , withIter ) where import Control.Applicative ((<$>), (<*>)) -import Control.Exception (bracket, finally, onException) import Control.Monad (when) +import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.ByteString (ByteString) -import Data.Maybe (catMaybes) import Foreign import Foreign.C.Error (throwErrnoIfNull) import Foreign.C.String (CString, peekCString) @@ -82,8 +77,8 @@ c_leveldb_iter_destroy iter_ptr `finally` freeCReadOpts opts -- | Run an action with an 'Iterator' -withIter :: MonadIO m => DB -> ReadOptions -> (Iterator -> IO a) -> m a -withIter db opts = liftIO . bracket (createIter db opts) releaseIter +withIter :: (MonadMask m, MonadIO m) => DB -> ReadOptions -> (Iterator -> m a) -> m a +withIter db opts = bracket (createIter db opts) releaseIter -- | An iterator is either positioned at a key/value pair, or not valid. This -- function returns /true/ iff the iterator is valid. @@ -164,52 +159,6 @@ else do err <- peekCString erra return . Just . BC.pack $ err - --- | Map a function over an iterator, advancing the iterator forward and --- returning the value. The iterator should be put in the right position prior --- to calling the function. --- --- Note that this function accumulates the result strictly, ie. it reads all --- values into memory until the iterator is exhausted. This is most likely not --- what you want for large ranges. You may consider using conduits instead, for --- an example see: -mapIter :: MonadIO m => (Iterator -> m a) -> Iterator -> m [a] -mapIter f iter@(Iterator iter_ptr _) = go [] - where - go acc = do - valid <- liftIO $ c_leveldb_iter_valid iter_ptr - if valid == 0 - then return acc - else do - val <- f iter - () <- liftIO $ c_leveldb_iter_next iter_ptr - go (val : acc) -{-# DEPRECATED mapIter "will be removed in the next release" #-} - --- | Return a list of key and value tuples from an iterator. The iterator --- should be put in the right position prior to calling this with the iterator. --- --- See strictness remarks on 'mapIter'. -iterItems :: (Functor m, MonadIO m) => Iterator -> m [(ByteString, ByteString)] -iterItems iter = catMaybes <$> mapIter iterEntry iter -{-# DEPRECATED iterItems "will be removed in the next release" #-} - --- | Return a list of key from an iterator. The iterator should be put --- in the right position prior to calling this with the iterator. --- --- See strictness remarks on 'mapIter' -iterKeys :: (Functor m, MonadIO m) => Iterator -> m [ByteString] -iterKeys iter = catMaybes <$> mapIter iterKey iter -{-# DEPRECATED iterKeys "will be removed in the next release" #-} - --- | Return a list of values from an iterator. The iterator should be put --- in the right position prior to calling this with the iterator. --- --- See strictness remarks on 'mapIter' -iterValues :: (Functor m, MonadIO m) => Iterator -> m [ByteString] -iterValues iter = catMaybes <$> mapIter iterValue iter -{-# DEPRECATED iterValues "will be removed in the next release" #-} - -- -- Internal diff --git a/src/Database/LevelDB/MonadResource.hs b/src/Database/LevelDB/MonadResource.hs --- a/src/Database/LevelDB/MonadResource.hs +++ b/src/Database/LevelDB/MonadResource.hs @@ -60,10 +60,6 @@ , iterKey , iterValue , iterGetError - , mapIter - , iterItems - , iterKeys - , iterValues -- * Re-exports , MonadResource (..) @@ -244,43 +240,6 @@ -- Note that this captures somewhat severe errors such as a corrupted database. iterGetError :: MonadResource m => Iterator -> m (Maybe ByteString) iterGetError = Base.iterGetError - - --- | Map a function over an iterator, advancing the iterator forward and --- returning the value. The iterator should be put in the right position prior --- to calling the function. --- --- Note that this function accumulates the result strictly, ie. it reads all --- values into memory until the iterator is exhausted. This is most likely not --- what you want for large ranges. You may consider using conduits instead, for --- an example see: -mapIter :: MonadResource m => (Iterator -> m a) -> Iterator -> m [a] -mapIter = Base.mapIter -{-# DEPRECATED mapIter "will be removed in the next release" #-} - --- | Return a list of key and value tuples from an iterator. The iterator --- should be put in the right position prior to calling this with the iterator. --- --- See strictness remarks on 'mapIter'. -iterItems :: MonadResource m => Iterator -> m [(ByteString, ByteString)] -iterItems = Base.iterItems -{-# DEPRECATED iterItems "will be removed in the next release" #-} - --- | Return a list of key from an iterator. The iterator should be put --- in the right position prior to calling this with the iterator. --- --- See strictness remarks on 'mapIter' -iterKeys :: MonadResource m => Iterator -> m [ByteString] -iterKeys = Base.iterKeys -{-# DEPRECATED iterKeys "will be removed in the next release" #-} - --- | Return a list of values from an iterator. The iterator should be put --- in the right position prior to calling this with the iterator. --- --- See strictness remarks on 'mapIter' -iterValues :: MonadResource m => Iterator -> m [ByteString] -iterValues = Base.iterValues -{-# DEPRECATED iterValues "will be removed in the next release" #-} -- | Return the runtime version of the underlying LevelDB library as a (major, diff --git a/src/Database/LevelDB/Streaming.hs b/src/Database/LevelDB/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/Database/LevelDB/Streaming.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Database.LevelDB.Streaming +-- Copyright : (c) 2014 Kim Altintop +-- License : BSD3 +-- Maintainer : kim.altintop@gmail.com +-- Stability : experimental +-- Portability : non-portable +-- +-- High-level, "Data.List"-like, streaming interface to +-- "Database.LevelDB.Iterator". +-- +-- This module contains types and functions to construct 'Stream's from +-- 'Database.LevelDB.Iterator.Iterator's, and re-exports the functions operating +-- on 'Stream's from "Data.Stream.Monadic". +-- +-- __Note__ that most of the functions from the latter module are +-- (intentionally) conflicting with the "Prelude", it is thus recommended to +-- import this module qualified: +-- +-- > import Database.LevelDB -- or Database.LevelDB.Base +-- > import qualified Database.LevelDB.Streaming as S + +module Database.LevelDB.Streaming + ( Slice (..) + , KeyRange (..) + , Direction (..) + , Key + , Value + , Entry + + -- * Constructing streams + , keySlice + , entrySlice + + -- * Re-exports + , module Data.Stream.Monadic + ) +where + +import Control.Applicative +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.Stream.Monadic +import Database.LevelDB.Base + +import Prelude hiding (drop, filter, foldl, map, mapM, mapM_, take) + + +data Slice = Slice !Iterator (Maybe KeyRange) !Direction + +data KeyRange + = KeyRange { start :: !ByteString + , end :: ByteString -> Ordering + } + | AllKeys + +data Direction = Asc | Desc + deriving Show + +type Key = ByteString +type Value = ByteString +type Entry = (Key, Value) + + +-- | Create a 'Stream' which yields only the keys of the given 'KeyRange' (in +-- the given 'Direction'). +-- +-- Since traversing the 'Stream' mutates the state of the underlying 'Iterator', +-- it is obviously __unsafe__ to share the latter (between threads, or when +-- 'Data.Stream.Monadic.zip'ping). Hence, it is __highly__ recommended to create +-- a new 'Iterator' for each 'Stream'. +keySlice :: (Applicative m, MonadIO m) + => Iterator + -> KeyRange + -> Direction + -> Stream m Key +keySlice i (KeyRange s e) d = Stream next (iterSeek i s >> pure i) + where + next it = do + key <- iterKey it + case key of + Nothing -> pure Done + Just k -> case d of + Asc | e k < GT -> Yield k <$> (iterNext it >> pure it) + | otherwise -> pure Done + Desc | e k > EQ -> Yield k <$> (iterPrev it >> pure it) + | otherwise -> pure Done + +keySlice i AllKeys Asc = Stream next (iterFirst i >> pure i) + where + next it = iterKey it + >>= maybe (pure Done) (\ k -> Yield k <$> (iterNext it >> pure it)) + +keySlice i AllKeys Desc = Stream next (iterLast i >> pure i) + where + next it = iterKey it + >>= maybe (pure Done) (\ k -> Yield k <$> (iterPrev it >> pure it)) + +-- | Create a 'Stream' which yields key/value pairs of the given 'KeyRange' (in +-- the given 'Direction'). +-- +-- Since traversing the 'Stream' mutates the state of the underlying 'Iterator', +-- it is obviously __unsafe__ to share the latter (between threads, or when +-- 'Data.Stream.Monadic.zip'ping). Hence, it is __highly__ recommended to create +-- a new 'Iterator' for each 'Stream'. +entrySlice :: (Applicative m, MonadIO m) + => Iterator + -> KeyRange + -> Direction + -> Stream m Entry +entrySlice i (KeyRange s e) d = Stream next (iterSeek i s >> pure i) + where + next it = do + entry <- iterEntry it + case entry of + Nothing -> pure Done + Just x@(!k,_) -> case d of + Asc | e k < GT -> Yield x <$> (iterNext it >> pure it) + | otherwise -> pure Done + Desc | e k > EQ -> Yield x <$> (iterPrev it >> pure it) + | otherwise -> pure Done + +entrySlice i AllKeys Asc = Stream next (iterFirst i >> pure i) + where + next it = iterEntry it + >>= maybe (pure Done) (\ x -> Yield x <$> (iterNext it >> pure it)) + +entrySlice i AllKeys Desc = Stream next (iterLast i >> pure i) + where + next it = iterEntry it + >>= maybe (pure Done) (\ x -> Yield x <$> (iterPrev it >> pure it)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified Test.Streaming as Streaming +import Test.Tasty + + +main :: IO () +main = defaultMain $ testGroup "Tests" [ Streaming.tests ]