├── .github
└── workflows
│ └── matrix.yaml
├── .gitignore
├── AUTHORS
├── CHANGELOG
├── LICENSE
├── Makefile
├── Readme.md
├── Setup.hs
├── examples
├── Makefile
├── comparator.hs
├── features.hs
├── filterpolicy.hs
└── iterforkio.hs
├── leveldb-haskell.cabal
├── src
├── Data
│ └── Stream
│ │ └── Monadic.hs
└── Database
│ ├── LevelDB.hs
│ └── LevelDB
│ ├── Base.hs
│ ├── C.hsc
│ ├── Internal.hs
│ ├── Iterator.hs
│ ├── MonadResource.hs
│ ├── Streaming.hs
│ └── Types.hs
└── test
├── Main.hs
└── Test
└── Streaming.hs
/.github/workflows/matrix.yaml:
--------------------------------------------------------------------------------
1 | name: Matrix Build
2 |
3 | on: pull_request
4 |
5 | jobs:
6 | linux:
7 | runs-on: ubuntu-latest
8 | strategy:
9 | fail-fast: false
10 | matrix:
11 | versions:
12 | # Three stable versions
13 | - ghc: '9.10.1'
14 | - ghc: '9.8.2'
15 | - ghc: '9.6.5'
16 | # Latest as moving target
17 | - ghc: 'latest'
18 | steps:
19 | - uses: actions/checkout@v2
20 |
21 | - name: Install recent cabal/ghc
22 | uses: haskell/actions/setup@v1
23 | with:
24 | ghc-version: ${{ matrix.versions.ghc }}
25 |
26 | - name: Install native leveldb
27 | run: sudo apt-get install --yes libleveldb-dev libsnappy-dev
28 |
29 | - name: Cache cabal global package db
30 | id: cabal-global
31 | uses: actions/cache@v2
32 | with:
33 | path: |
34 | ~/.cabal
35 | key: ${{ runner.os }}-${{ matrix.versions.ghc }}-cabal-global-${{ hashFiles('cabal.project') }}
36 |
37 | - name: Cache cabal work
38 | id: cabal-local
39 | uses: actions/cache@v2
40 | with:
41 | path: |
42 | dist-newstyle
43 | key: ${{ runner.os }}-${{ matrix.versions.ghc }}-cabal-local
44 |
45 | - name: Install dependencies
46 | run: |
47 | cabal update
48 | cabal build all --dependencies-only --enable-tests --disable-optimization
49 | - name: Build
50 | run: |
51 | cabal build all --enable-tests --disable-optimization 2>&1
52 | - name: Test
53 | run: |
54 | cabal test all --disable-optimization
55 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | cabal-dev
2 | dist
3 | tags
4 | *.o
5 | *.swp
6 | *.a
7 | *.hi
8 | .cabal-sandbox
9 | cabal.sandbox.config
10 | .stack-work
11 |
--------------------------------------------------------------------------------
/AUTHORS:
--------------------------------------------------------------------------------
1 | # The following people, listed in alphabetical order, contributed to the
2 | # leveldb-haskell library:
3 |
4 | Austin Seipp
5 | Kim Altintop
6 | Michael Lazarev
7 | Nicolas Trangez
8 | Will Moss
9 |
--------------------------------------------------------------------------------
/CHANGELOG:
--------------------------------------------------------------------------------
1 | [0.6.5]:
2 |
3 | * Relaxed constraints in `MonadResource` module
4 |
5 | [0.6.1]:
6 |
7 | * Expose `compactRange`
8 |
9 | [0.6.0]:
10 |
11 | * Slices include the end element (justifies version bump)
12 | * Large parts of the Data.API implemented. This is now completely overdone
13 |
14 | [0.5.0]:
15 |
16 | * Remove `close` from public API
17 |
18 | [0.4.2]:
19 |
20 | * Deprecate `close`
21 |
22 | [0.4.0]:
23 |
24 | * New streaming interface (experimental)
25 |
26 | [0.3.1]:
27 |
28 | * Deprecate `mapIter`, `iterItems`, `iterKeys`, `iterValues`
29 |
30 | [0.3.0]:
31 |
32 | * ResourceT is no longer compulsory
33 |
34 |
35 | [0.2.0]:
36 |
37 | * requires LevelDB v1.7
38 | * support for filter policy (LevelDB v1.5), either custom or using the built-in
39 | bloom filter implementation
40 | * write batch values no longer require a `memcpy` to be early-finalizer-safe
41 | (introduced in 0.1.1)
42 |
43 |
44 | [0.1.0]:
45 |
46 | * memory (foreign pointers) is managed through
47 | [ResourceT](http://hackage.haskell.org/package/resourcet). Note that this
48 | requires to lift monadic actions inside the `MonadResource` monad, see the
49 | examples.
50 | * links against shared library (LevelDB v1.3 or higher)
51 | * LevelDB 1.3 API fully supported (including custom comparators, excluding
52 | custom environments)
53 |
54 |
55 | [0.0.x]:
56 |
57 | * experimental releases
58 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2011, Kim Altintop
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Kim Altintop nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | SHELL := /usr/bin/env bash
2 | NAME := leveldb-haskell
3 | VERSION := $(shell sed -n 's/^version: *\(.*\)$$/\1/p' $(NAME).cabal)
4 | CABAL_SANDBOX ?= $(CURDIR)/.cabal-sandbox
5 |
6 | CONFIGURED := dist/setup-config
7 | DOCS := dist/leveldb-haskell-$(VERSION)-docs.tar.gz
8 |
9 | HACKAGE ?= hackage.haskell.org
10 |
11 |
12 | default: build
13 |
14 | .PHONY: build
15 | build: $(CONFIGURED)
16 | cabal build -j
17 |
18 | .PHONY: deps
19 | deps: cabal.sandbox.config
20 | cabal install -j --only-dep --enable-documentation --enable-test
21 |
22 | .PHONY: dist
23 | dist:
24 | cabal sdist
25 |
26 | .PHONY: docs
27 | docs: $(CONFIGURED)
28 | cabal haddock \
29 | --hoogle \
30 | --html \
31 | --hyperlink-source \
32 | --haddock-option='--built-in-themes' \
33 | --haddock-options='-q aliased' \
34 | --html-location='/package/$$pkg-$$version/docs' \
35 | --contents-location='/package/$$pkg-$$version'
36 |
37 | .PHONY: clean
38 | clean:
39 | cabal clean
40 |
41 | .PHONY: prune
42 | prune: clean
43 | cabal sandbox delete
44 |
45 | .PHONY: publish
46 | publish: upload-package upload-docs
47 |
48 | .PHONY: upload-package
49 | upload-package: dist
50 | cabal upload --username=$(HACKAGE_USER) --password=$(HACKAGE_PASSWORD) \
51 | dist/leveldb-haskell-$(VERSION).tar.gz
52 |
53 | .PHONY: upload-docs
54 | upload-docs: $(DOCS)
55 | curl -XPUT \
56 | -H'Content-Type: application/x-tar' \
57 | -H'Content-Encoding: gzip' \
58 | --data-binary @$(DOCS) \
59 | "https://$(HACKAGE_USER):$(HACKAGE_PASSWORD)@$(HACKAGE)/package/leveldb-haskell-$(VERSION)/docs"
60 |
61 | cabal.sandbox.config:
62 | cabal sandbox init --sandbox=$(CABAL_SANDBOX)
63 |
64 | $(CONFIGURED): cabal.sandbox.config deps $(NAME).cabal
65 | cabal configure --enable-test --enable-bench
66 |
67 | $(DOCS): docs
68 | mkdir -p dist/leveldb-haskell-$(VERSION)-docs
69 | cp -a dist/doc/html/leveldb-haskell/* dist/leveldb-haskell-$(VERSION)-docs
70 | COPYFILE_DISABLE=1 tar -cvz --format=ustar -f $(DOCS) -C dist leveldb-haskell-$(VERSION)-docs
71 |
--------------------------------------------------------------------------------
/Readme.md:
--------------------------------------------------------------------------------
1 | This library provides Haskell bindings to
2 | [LevelDB](https://github.com/google/leveldb)
3 |
4 | [](http://travis-ci.org/kim/leveldb-haskell)
5 |
6 | ## Installation
7 |
8 | Prerequisites:
9 |
10 | * [GHC 7.*](http://www.haskell.org/ghc)
11 | * [Cabal](http://www.haskell.org/cabal), version 1.3 or higher
12 | * [LevelDB](https://github.com/google/leveldb)
13 | * Optional: [Snappy](http://code.google.com/p/snappy),
14 | if compression support is desired
15 |
16 | **Note:** as of version 1.3, LevelDB can be built as a shared library. Thus, as
17 | of version 0.1.0 of this library, LevelDB is no longer bundled and must be
18 | installed on the target system. On many systems / distributions, the LevelDB
19 | library is available via the native package manager. On Windows, you may want to
20 | follow [these instructions](https://github.com/lamdu/lamdu/blob/1623bc38e67361d4ba4f051e23a66985a66ca52c/doc/Build.md#windows).
21 |
22 | To install the latest version from hackage:
23 |
24 | ```shell
25 | $ cabal install leveldb-haskell
26 | ```
27 |
28 | To install from checked-out source:
29 |
30 | ```shell
31 | $ cabal install
32 | ```
33 |
34 | ## Notes
35 |
36 | This library is in very early stage and has seen very limited testing. Comments
37 | and contributions are welcome.
38 |
39 | ## Bugs and Contributing
40 |
41 | Please report issues via http://github.com/kim/leveldb-haskell/issues.
42 | Patches are best submitted as pull requests, or via email
43 | (kim.altintop@gmail.com).
44 |
45 | ## License
46 |
47 | BSD 3, see LICENSE file.
48 |
--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/examples/Makefile:
--------------------------------------------------------------------------------
1 | .PHONY: build clean run
2 |
3 | build :
4 | for s in *.hs; do ghc --make -fforce-recomp -threaded $$s; done
5 |
6 | run : build
7 | for x in `find . -perm -755`; do \
8 | echo "Running $$x..."; \
9 | ./$$x; \
10 | done
11 |
12 | clean :
13 | rm *.hi
14 | rm *.o
15 | find . -perm -755 -delete
16 |
--------------------------------------------------------------------------------
/examples/comparator.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 |
3 | -- | Demo custom comparator
4 |
5 | module Main where
6 |
7 | import Control.Monad.IO.Class (liftIO)
8 | import Data.Default
9 | import Database.LevelDB
10 | import qualified Database.LevelDB.Streaming as S
11 |
12 |
13 | customComparator :: Comparator
14 | customComparator = Comparator compare
15 |
16 | main :: IO ()
17 | main = runResourceT $ do
18 | db <- open "/tmp/lvlcmptest"
19 | defaultOptions{ createIfMissing = True
20 | , comparator = Just customComparator
21 | }
22 |
23 | put db def "zzz" ""
24 | put db def "yyy" ""
25 | put db def "xxx" ""
26 |
27 | withIterator db def $ \iter -> liftIO $
28 | S.toList (S.entrySlice iter S.AllKeys S.Asc)
29 | >>= print
30 |
31 | return ()
32 |
--------------------------------------------------------------------------------
/examples/features.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | -- |
3 | -- Comprehensive walkthough of the functionality provided by this library.
4 | --
5 | module Main where
6 |
7 | import Control.Monad
8 | import Control.Monad.IO.Class (liftIO)
9 | import Control.Monad.Trans.Resource (release)
10 | import Data.ByteString.Char8 hiding (take)
11 | import Data.Default
12 | import Data.Monoid
13 | import Database.LevelDB
14 | import qualified Database.LevelDB.Streaming as S
15 | import Prelude hiding (putStrLn)
16 |
17 |
18 | main :: IO ()
19 | main = runResourceT $ do
20 | printVersion
21 |
22 | db <- open "/tmp/leveltest"
23 | defaultOptions{ createIfMissing = True
24 | , cacheSize= 2048
25 | }
26 |
27 | putStrLn' "Put value"
28 | put db def "foo" "bar"
29 | get db def "foo" >>= liftIO . print
30 |
31 | putStrLn' ""
32 |
33 | putStrLn' "Delete value"
34 | delete db def "foo"
35 | get db def "foo" >>= liftIO . print
36 |
37 |
38 | putStrLn' ""
39 |
40 | (releaseSnap, snap) <- createSnapshot' db
41 |
42 | putStrLn' "Write batch"
43 | write db def{sync = True} [ Put "a" "one"
44 | , Put "b" "two"
45 | , Put "c" "three"
46 | ]
47 |
48 | putStrLn' "Dump entries with old snapshot"
49 | withIterator db def{useSnapshot = Just snap} $ \iter -> dumpEntries iter
50 |
51 | -- early release snapshot
52 | release releaseSnap
53 |
54 | -- here, we keep the iterator around for later reuse.
55 | -- Note that we don't explicitly release it (and thus don't keep the release
56 | -- key). The iterator will be released when runResourceT terminates.
57 | iter <- iterOpen db def
58 | putStrLn' "Dump entries with fresh iterator"
59 | dumpEntries iter
60 |
61 | putStrLn' ""
62 |
63 | printDbSize db
64 | putStrLn' "Trigger compaction"
65 | compactRange db ("a", "z")
66 | printDbSize db
67 |
68 |
69 | putStrLn' ""
70 |
71 | putStrLn' " BEGIN dump properties"
72 | getProperty db SSTables >>= printProperty "SSTables:"
73 | getProperty db Stats >>= printProperty "Stats:"
74 | getProperty db (NumFilesAtLevel 1) >>= printProperty "Num files at level 1:"
75 | putStrLn' " END dump properties"
76 |
77 |
78 | putStrLn' ""
79 |
80 | putStrLn' "Delete batch"
81 | write db def [ Del "a"
82 | , Del "b"
83 | , Del "c"
84 | ]
85 |
86 | putStrLn' "Dump entries"
87 | dumpEntries iter
88 |
89 | return ()
90 |
91 | where
92 | dumpEntries iter = liftIO $
93 | S.toList (S.entrySlice iter S.AllKeys S.Asc)
94 | >>= print
95 |
96 | printProperty l p = do
97 | putStrLn' l
98 | maybe (putStrLn' "n/a") putStrLn' p
99 |
100 | printVersion = do
101 | v <- versionBS
102 | putStrLn' $ "LevelDB Version: " <> v
103 |
104 | printDbSize db = do
105 | s <- approximateSize db ("a", "z")
106 | putStrLn' $ "Approximate DB size: " <> pack (show s)
107 |
108 | versionBS = do
109 | (major, minor) <- version
110 | return $ intToBs major <> "." <> intToBs minor
111 |
112 | intToBs :: Int -> ByteString
113 | intToBs = pack . show
114 |
115 | putStrLn' = liftIO . putStrLn
116 |
--------------------------------------------------------------------------------
/examples/filterpolicy.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 |
3 | -- | Demo filter policy / bloom filter
4 |
5 | module Main where
6 |
7 | import Control.Monad.IO.Class (liftIO)
8 | import Data.Default
9 |
10 | import Database.LevelDB
11 |
12 |
13 | main :: IO ()
14 | main = runResourceT $ do
15 | bloom <- bloomFilter 10
16 | db <- open "/tmp/lvlbloomtest"
17 | defaultOptions { createIfMissing = True
18 | , filterPolicy = Just . Left $ bloom
19 | }
20 |
21 | put db def "zzz" "zzz"
22 | put db def "yyy" "yyy"
23 | put db def "xxx" "xxx"
24 |
25 | get db def "yyy" >>= liftIO . print
26 | get db def "xxx" >>= liftIO . print
27 |
28 | return ()
29 |
--------------------------------------------------------------------------------
/examples/iterforkio.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
3 |
4 | -- |
5 | -- Simplistic demo of 'Iterator' synchronization, using the 'Base" API
6 | --
7 | module Main where
8 |
9 | import Control.Concurrent
10 | import Control.Concurrent.Async
11 | import Data.Default
12 |
13 | import Database.LevelDB.Base
14 |
15 | import qualified Data.ByteString.Char8 as BS
16 |
17 | main :: IO ()
18 | main = withDB "/tmp/leveltest" def{ createIfMissing = True } $ \ db -> do
19 |
20 | let xs = [1..100] :: [Int]
21 |
22 | write db def (map (\ x -> Put (BS.pack . show $ x) "") xs)
23 |
24 | withIter db def $ \ iter -> do
25 | _ <- iterFirst iter
26 | lck <- newMVar iter
27 | es <- mapConcurrently (getEntry lck) xs
28 | mapM (\ (i,e) -> putStrLn $ "#" ++ show i ++ ": " ++ show e) es
29 |
30 | return ()
31 | where
32 | getEntry lck i = withMVar lck $ \ iter -> do
33 | entry <- iterEntry iter
34 | iterNext iter
35 | return (i, entry)
36 |
--------------------------------------------------------------------------------
/leveldb-haskell.cabal:
--------------------------------------------------------------------------------
1 | name: leveldb-haskell
2 | version: 0.6.5.1
3 | synopsis: Haskell bindings to LevelDB
4 | homepage: http://github.com/kim/leveldb-haskell
5 | bug-reports: http://github.com/kim/leveldb-haskell/issues
6 | license: BSD3
7 | license-file: LICENSE
8 | author: Kim Altintop et.al. (see AUTHORS file)
9 | maintainer: kim.altintop@gmail.com
10 | copyright: Copyright (c) 2012-2014 The leveldb-haskell Authors
11 | category: Database, FFI
12 | stability: Experimental
13 | build-type: Simple
14 | cabal-version: >=1.10
15 | tested-with: GHC == 7.4.2, GHC == 7.6.4, GHC == 7.8.3, GHC == 7.10.1, GHC == 8.0.1
16 | description:
17 | From :
18 | .
19 | LevelDB is a fast key-value storage library written at Google that provides
20 | an ordered mapping from string keys to string values.
21 | .
22 | .
23 | This library provides a Haskell language binding to LeveldDB. It is in very
24 | early stage and has seen very limited testing.
25 | .
26 | Note: as of v1.3, LevelDB can be built as a shared library. Thus, as of
27 | v0.1.0 of this library, LevelDB is no longer bundled and must be installed
28 | on the target system (version 1.7 or greater is required).
29 |
30 | extra-source-files: Readme.md, AUTHORS, CHANGELOG examples/*.hs
31 |
32 | source-repository head
33 | type: git
34 | location: git://github.com/kim/leveldb-haskell.git
35 |
36 | Flag Examples
37 | description: Build examples
38 | default: False
39 | manual: True
40 |
41 | library
42 | exposed-modules: Database.LevelDB
43 | , Database.LevelDB.Base
44 | , Database.LevelDB.C
45 | , Database.LevelDB.Internal
46 | , Database.LevelDB.Iterator
47 | , Database.LevelDB.MonadResource
48 | , Database.LevelDB.Streaming
49 | , Database.LevelDB.Types
50 | , Data.Stream.Monadic
51 |
52 | default-language: Haskell2010
53 |
54 | build-depends: base >= 3 && < 5
55 | , bytestring
56 | , data-default
57 | , exceptions >= 0.6
58 | , filepath
59 | , resourcet > 0.3.2
60 | , transformers
61 |
62 | ghc-options: -Wall -funbox-strict-fields
63 |
64 | hs-source-dirs: src
65 |
66 | if os(mingw32)
67 | extra-libraries: libstdc++-6
68 | extra-libraries: leveldb
69 |
70 | executable leveldb-example-comparator
71 | main-is: comparator.hs
72 |
73 | default-language: Haskell2010
74 |
75 | build-depends: base >= 3 && < 5
76 | , transformers
77 | , data-default
78 | , leveldb-haskell
79 |
80 | ghc-options: -Wall -threaded -rtsopts
81 |
82 | hs-source-dirs: examples
83 |
84 | if flag(Examples)
85 | buildable: True
86 | else
87 | buildable: False
88 |
89 | executable leveldb-example-features
90 | main-is: features.hs
91 |
92 | default-language: Haskell2010
93 |
94 | build-depends: base >= 3 && < 5
95 | , bytestring
96 | , transformers
97 | , resourcet > 0.3.2
98 | , data-default
99 | , leveldb-haskell
100 |
101 | ghc-options: -Wall -threaded -rtsopts
102 |
103 | hs-source-dirs: examples
104 |
105 | if flag(Examples)
106 | buildable: True
107 | else
108 | buildable: False
109 |
110 | executable leveldb-example-filterpolicy
111 | main-is: filterpolicy.hs
112 |
113 | default-language: Haskell2010
114 |
115 | build-depends: base >= 3 && < 5
116 | , transformers
117 | , data-default
118 | , leveldb-haskell
119 |
120 | ghc-options: -Wall -threaded -rtsopts
121 |
122 | hs-source-dirs: examples
123 |
124 | if flag(Examples)
125 | buildable: True
126 | else
127 | buildable: False
128 |
129 | executable leveldb-example-iterforkio
130 | main-is: iterforkio.hs
131 |
132 | default-language: Haskell2010
133 |
134 | build-depends: base >= 3 && < 5
135 | , async
136 | , bytestring
137 | , data-default
138 | , leveldb-haskell
139 |
140 | ghc-options: -Wall -threaded -rtsopts
141 |
142 | hs-source-dirs: examples
143 |
144 | if flag(Examples)
145 | buildable: True
146 | else
147 | buildable: False
148 |
149 | test-suite leveldb-properties
150 | type: exitcode-stdio-1.0
151 | main-is: Main.hs
152 | hs-source-dirs: test
153 |
154 | other-modules: Test.Streaming
155 |
156 | default-language: Haskell2010
157 |
158 | build-depends: base
159 | , bytestring
160 | , data-default
161 | , directory
162 | , exceptions >= 0.6
163 | , mtl
164 | , leveldb-haskell
165 | , QuickCheck >= 2.7
166 | , tasty >= 0.10
167 | , tasty-quickcheck >= 0.8
168 | , temporary
169 | , transformers
170 |
171 | ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N
172 |
--------------------------------------------------------------------------------
/src/Data/Stream/Monadic.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns #-}
2 | {-# LANGUAGE ExistentialQuantification #-}
3 |
4 | -- |
5 | -- Module : Data.Stream.Monadic
6 | -- Copyright : (c) 2014 Kim Altintop
7 | -- License : BSD3
8 | -- Maintainer : kim.altintop@gmail.com
9 | -- Stability : experimental
10 | -- Portability : non-portable
11 | --
12 | -- (Mostly mechanical) adaptation of the
13 | --
14 | -- module from the
15 | -- package to a
16 | -- monadic 'Stream' datatype similar to the one
17 | -- by
18 | -- Michael Snoyman for the
19 | -- package.
20 | --
21 | -- The intention here is to provide a high-level, "Data.List"-like interface to
22 | -- "Database.LevelDB.Iterator"s with predictable space and time complexity (see
23 | -- "Database.LevelDB.Streaming"), and without introducing a dependency eg. on
24 | -- one of the streaming libraries (all relevant datatypes are fully exported,
25 | -- though, so it should be straightforward to write wrappers for your favourite
26 | -- streaming library).
27 | --
28 | -- Fusion and inlining rules and strictness annotations have been put in place
29 | -- faithfully, and may need further profiling. Also, some functions (from
30 | -- "Data.List") have been omitted for various reasons. Missing functions may be
31 | -- added upon .
32 |
33 | module Data.Stream.Monadic
34 | ( Step (..)
35 | , Stream (..)
36 |
37 | -- * Conversion with lists
38 | , toList
39 | , fromList
40 |
41 | -- * Basic functions
42 | , append
43 | , cons
44 | , snoc
45 | , head
46 | , last
47 | , tail
48 | , init
49 | , null
50 | , length -- finitary
51 |
52 | -- * Transformations
53 | , map
54 | , mapM
55 | , mapM_
56 | , reverse
57 | , intersperse
58 | , intercalate
59 |
60 | -- * Folds
61 | , foldl
62 | , foldl'
63 | -- , foldl1
64 | -- , foldl1'
65 | , foldr
66 | -- , foldr1
67 | , foldMap
68 | , foldM
69 | , foldM_
70 |
71 | -- * Special folds
72 | , concat
73 | , concatMap
74 | , and
75 | , or
76 | , any
77 | , all
78 | , sum
79 | , product
80 | --, maximum -- non-empty
81 | --, minimum -- non-empty
82 |
83 | -- * Building streams
84 | -- ** Scans
85 | , scanl
86 | -- , scanl1
87 | -- , scanr
88 | -- , scanr1
89 |
90 | -- Accumulating maps
91 | -- , mapAccumL
92 | -- , mapAccumR
93 |
94 | -- ** Infinite streams
95 | , iterate
96 | , repeat
97 | , replicate
98 | , cycle
99 |
100 | -- ** Unfolding
101 | , unfoldr
102 | , unfoldrM
103 |
104 | -- * Substreams
105 | -- ** Extracting substreams
106 | , take
107 | , drop
108 | , splitAt
109 | , takeWhile
110 | , dropWhile
111 | , span
112 | , break
113 | -- , group
114 | -- , inits
115 | -- , tails
116 |
117 | -- ** Predicates
118 | , isPrefixOf
119 | , isSuffixOf
120 | -- , isInfixOf -- would need 'tails'
121 |
122 | -- * Searching streams
123 | -- ** Searching by equality
124 | , elem
125 | , notElem
126 | , lookup
127 |
128 | -- ** Searching with a predicate
129 | , find
130 | , filter
131 | -- , partition
132 |
133 | -- Indexing streams
134 | -- does not make too much sense
135 | -- , index
136 | -- , findIndex
137 | -- , elemIndex
138 | -- , elemIndices
139 | -- , findIndices
140 |
141 | -- * Zipping and unzipping
142 | , zip
143 | , zip3
144 | , zip4
145 | , zipWith
146 | , zipWith3
147 | , zipWith4
148 | , unzip
149 | , unzip3
150 | , unzip4
151 |
152 | -- * Special streams
153 | -- strings - not applicable
154 | -- , lines
155 | -- , words
156 | -- , unlines
157 | -- , unwords
158 |
159 | -- ** \"Set\" operations
160 | -- , nub
161 | , delete
162 | -- , \\
163 | -- , union
164 | -- , intersect
165 |
166 | -- , sort
167 | , insert
168 |
169 | -- * Generalized functions
170 |
171 | -- User-supplied equality, replacing an Eq context
172 | -- , nubBy
173 | , deleteBy
174 | -- , deleteFirstsBy
175 | -- , unionBy
176 | -- , intersectBy
177 | -- , groupBy
178 |
179 | -- ** User-supplied comparison, replacing an Ord context
180 | -- , sortBy
181 | , insertBy
182 | -- , maximumBy
183 | -- , minimumBy
184 |
185 | -- * The \"generic\" operations
186 | , genericLength
187 | , genericTake
188 | , genericDrop
189 | , genericSplitAt
190 | -- , genericIndex
191 | , genericReplicate
192 |
193 | , enumFromToInt
194 | , enumFromToChar
195 | , enumDeltaInteger
196 | )
197 | where
198 |
199 | import Control.Applicative
200 | import Control.Monad (Monad (..), void, (=<<), (>=>))
201 | import Data.Char (Char, chr, ord)
202 | import Data.Monoid
203 |
204 | import Debug.Trace
205 |
206 | import Prelude (Bool (..), Either (..), Eq (..), Functor (..), Int, Integer,
207 | Integral (..), Maybe (..), Num (..), Ord (..), Ordering (..),
208 | error, flip, not, otherwise, undefined, ($), (&&), (.), (||))
209 |
210 |
211 | data Step a s
212 | = Yield a !s
213 | | Skip !s
214 | | Done
215 |
216 | data Stream m a = forall s. Stream (s -> m (Step a s)) (m s)
217 |
218 | instance Monad m => Functor (Stream m) where
219 | fmap = map
220 |
221 |
222 | toList :: (Functor m, Monad m) => Stream m a -> m [a]
223 | toList (Stream next s0) = unfold =<< s0
224 | where
225 | unfold !s = do
226 | step <- next s
227 | case step of
228 | Done -> return []
229 | Skip s' -> unfold s'
230 | Yield x s' -> (x :) <$> unfold s'
231 | {-# INLINE [0] toList #-}
232 |
233 | fromList :: Monad m => [a] -> Stream m a
234 | fromList xs = Stream next (return xs)
235 | where
236 | {-# INLINE next #-}
237 | next [] = return Done
238 | next (x:xs') = return $ Yield x xs'
239 | {-# INLINE [0] fromList #-}
240 | {-# RULES
241 | "Stream fromList/toList fusion" forall s.
242 | fmap fromList (toList s) = return s
243 | #-}
244 |
245 | append :: (Functor m, Monad m) => Stream m a -> Stream m a -> Stream m a
246 | append (Stream next0 s0) (Stream next1 s1) = Stream next (Left <$> s0)
247 | where
248 | {-# INLINE next #-}
249 | next (Left s) = do
250 | step <- next0 s
251 | case step of
252 | Done -> Skip . Right <$> s1
253 | Skip s' -> return $ Skip (Left s')
254 | Yield x s' -> return $ Yield x (Left s')
255 |
256 | next (Right s) = do
257 | step <- next1 s
258 | return $ case step of
259 | Done -> Done
260 | Skip s' -> Skip (Right s')
261 | Yield x s' -> Yield x (Right s')
262 | {-# INLINE [0] append #-}
263 |
264 | cons :: (Functor m, Monad m) => a -> Stream m a -> Stream m a
265 | cons w (Stream next0 s0) = Stream next ((,) S2 <$> s0)
266 | where
267 | {-# INLINE next #-}
268 | next (S2, s) = return $ Yield w (S1, s)
269 | next (S1, s) = do
270 | step <- next0 s
271 | return $ case step of
272 | Done -> Done
273 | Skip s' -> Skip (S1, s')
274 | Yield x s' -> Yield x (S1, s')
275 | {-# INLINE [0] cons #-}
276 |
277 | snoc :: (Functor m, Monad m) => Stream m a -> a -> Stream m a
278 | snoc (Stream next0 s0) y = Stream next (Just <$> s0)
279 | where
280 | {-# INLINE next #-}
281 | next Nothing = return Done
282 | next (Just s) = do
283 | step <- next0 s
284 | return $ case step of
285 | Done -> Yield y Nothing
286 | Skip s' -> Skip (Just s')
287 | Yield x s' -> Yield x (Just s')
288 | {-# INLINE [0] snoc #-}
289 |
290 | -- | Unlike 'Data.List.head', this function does not diverge if the 'Stream' is
291 | -- empty. Instead, 'Nothing' is returned.
292 | head :: Monad m => Stream m a -> m (Maybe a)
293 | head (Stream next s0) = loop =<< s0
294 | where
295 | loop !s = do
296 | step <- next s
297 | case step of
298 | Yield x _ -> return $ Just x
299 | Skip s' -> loop s'
300 | Done -> return Nothing
301 | {-# INLINE [0] head #-}
302 |
303 | -- | Unlike 'Data.List.last', this function does not diverge if the 'Stream' is
304 | -- empty. Instead, 'Nothing' is returned.
305 | last :: Monad m => Stream m a -> m (Maybe a)
306 | last (Stream next s0) = loop =<< s0
307 | where
308 | loop !s = do
309 | step <- next s
310 | case step of
311 | Done -> return Nothing
312 | Skip s' -> loop s'
313 | Yield x s' -> loop' x s'
314 | loop' x !s = do
315 | step <- next s
316 | case step of
317 | Done -> return $ Just x
318 | Skip s' -> loop' x s'
319 | Yield x' s' -> loop' x' s'
320 | {-# INLINE [0] last #-}
321 |
322 | data Switch = S1 | S2
323 |
324 | -- | Unlike 'Data.List.tail', this function does not diverge if the 'Stream' is
325 | -- empty. Instead, it is the identity in this case.
326 | tail :: (Functor m, Monad m) => Stream m a -> Stream m a
327 | tail (Stream next0 s0) = Stream next ((,) S1 <$> s0)
328 | where
329 | {-# INLINE next #-}
330 | next (S1, s) = do
331 | step <- next0 s
332 | return $ case step of
333 | Done -> Done
334 | Skip s' -> Skip (S1, s')
335 | Yield _ s' -> Skip (S2, s')
336 |
337 | next (S2, s) = do
338 | step <- next0 s
339 | return $ case step of
340 | Done -> Done
341 | Skip s' -> Skip (S2, s')
342 | Yield x s' -> Yield x (S2, s')
343 | {-# INLINE [0] tail #-}
344 |
345 | -- | Unlike 'Data.List.init', this function does not diverge if the 'Stream' is
346 | -- empty. Instead, it is the identity in this case.
347 | init :: (Functor m, Monad m) => Stream m a -> Stream m a
348 | init (Stream next0 s0) = Stream next ((,) Nothing <$> s0)
349 | where
350 | {-# INLINE next #-}
351 | next (Nothing, s) = do
352 | step <- next0 s
353 | return $ case step of
354 | Done -> Done
355 | Skip s' -> Skip (Nothing, s')
356 | Yield x s' -> Skip (Just x , s')
357 |
358 | next (Just x, s) = do
359 | step <- next0 s
360 | return $ case step of
361 | Done -> Done
362 | Skip s' -> Skip (Just x , s')
363 | Yield x' s' -> Yield x (Just x', s')
364 | {-# INLINE [0] init #-}
365 |
366 | null :: Monad m => Stream m a -> m Bool
367 | null (Stream next s0) = loop =<< s0
368 | where
369 | loop !s = do
370 | step <- next s
371 | case step of
372 | Done -> return True
373 | Yield _ _ -> return False
374 | Skip s' -> loop s'
375 | {-# INLINE [0] null #-}
376 |
377 | length :: Monad m => Stream m a -> m Int
378 | length (Stream next s0) = loop 0 =<< s0
379 | where
380 | loop !z !s = do
381 | step <- next s
382 | case step of
383 | Done -> return z
384 | Skip s' -> loop z s'
385 | Yield _ s' -> loop (z+1) s'
386 | {-# INLINE [0] length #-}
387 |
388 | elem :: (Eq a, Monad m) => a -> Stream m a -> m Bool
389 | elem x (Stream next s0) = loop =<< s0
390 | where
391 | loop !s = do
392 | step <- next s
393 | case step of
394 | Done -> return False
395 | Skip s' -> loop s'
396 | Yield y s' | y == x -> return True
397 | | otherwise -> loop s'
398 | {-# INLINE [0] elem #-}
399 |
400 | notElem :: (Eq a, Monad m) => a -> Stream m a -> m Bool
401 | notElem x s = elem x s >>= return . not
402 |
403 | lookup :: (Eq a, Monad m) => a -> Stream m (a, b) -> m (Maybe b)
404 | lookup key (Stream next s0) = loop =<< s0
405 | where
406 | loop !s = do
407 | step <- next s
408 | case step of
409 | Done -> return Nothing
410 | Skip s' -> loop s'
411 | Yield (x, y) s' | key == x -> return $ Just y
412 | | otherwise -> loop s'
413 | {-# INLINE [0] lookup #-}
414 |
415 | find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)
416 | find p = head . filter p
417 | {-# INLINE [0] find #-}
418 |
419 | filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
420 | filter p (Stream next0 s0) = Stream next s0
421 | where
422 | {-# INLINE next #-}
423 | next !s = do
424 | step <- next0 s
425 | return $ case step of
426 | Done -> Done
427 | Skip s' -> Skip s'
428 | Yield x s' | p x -> Yield x s'
429 | | otherwise -> Skip s'
430 | {-# INLINE [0] filter #-}
431 | {-# RULES
432 | "Stream filter/filter fusion" forall p q s.
433 | filter p (filter q s) = filter (\ x -> q x && p x) s
434 | #-}
435 |
436 | map :: Monad m => (a -> b) -> Stream m a -> Stream m b
437 | map f (Stream next0 s0) = Stream next s0
438 | where
439 | {-# INLINE next #-}
440 | next !s = do
441 | step <- next0 s
442 | return $ case step of
443 | Done -> Done
444 | Skip s' -> Skip s'
445 | Yield x s' -> Yield (f x) s'
446 | {-# INLINE [0] map #-}
447 | {-# RULES
448 | "Stream map/map fusion" forall f g s.
449 | map f (map g s) = map (f . g) s
450 | #-}
451 |
452 | mapM :: (Functor m, Monad m) => (a -> m b) -> Stream m a -> Stream m b
453 | mapM f (Stream next0 s0) = Stream next s0
454 | where
455 | {-# INLINE next #-}
456 | next !s = do
457 | step <- next0 s
458 | case step of
459 | Done -> return Done
460 | Skip s' -> return $ Skip s'
461 | Yield x s' -> (`Yield` s') <$> f x
462 | {-# INLINE [0] mapM #-}
463 | {-# RULES
464 | "Stream mapM/mapM fusion" forall f g s.
465 | mapM f (mapM g s) = mapM (g >=> f) s
466 |
467 | "Stream map/mapM fusion" forall f g s.
468 | map f (mapM g s) = mapM (fmap f . g) s
469 |
470 | "Stream mapM/map fusion" forall f g s.
471 | mapM f (map g s) = mapM (f . g) s
472 | #-}
473 |
474 | mapM_ :: (Functor m, Monad m) => (a -> m b) -> Stream m a -> Stream m ()
475 | mapM_ f s = Stream go (return ())
476 | where
477 | {-# INLINE go #-}
478 | go _ = foldM_ (\ _ -> void . f) () s >> return Done
479 | {-# INLINE [0] mapM_ #-}
480 | {-# RULES
481 | "Stream mapM_/mapM fusion" forall f g s.
482 | mapM_ f (mapM g s) = mapM_ (g >=> f) s
483 |
484 | "Stream mapM_/map fusion" forall f g s.
485 | mapM_ f (map g s) = mapM_ (f . g) s
486 | #-}
487 |
488 | reverse :: (Functor m, Monad m) => Stream m a -> m (Stream m a)
489 | reverse = foldl' (flip cons) (fromList [])
490 | {-# INLINE reverse #-}
491 |
492 | intersperse :: (Functor m, Monad m) => a -> Stream m a -> Stream m a
493 | intersperse sep (Stream next0 s0) = Stream next ((,,) Nothing S1 <$> s0)
494 | where
495 | {-# INLINE next #-}
496 | next (Nothing, S1, s) = do
497 | step <- next0 s
498 | return $ case step of
499 | Done -> Done
500 | Skip s' -> Skip (Nothing, S1, s')
501 | Yield x s' -> Skip (Just x , S1, s')
502 |
503 | next (Just x, S1, s) = return $ Yield x (Nothing, S2, s)
504 |
505 | next (Nothing, S2, s) = do
506 | step <- next0 s
507 | return $ case step of
508 | Done -> Done
509 | Skip s' -> Skip (Nothing, S2, s')
510 | Yield x s' -> Yield sep (Just x , S1, s')
511 |
512 | next (Just _, S2, _) = error "Data.Stream.Monadic.intersperse: impossible"
513 | {-# INLINE [0] intersperse #-}
514 |
515 | intercalate :: (Functor m, Monad m) => Stream m a -> Stream m [a] -> Stream m a
516 | intercalate sep s = first s `append` rest s
517 | where
518 | first = concat . take 1
519 | rest = concatMap (append sep . fromList) . drop 1
520 | {-# INLINE intercalate #-}
521 |
522 | --transpose :: Monad m => Stream m [a] -> Stream m [a]
523 |
524 | foldMap :: (Monoid m, Functor n, Monad n) => (a -> m) -> Stream n a -> n m
525 | foldMap f (Stream next s0) = loop mempty =<< s0
526 | where
527 | loop z !s = do
528 | step <- next s
529 | case step of
530 | Done -> return z
531 | Skip s' -> loop z s'
532 | Yield x s' -> loop (z <> f x) s'
533 | {-# INLINE [0] foldMap #-}
534 | {-# RULES
535 | "Stream foldMap/map fusion" forall f g s.
536 | foldMap f (map g s) = foldMap (f . g) s
537 |
538 | "Stream foldMap/mapM fusion" forall f g s.
539 | foldMap f (mapM g s) = foldM (\ z' -> fmap ((z' <>) . f) . g) mempty s
540 | #-}
541 |
542 | foldl :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b
543 | foldl f z0 (Stream next s0) = loop z0 =<< s0
544 | where
545 | loop z !s = do
546 | step <- next s
547 | case step of
548 | Done -> return z
549 | Skip s' -> loop z s'
550 | Yield x s' -> loop (f z x) s'
551 | {-# INLINE [0] foldl #-}
552 | {-# RULES
553 | "Stream foldl/map fusion" forall f g z s.
554 | foldl f z (map g s) = foldl (\ z' -> f z' . g) z s
555 |
556 | "Stream foldl/mapM fusion" forall f g z s.
557 | foldl f z (mapM g s) = foldM (\ z' -> fmap (f z') . g) z s
558 | #-}
559 |
560 | foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b
561 | foldl' f z0 (Stream next s0) = loop z0 =<< s0
562 | where
563 | loop !z !s = do
564 | step <- next s
565 | case step of
566 | Done -> return z
567 | Skip s' -> loop z s'
568 | Yield x s' -> loop (f z x) s'
569 | {-# INLINE [0] foldl' #-}
570 | {-# RULES
571 | "Stream foldl'/map fusion" forall f g z s.
572 | foldl' f z (map g s) = foldl' (\ z' -> f z' . g) z s
573 |
574 | "Stream foldl'/mapM fusion" forall f g z s.
575 | foldl' f z (mapM g s) = foldM (\ z' -> fmap (f z') . g) z s
576 | #-}
577 |
578 | foldr :: (Functor m, Monad m) => (a -> b -> b) -> b -> Stream m a -> m b
579 | foldr f z (Stream next s0) = loop =<< s0
580 | where
581 | loop !s = do
582 | step <- next s
583 | case step of
584 | Done -> return z
585 | Skip s' -> loop s'
586 | Yield x s' -> f x <$> loop s'
587 | {-# INLINE [0] foldr #-}
588 | {-# RULES
589 | "Stream foldr/map fusion" forall f g z s.
590 | foldr f z (map g s) = foldr (f . g) z s
591 |
592 | "Stream foldr/mapM fusion" forall f g z s.
593 | foldr f z (mapM g s) = foldM (\ z' -> fmap (`f` z') . g) z s
594 | #-}
595 |
596 | foldM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m b
597 | foldM f z0 (Stream next s0) = loop z0 =<< s0
598 | where
599 | loop z !s = do
600 | step <- next s
601 | case step of
602 | Done -> return z
603 | Skip s' -> loop z s'
604 | Yield x s' -> f z x >>= (`loop` s')
605 | {-# INLINE [0] foldM #-}
606 | {-# RULES
607 | "Stream foldM/map fusion" forall f g z s.
608 | foldM f z (map g s) = foldM (\ z' -> f z' . g) z s
609 |
610 | "Stream foldM/mapM fusion" forall f g z s.
611 | foldM f z (mapM g s) = foldM (\ z' -> g >=> f z') z s
612 | #-}
613 |
614 | foldM_ :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m ()
615 | foldM_ f z s = foldM f z s >> return ()
616 | {-# INLINE foldM_ #-}
617 |
618 | concat :: (Functor m, Monad m) => Stream m [a] -> Stream m a
619 | concat = concatMap fromList
620 | {-# INLINE concat #-}
621 |
622 | concatMap :: (Functor m, Monad m) => (a -> Stream m b) -> Stream m a -> Stream m b
623 | concatMap f (Stream next0 s0) = Stream next ((,) Nothing <$> s0)
624 | where
625 | {-# INLINE next #-}
626 | next (Nothing, s) = do
627 | step <- next0 s
628 | return $ case step of
629 | Done -> Done
630 | Skip s' -> Skip (Nothing , s')
631 | Yield x s' -> Skip (Just (f x), s')
632 |
633 | next (Just (Stream g t), s) = do
634 | step <- g =<< t
635 | return $ case step of
636 | Done -> Skip (Nothing , s)
637 | Skip t' -> Skip (Just (Stream g (return t')), s)
638 | Yield x t' -> Yield x (Just (Stream g (return t')), s)
639 | {-# INLINE [0] concatMap #-}
640 | {-# RULES
641 | "Stream concatMap/map fusion" forall f g s.
642 | concatMap f (map g s) = concatMap (f . g) s
643 | #-}
644 |
645 | and :: (Functor m, Monad m) => Stream m Bool -> m Bool
646 | and = foldr (&&) True
647 | {-# INLINE and #-}
648 |
649 | or :: (Functor m, Monad m) => Stream m Bool -> m Bool
650 | or = foldr (||) False
651 | {-# INLINE or #-}
652 |
653 | any :: Monad m => (a -> Bool) -> Stream m a -> m Bool
654 | any p (Stream next s0) = loop =<< s0
655 | where
656 | loop !s = do
657 | step <- next s
658 | case step of
659 | Done -> return False
660 | Skip s' -> loop s'
661 | Yield x s' | p x -> return True
662 | | otherwise -> loop s'
663 | {-# INLINE [0] any #-}
664 |
665 | all :: Monad m => (a -> Bool) -> Stream m a -> m Bool
666 | all p (Stream next s0) = loop =<< s0
667 | where
668 | loop !s = do
669 | step <- next s
670 | case step of
671 | Done -> return True
672 | Skip s' -> loop s'
673 | Yield x s' | p x -> loop s'
674 | | otherwise -> return False
675 | {-# INLINE [0] all #-}
676 |
677 | sum :: (Num a, Monad m) => Stream m a -> m a
678 | sum (Stream next s0) = loop 0 =<< s0
679 | where
680 | loop !a !s = do
681 | step <- next s
682 | case step of
683 | Done -> return a
684 | Skip s' -> loop a s'
685 | Yield x s' -> loop (a + x) s'
686 | {-# INLINE [0] sum #-}
687 |
688 | product :: (Num a, Monad m) => Stream m a -> m a
689 | product (Stream next s0) = loop 1 =<< s0
690 | where
691 | loop !a !s = do
692 | step <- next s
693 | case step of
694 | Done -> return a
695 | Skip s' -> loop a s'
696 | Yield x s' -> loop (a * x) s'
697 | {-# INLINE [0] product #-}
698 |
699 | scanl :: (Functor m, Monad m) => (b -> a -> b) -> b -> Stream m a -> Stream m b
700 | scanl f z0 = go . (`snoc` undefined)
701 | where
702 | {-# INLINE go #-}
703 | go (Stream step s0) = Stream (next step) ((,) z0 <$> s0)
704 |
705 | {-# INLINE next #-}
706 | next step (z, s) = do
707 | step' <- step s
708 | return $ case step' of
709 | Done -> Done
710 | Skip s' -> Skip (z , s')
711 | Yield x s' -> Yield z (f z x, s')
712 | {-# INLINE [0] scanl #-}
713 |
714 | iterate :: Monad m => (a -> a) -> a -> Stream m a
715 | iterate f x0 = Stream next (return x0)
716 | where
717 | {-# INLINE next #-}
718 | next x = return $ Yield x (f x)
719 | {-# INLINE [0] iterate #-}
720 |
721 | repeat :: Monad m => a -> Stream m a
722 | repeat x = Stream next (return ())
723 | where
724 | {-# INLINE next #-}
725 | next _ = return $ Yield x ()
726 | {-# INLINE [0] repeat #-}
727 | {-# RULES
728 | "map/repeat" forall f x.
729 | map f (repeat x) = repeat (f x)
730 | #-}
731 |
732 | replicate :: Monad m => Int -> a -> Stream m a
733 | replicate n x = Stream next (return n)
734 | where
735 | {-# INLINE next #-}
736 | next !i | i <= 0 = return Done
737 | | otherwise = return $ Yield x (i-1)
738 | {-# INLINE [0] replicate #-}
739 | {-# RULES
740 | "map/replicate" forall f n x.
741 | map f (replicate n x) = replicate n (f x)
742 | #-}
743 |
744 | -- | Unlike 'Data.List.cycle', this function does not diverge if the 'Stream' is
745 | -- empty. Instead, it is the identity in this case.
746 | cycle :: (Functor m, Monad m) => Stream m a -> Stream m a
747 | cycle (Stream next0 s0) = Stream next ((,) S1 <$> s0)
748 | where
749 | {-# INLINE next #-}
750 | next (S1, s) = do
751 | step <- next0 s
752 | return $ case step of
753 | Done -> Done -- error?
754 | Skip s' -> Skip (S1, s')
755 | Yield x s' -> Yield x (S2, s')
756 |
757 | next (S2, s) = do
758 | step <- next0 s
759 | case step of
760 | Done -> Skip . (,) S2 <$> s0
761 | Skip s' -> return $ Skip (S2, s')
762 | Yield x s' -> return $ Yield x (S2, s')
763 | {-# INLINE [0] cycle #-}
764 |
765 | unfoldr :: Monad m => (b -> Maybe (a, b)) -> b -> Stream m a
766 | unfoldr f s0 = Stream next (return s0)
767 | where
768 | {-# INLINE next #-}
769 | next s = return $ case f s of
770 | Nothing -> Done
771 | Just (w, s') -> Yield w s'
772 | {-# INLINE [0] unfoldr #-}
773 |
774 | -- | Build a stream from a monadic seed (or state function).
775 | unfoldrM :: (Functor m, Monad m) => (b -> Maybe (a, m b)) -> m b -> Stream m a
776 | unfoldrM f = Stream next
777 | where
778 | {-# INLINE next #-}
779 | next s = case f s of
780 | Nothing -> return Done
781 | Just (w, s') -> Yield w <$> s'
782 | {-# INLINE [0] unfoldrM #-}
783 |
784 | isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
785 | isPrefixOf (Stream nexta sa0) (Stream nextb sb0) = do
786 | sa0' <- sa0
787 | sb0' <- sb0
788 | loop sa0' sb0' Nothing
789 | where
790 | loop !sa !sb Nothing = do
791 | stepa <- nexta sa
792 | case stepa of
793 | Done -> return True
794 | Skip sa' -> loop sa' sb Nothing
795 | Yield x sa' -> loop sa' sb (Just x)
796 |
797 | loop !sa !sb (Just x) = do
798 | stepb <- nextb sb
799 | case stepb of
800 | Done -> return False
801 | Skip sb' -> loop sa sb' (Just x)
802 | Yield y sb' | x == y -> loop sa sb' Nothing
803 | | otherwise -> return False
804 | {-# INLINE [0] isPrefixOf #-}
805 |
806 | -- | Note that this is:
807 | --
808 | -- > isSuffixOf a b = reverse a `isPrefixOf` reverse b
809 | --
810 | -- It might be more efficient to construct the 'Stream's in reverse order and
811 | -- use 'isPrefixOf' directly, as 'reverse' is /O(n)/ and requires a finite
812 | -- stream argument.
813 | isSuffixOf :: (Eq a, Functor m, Monad m) => Stream m a -> Stream m a -> m Bool
814 | isSuffixOf sa sb = do
815 | ra <- reverse sa
816 | rb <- reverse sb
817 | ra `isPrefixOf` rb
818 |
819 | take :: (Functor m, Monad m) => Int -> Stream m a -> Stream m a
820 | take n0 (Stream next0 s0) = Stream next ((,) n0 <$> s0)
821 | where
822 | {-# INLINE next #-}
823 | next (!n, s)
824 | | n <= 0 = return Done
825 | | otherwise = do
826 | step <- next0 s
827 | return $ case step of
828 | Done -> Done
829 | Skip s' -> Skip (n , s')
830 | Yield x s' -> Yield x (n-1, s')
831 | {-# INLINE [0] take #-}
832 |
833 | drop :: (Functor m, Monad m) => Int -> Stream m a -> Stream m a
834 | drop n0 (Stream next0 s0) = Stream next ((,) (Just (max 0 n0)) <$> s0)
835 | where
836 | {-# INLINE next #-}
837 | next (Just !n, s)
838 | | n == 0 = return $ Skip (Nothing, s)
839 | | otherwise = do
840 | step <- next0 s
841 | return $ case step of
842 | Done -> Done
843 | Skip s' -> Skip (Just n , s')
844 | Yield _ s' -> Skip (Just (n-1), s')
845 | next (Nothing, s) = do
846 | step <- next0 s
847 | return $ case step of
848 | Done -> Done
849 | Skip s' -> Skip (Nothing, s')
850 | Yield x s' -> Yield x (Nothing, s')
851 | {-# INLINE [0] drop #-}
852 |
853 | -- |
854 | --
855 | -- > splitAt n s = (take n s, drop n s)
856 | --
857 | -- Note that the resulting 'Streams' share their state, so do not interleave
858 | -- traversals.
859 | splitAt :: (Functor m, Monad m) => Int -> Stream m a -> (Stream m a, Stream m a)
860 | -- not the most efficient solution, but allows the stream argument to be
861 | -- infinite
862 | splitAt n s = (take n s, drop n s)
863 | {-# INLINE splitAt #-}
864 |
865 | takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
866 | takeWhile p (Stream next0 s0) = Stream next s0
867 | where
868 | {-# INLINE next #-}
869 | next !s = do
870 | step <- next0 s
871 | return $ case step of
872 | Done -> Done
873 | Skip s' -> Skip s'
874 | Yield x s' | p x -> Yield x s'
875 | | otherwise -> Done
876 | {-# INLINE [0] takeWhile #-}
877 |
878 | dropWhile :: (Functor m, Monad m) => (a -> Bool) -> Stream m a -> Stream m a
879 | dropWhile p (Stream next0 s0) = Stream next ((,) S1 <$> s0)
880 | where
881 | {-# INLINE next #-}
882 | next (S1, s) = do
883 | step <- next0 s
884 | return $ case step of
885 | Done -> Done
886 | Skip s' -> Skip (S1, s')
887 | Yield x s' | p x -> Skip (S1, s')
888 | | otherwise -> Yield x (S2, s')
889 | next (S2, s) = do
890 | step <- next0 s
891 | return $ case step of
892 | Done -> Done
893 | Skip s' -> Skip (S2, s')
894 | Yield x s' -> Yield x (S2, s')
895 | {-# INLINE [0] dropWhile #-}
896 |
897 | span :: (Functor m, Monad m) => (a -> Bool) -> Stream m a -> (Stream m a, Stream m a)
898 | span p s = (takeWhile p s, dropWhile p s)
899 | {-# INLINE span #-}
900 |
901 | break :: (Functor m, Monad m) => (a -> Bool) -> Stream m a -> (Stream m a, Stream m a)
902 | break p = span (not . p)
903 | {-# INLINE break #-}
904 |
905 | zip :: (Functor m, Applicative m, Monad m)
906 | => Stream m a
907 | -> Stream m b
908 | -> Stream m (a, b)
909 | zip = zipWith (,)
910 | {-# INLINE zip #-}
911 |
912 | zip3 :: (Functor m, Applicative m, Monad m)
913 | => Stream m a
914 | -> Stream m b
915 | -> Stream m c
916 | -> Stream m (a, b, c)
917 | zip3 = zipWith3 (,,)
918 | {-# INLINE zip3 #-}
919 |
920 | zip4 :: (Functor m, Applicative m, Monad m)
921 | => Stream m a
922 | -> Stream m b
923 | -> Stream m c
924 | -> Stream m d
925 | -> Stream m (a, b, c, d)
926 | zip4 = zipWith4 (,,,)
927 | {-# INLINE zip4 #-}
928 |
929 | zipWith :: (Functor m, Applicative m, Monad m)
930 | => (a -> b -> c)
931 | -> Stream m a
932 | -> Stream m b
933 | -> Stream m c
934 | zipWith f (Stream nexta sa0) (Stream nextb sb0) =
935 | Stream next ((,,) Nothing <$> sa0 <*> sb0)
936 | where
937 | {-# INLINE next #-}
938 | next (Nothing, sa, sb) = do
939 | step <- nexta sa
940 | return $ case step of
941 | Done -> Done
942 | Skip sa' -> Skip (Nothing, sa', sb)
943 | Yield a sa' -> Skip (Just a , sa', sb)
944 |
945 | next (Just a, sa', sb) = do
946 | step <- nextb sb
947 | return $ case step of
948 | Done -> Done
949 | Skip sb' -> Skip (Just a, sa', sb')
950 | Yield b sb' -> Yield (f a b) (Nothing, sa', sb')
951 | {-# INLINE [0] zipWith #-}
952 |
953 | zipWith3 :: (Functor m, Applicative m , Monad m)
954 | => (a -> b -> c -> d)
955 | -> Stream m a
956 | -> Stream m b
957 | -> Stream m c
958 | -> Stream m d
959 | zipWith3 f (Stream nexta sa0)
960 | (Stream nextb sb0)
961 | (Stream nextc sc0)
962 | = Stream next ((,,,) Nothing <$> sa0 <*> sb0 <*> sc0)
963 | where
964 | {-# INLINE next #-}
965 | next (Nothing, sa, sb, sc) = do
966 | step <- nexta sa
967 | return $ case step of
968 | Done -> Done
969 | Skip sa' -> Skip (Nothing , sa', sb, sc)
970 | Yield a sa' -> Skip (Just (a, Nothing), sa', sb, sc)
971 |
972 | next (Just (a, Nothing), sa', sb, sc) = do
973 | step <- nextb sb
974 | return $ case step of
975 | Done -> Done
976 | Skip sb' -> Skip (Just (a, Nothing), sa', sb', sc)
977 | Yield b sb' -> Skip (Just (a, Just b ), sa', sb', sc)
978 |
979 | next (Just (a, Just b), sa', sb', sc) = do
980 | step <- nextc sc
981 | return $ case step of
982 | Done -> Done
983 | Skip sc' -> Skip (Just (a, Just b), sa', sb', sc')
984 | Yield c sc' -> Yield (f a b c) (Nothing , sa', sb', sc')
985 | {-# INLINE [0] zipWith3 #-}
986 |
987 | zipWith4 :: (Functor m, Applicative m , Monad m)
988 | => (a -> b -> c -> d -> e)
989 | -> Stream m a
990 | -> Stream m b
991 | -> Stream m c
992 | -> Stream m d
993 | -> Stream m e
994 | zipWith4 f (Stream nexta sa0)
995 | (Stream nextb sb0)
996 | (Stream nextc sc0)
997 | (Stream nextd sd0)
998 | = Stream next ((,,,,) Nothing <$> sa0 <*> sb0 <*> sc0 <*> sd0)
999 | where
1000 | {-# INLINE next #-}
1001 | next (Nothing, sa, sb, sc, sd) = do
1002 | step <- nexta sa
1003 | return $ case step of
1004 | Done -> Done
1005 | Skip sa' -> Skip (Nothing , sa', sb, sc, sd)
1006 | Yield a sa' -> Skip (Just (a, Nothing), sa', sb, sc, sd)
1007 |
1008 | next (Just (a, Nothing), sa', sb, sc, sd) = do
1009 | step <- nextb sb
1010 | return $ case step of
1011 | Done -> Done
1012 | Skip sb' -> Skip (Just (a, Nothing) , sa', sb', sc, sd)
1013 | Yield b sb' -> Skip (Just (a, Just (b, Nothing)), sa', sb', sc, sd)
1014 |
1015 | next (Just (a, Just (b, Nothing)), sa', sb', sc, sd) = do
1016 | step <- nextc sc
1017 | return $ case step of
1018 | Done -> Done
1019 | Skip sc' -> Skip (Just (a, Just (b, Nothing)), sa', sb', sc', sd)
1020 | Yield c sc' -> Skip (Just (a, Just (b, Just c)) , sa', sb', sc', sd)
1021 |
1022 | next (Just (a, Just (b, Just c)), sa', sb', sc', sd) = do
1023 | step <- nextd sd
1024 | return $ case step of
1025 | Done -> Done
1026 | Skip sd' -> Skip (Just (a, Just (b, Just c)), sa', sb', sc', sd')
1027 | Yield d sd' -> Yield (f a b c d) (Nothing , sa', sb', sc', sd')
1028 | {-# INLINE [0] zipWith4 #-}
1029 |
1030 | unzip :: (Functor m, Monad m) => Stream m (a, b) -> m ([a], [b])
1031 | unzip = foldr (\ (a,b) ~(as,bs) -> (a:as, b:bs)) ([],[])
1032 | {-# INLINE unzip #-}
1033 |
1034 | unzip3 :: (Functor m, Monad m) => Stream m (a, b, c) -> m ([a], [b], [c])
1035 | unzip3 = foldr (\ (a,b,c) ~(as,bs,cs) -> (a:as, b:bs, c:cs)) ([],[],[])
1036 | {-# INLINE unzip3 #-}
1037 |
1038 | unzip4 :: (Functor m, Monad m) => Stream m (a, b, c, d) -> m ([a], [b], [c], [d])
1039 | unzip4 = foldr (\ (a,b,c,d) ~(as,bs,cs,ds) -> (a:as, b:bs, c:cs, d:ds)) ([],[],[],[])
1040 | {-# INLINE unzip4 #-}
1041 |
1042 | delete :: (Eq a, Functor m, Monad m) => a -> Stream m a -> Stream m a
1043 | delete = deleteBy (==)
1044 | {-# INLINE delete #-}
1045 |
1046 | insert :: (Ord a, Functor m, Monad m) => a -> Stream m a -> Stream m a
1047 | insert = insertBy compare
1048 | {-# INLINE insert #-}
1049 |
1050 | deleteBy :: (Functor m, Monad m)
1051 | => (a -> a -> Bool)
1052 | -> a
1053 | -> Stream m a
1054 | -> Stream m a
1055 | deleteBy eq a (Stream next0 s0) = Stream next ((,) S1 <$> s0)
1056 | where
1057 | {-# INLINE next #-}
1058 | next (S1, s) = do
1059 | step <- next0 s
1060 | return $ case step of
1061 | Done -> Done
1062 | Skip s' -> Skip (S1, s')
1063 | Yield x s' | a `eq` x -> Skip (S2, s')
1064 | | otherwise -> Yield x (S1, s')
1065 |
1066 | next (S2, s) = do
1067 | step <- next0 s
1068 | return $ case step of
1069 | Done -> Done
1070 | Skip s' -> Skip (S2, s')
1071 | Yield x s' -> Yield x (S2, s')
1072 | {-# INLINE [0] deleteBy #-}
1073 |
1074 | insertBy :: (Functor m, Monad m)
1075 | => (a -> a -> Ordering)
1076 | -> a
1077 | -> Stream m a
1078 | -> Stream m a
1079 | insertBy cmp x (Stream next0 s0) = Stream next ((,,) S2 Nothing <$> s0)
1080 | where
1081 | {-# INLINE next #-}
1082 | next (S2, Nothing, s) = do
1083 | step <- next0 s
1084 | return $ case step of
1085 | Done -> Yield x (S1, Nothing, s ) -- a snoc
1086 | Skip s' -> Skip (S2, Nothing, s')
1087 | Yield y s' | GT == cmp x y -> Yield y (S2, Nothing, s')
1088 | | otherwise -> Yield x (S1, Just y , s ) -- insert
1089 |
1090 | next (S2, Just _, _) = error "Data.Stream.Monadic.insertBy: impossible"
1091 |
1092 | next (S1, Just y, s) = return $ Yield y (S1, Nothing, s)
1093 |
1094 | next (S1, Nothing, s) = do
1095 | step <- next0 s
1096 | return $ case step of
1097 | Done -> Done
1098 | Skip s' -> Skip (S1, Nothing, s')
1099 | Yield y s' -> Yield y (S1, Nothing, s')
1100 | {-# INLINE [0] insertBy #-}
1101 |
1102 | -- not sure why this is defined recursively (unlike 'length')
1103 | genericLength :: (Num i, Functor m, Monad m) => Stream m a -> m i
1104 | genericLength (Stream next s0) = loop =<< s0
1105 | where
1106 | loop !s = do
1107 | step <- next s
1108 | case step of
1109 | Done -> return 0
1110 | Skip s' -> loop s'
1111 | Yield _ s' -> (1 +) <$> loop s'
1112 | {-# INLINE [0] genericLength #-}
1113 |
1114 | genericTake :: (Integral i, Functor m, Monad m) => i -> Stream m a -> Stream m a
1115 | genericTake n0 (Stream next0 s0) = Stream next ((,) n0 <$> s0)
1116 | where
1117 | {-# INLINE next #-}
1118 | next (0, _) = return Done
1119 | next (n, s) = do
1120 | step <- next0 s
1121 | return $ case step of
1122 | Done -> Done
1123 | Skip s' -> Skip (n , s')
1124 | Yield x s'
1125 | | n > 0 -> Yield x (n-1, s')
1126 | | otherwise -> error "List.genericTake: negative argument"
1127 | {-# INLINE [0] genericTake #-}
1128 |
1129 | genericDrop :: (Integral i, Functor m, Monad m) => i -> Stream m a -> Stream m a
1130 | genericDrop n0 (Stream next0 s0) = Stream next ((,) (Just n0) <$> s0)
1131 | where
1132 | {-# INLINE next #-}
1133 | next (Just 0, s) = return $ Skip (Nothing, s)
1134 | next (Just n, s) = do
1135 | step <- next0 s
1136 | return $ case step of
1137 | Done -> Done
1138 | Skip s' -> Skip (Just n , s')
1139 | Yield _ s' | n > 0 -> Skip (Just (n-1), s')
1140 | | otherwise -> error "List.genericDrop: negative argument"
1141 |
1142 | next (Nothing, s) = do
1143 | step <- next0 s
1144 | return $ case step of
1145 | Done -> Done
1146 | Skip s' -> Skip (Nothing, s')
1147 | Yield x s' -> Yield x (Nothing, s')
1148 | {-# INLINE [0] genericDrop #-}
1149 |
1150 | genericSplitAt :: (Integral i, Functor m, Monad m)
1151 | => i
1152 | -> Stream m a
1153 | -> (Stream m a, Stream m a)
1154 | genericSplitAt i s = (genericTake i s, genericDrop i s)
1155 | {-# INLINE genericSplitAt #-}
1156 |
1157 | genericReplicate :: (Integral i, Functor m, Monad m) => i -> a -> Stream m a
1158 | genericReplicate n = genericTake n . repeat
1159 | {-# INLINE [0] genericReplicate #-}
1160 | {-# RULES
1161 | "genericReplicate -> replicate/Int"
1162 | genericReplicate = replicate :: Monad m => Int -> a -> Stream m a
1163 | #-}
1164 |
1165 | -- TODO: is it possible to define rules which would rewrite @fromList [n..m]@ to
1166 | -- one of the below?
1167 |
1168 | -- | Like @fromList ([n..m] :: [Int])@ but avoids allocating a list
1169 | enumFromToInt :: Monad m => Int -> Int -> Stream m Int
1170 | enumFromToInt x y = trace "enumFromToInt" $ Stream next (return x)
1171 | where
1172 | {-# INLINE next #-}
1173 | next !n
1174 | | n > y = return Done
1175 | | otherwise = return $ Yield n (n+1)
1176 | {-# INLINE [0] enumFromToInt #-}
1177 |
1178 | -- | Like @fromList ([n,n+d..] :: [Integer])@ but avoids allocating a list
1179 | enumDeltaInteger :: Monad m => Integer -> Integer -> Stream m Integer
1180 | enumDeltaInteger a d = trace "enumDeltaInteger" $ Stream next (return a)
1181 | where
1182 | {-# INLINE next #-}
1183 | next !x = return $ Yield x (x+d)
1184 | {-# INLINE [0] enumDeltaInteger #-}
1185 |
1186 | -- | Like @fromList ([n..m] :: [Char])@ but avoids allocating a list
1187 | enumFromToChar :: Monad m => Char -> Char -> Stream m Char
1188 | enumFromToChar x y = Stream next (return (ord x))
1189 | where
1190 | m = ord y
1191 |
1192 | {-# INLINE next #-}
1193 | next !n
1194 | | n > m = return Done
1195 | | otherwise = return $ Yield (chr n) (n+1)
1196 | {-# INLINE [0] enumFromToChar #-}
1197 |
--------------------------------------------------------------------------------
/src/Database/LevelDB.hs:
--------------------------------------------------------------------------------
1 | -- |
2 | -- Module : Database.LevelDB
3 | -- Copyright : (c) 2012-2013 The leveldb-haskell Authors
4 | -- License : BSD3
5 | -- Maintainer : kim.altintop@gmail.com
6 | -- Stability : experimental
7 | -- Portability : non-portable
8 | --
9 | -- LevelDB Haskell binding.
10 | --
11 | -- The API closely follows the C-API of LevelDB.
12 | -- For more information, see:
13 |
14 | module Database.LevelDB (module Database.LevelDB.MonadResource) where
15 |
16 | import Database.LevelDB.MonadResource
17 |
--------------------------------------------------------------------------------
/src/Database/LevelDB/Base.hs:
--------------------------------------------------------------------------------
1 | -- |
2 | -- Module : Database.LevelDB.Base
3 | -- Copyright : (c) 2012-2013 The leveldb-haskell Authors
4 | -- License : BSD3
5 | -- Maintainer : kim.altintop@gmail.com
6 | -- Stability : experimental
7 | -- Portability : non-portable
8 | --
9 | -- LevelDB Haskell binding.
10 | --
11 | -- The API closely follows the C-API of LevelDB.
12 | -- For more information, see:
13 |
14 | module Database.LevelDB.Base
15 | ( -- * Exported Types
16 | DB
17 | , BatchOp (..)
18 | , Comparator (..)
19 | , Compression (..)
20 | , Options (..)
21 | , ReadOptions (..)
22 | , Snapshot
23 | , WriteBatch
24 | , WriteOptions (..)
25 | , Range
26 |
27 | -- * Defaults
28 | , defaultOptions
29 | , defaultReadOptions
30 | , defaultWriteOptions
31 |
32 | -- * Basic Database Manipulations
33 | , withDB
34 | , open
35 | , put
36 | , delete
37 | , write
38 | , get
39 | , withSnapshot
40 | , createSnapshot
41 | , releaseSnapshot
42 |
43 | -- * Filter Policy / Bloom Filter
44 | , FilterPolicy (..)
45 | , BloomFilter
46 | , createBloomFilter
47 | , releaseBloomFilter
48 |
49 | -- * Administrative Functions
50 | , Property (..), getProperty
51 | , destroy
52 | , repair
53 | , approximateSize
54 | , compactRange
55 | , version
56 |
57 | -- * Iteration
58 | , module Database.LevelDB.Iterator
59 | )
60 | where
61 |
62 | import Control.Applicative ((<$>))
63 | import Control.Monad (liftM, void)
64 | import Control.Monad.Catch
65 | import Control.Monad.IO.Class (MonadIO (liftIO))
66 | import Data.ByteString (ByteString)
67 | import Data.ByteString.Internal (ByteString (..))
68 | import Data.IORef
69 | import Foreign hiding (free, void)
70 | import Foreign.C.String (withCString)
71 |
72 | import Database.LevelDB.C
73 | import Database.LevelDB.Internal
74 | import Database.LevelDB.Iterator
75 | import Database.LevelDB.Types
76 |
77 | import qualified Data.ByteString as BS
78 | import qualified Data.ByteString.Unsafe as BU
79 |
80 |
81 | -- | Open a database.
82 | --
83 | -- The returned handle has a finalizer attached which will free the underlying
84 | -- pointers once it goes out of scope. Note, however, that finalizers are /not/
85 | -- guaranteed to run, and may not run promptly if they do. Use 'unsafeClose' to
86 | -- free the handle immediately, but ensure it is not used after that (otherwise,
87 | -- the program will segault). Alternatively, use the
88 | -- "Database.LevelDB.MonadResource" API, which will take care of resource
89 | -- management automatically.
90 | open :: MonadIO m => FilePath -> Options -> m DB
91 | open path opts = liftIO $ bracketOnError (mkOpts opts) freeOpts mkDB
92 | where
93 | mkDB opts'@(Options' opts_ptr _ _ _) =
94 | withCString path $ \path_ptr -> do
95 | db_ptr <- throwIfErr "open" $ c_leveldb_open opts_ptr path_ptr
96 | alive <- newIORef True
97 | let db = DB db_ptr opts' alive
98 | addFinalizer alive $ unsafeClose db
99 | return db
100 |
101 | addFinalizer ref = void . mkWeakIORef ref
102 |
103 | -- | Run an action with a 'DB'.
104 | --
105 | -- > withDB path opts = bracket (open path opts) unsafeClose
106 | --
107 | -- Note that the 'DB' handle will be released promptly when this function exits.
108 | withDB :: (MonadMask m, MonadIO m) => FilePath -> Options -> (DB -> m a) -> m a
109 | withDB path opts = bracket (open path opts) (liftIO . unsafeClose)
110 |
111 | -- | Run an action with a 'Snapshot' of the database.
112 | withSnapshot :: (MonadMask m, MonadIO m) => DB -> (Snapshot -> m a) -> m a
113 | withSnapshot db = bracket (createSnapshot db) (releaseSnapshot db)
114 |
115 | -- | Create a snapshot of the database.
116 | --
117 | -- The returned 'Snapshot' should be released with 'releaseSnapshot'.
118 | createSnapshot :: MonadIO m => DB -> m Snapshot
119 | createSnapshot (DB db_ptr _ _) = liftIO $
120 | Snapshot <$> c_leveldb_create_snapshot db_ptr
121 |
122 | -- | Release a snapshot.
123 | --
124 | -- The handle will be invalid after calling this action and should no
125 | -- longer be used.
126 | releaseSnapshot :: MonadIO m => DB -> Snapshot -> m ()
127 | releaseSnapshot (DB db_ptr _ _) (Snapshot snap) = liftIO $
128 | c_leveldb_release_snapshot db_ptr snap
129 |
130 | -- | Get a DB property.
131 | getProperty :: MonadIO m => DB -> Property -> m (Maybe ByteString)
132 | getProperty (DB db_ptr _ _) p = liftIO $
133 | withCString (prop p) $ \prop_ptr -> do
134 | val_ptr <- c_leveldb_property_value db_ptr prop_ptr
135 | if val_ptr == nullPtr
136 | then return Nothing
137 | else do res <- Just <$> BS.packCString val_ptr
138 | c_leveldb_free val_ptr
139 | return res
140 | where
141 | prop (NumFilesAtLevel i) = "leveldb.num-files-at-level" ++ show i
142 | prop Stats = "leveldb.stats"
143 | prop SSTables = "leveldb.sstables"
144 |
145 | -- | Destroy the given LevelDB database.
146 | --
147 | -- The database must not be in use during this operation.
148 | destroy :: MonadIO m => FilePath -> Options -> m ()
149 | destroy path opts = liftIO $ bracket (mkOpts opts) freeOpts destroy'
150 | where
151 | destroy' (Options' opts_ptr _ _ _) =
152 | withCString path $ \path_ptr ->
153 | throwIfErr "destroy" $ c_leveldb_destroy_db opts_ptr path_ptr
154 |
155 | -- | Repair the given LevelDB database.
156 | repair :: MonadIO m => FilePath -> Options -> m ()
157 | repair path opts = liftIO $ bracket (mkOpts opts) freeOpts repair'
158 | where
159 | repair' (Options' opts_ptr _ _ _) =
160 | withCString path $ \path_ptr ->
161 | throwIfErr "repair" $ c_leveldb_repair_db opts_ptr path_ptr
162 |
163 |
164 | -- TODO: support [Range], like C API does
165 | type Range = (ByteString, ByteString)
166 |
167 | -- | Inspect the approximate sizes of the different levels.
168 | approximateSize :: MonadIO m => DB -> Range -> m Int64
169 | approximateSize (DB db_ptr _ _) (from, to) = liftIO $
170 | BU.unsafeUseAsCStringLen from $ \(from_ptr, flen) ->
171 | BU.unsafeUseAsCStringLen to $ \(to_ptr, tlen) ->
172 | withArray [from_ptr] $ \from_ptrs ->
173 | withArray [intToCSize flen] $ \flen_ptrs ->
174 | withArray [to_ptr] $ \to_ptrs ->
175 | withArray [intToCSize tlen] $ \tlen_ptrs ->
176 | allocaArray 1 $ \size_ptrs -> do
177 | c_leveldb_approximate_sizes db_ptr 1
178 | from_ptrs flen_ptrs
179 | to_ptrs tlen_ptrs
180 | size_ptrs
181 | liftM head $ peekArray 1 size_ptrs >>= mapM toInt64
182 |
183 | where
184 | toInt64 = return . fromIntegral
185 |
186 | -- | Compact the underlying storage for the given Range.
187 | -- In particular this means discarding deleted and overwritten data as well as
188 | -- rearranging the data to reduce the cost of operations accessing the data.
189 | compactRange :: MonadIO m => DB -> Range -> m ()
190 | compactRange (DB db_ptr _ _) (from, to) = liftIO $
191 | BU.unsafeUseAsCStringLen from $ \(from_ptr, flen) ->
192 | BU.unsafeUseAsCStringLen to $ \(to_ptr, tlen) ->
193 | c_leveldb_compact_range db_ptr from_ptr (intToCSize flen) to_ptr (intToCSize tlen)
194 |
195 | -- | Write a key/value pair.
196 | put :: MonadIO m => DB -> WriteOptions -> ByteString -> ByteString -> m ()
197 | put (DB db_ptr _ _) opts key value = liftIO $ withCWriteOpts opts $ \opts_ptr ->
198 | BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
199 | BU.unsafeUseAsCStringLen value $ \(val_ptr, vlen) ->
200 | throwIfErr "put"
201 | $ c_leveldb_put db_ptr opts_ptr
202 | key_ptr (intToCSize klen)
203 | val_ptr (intToCSize vlen)
204 |
205 | -- | Read a value by key.
206 | get :: MonadIO m => DB -> ReadOptions -> ByteString -> m (Maybe ByteString)
207 | get (DB db_ptr _ _) opts key = liftIO $ withCReadOpts opts $ \opts_ptr ->
208 | BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
209 | alloca $ \vlen_ptr -> do
210 | val_ptr <- throwIfErr "get" $
211 | c_leveldb_get db_ptr opts_ptr key_ptr (intToCSize klen) vlen_ptr
212 | vlen <- peek vlen_ptr
213 | if val_ptr == nullPtr
214 | then return Nothing
215 | else do
216 | res' <- Just <$> BS.packCStringLen (val_ptr, cSizeToInt vlen)
217 | c_leveldb_free val_ptr
218 | return res'
219 |
220 | -- | Delete a key/value pair.
221 | delete :: MonadIO m => DB -> WriteOptions -> ByteString -> m ()
222 | delete (DB db_ptr _ _) opts key = liftIO $ withCWriteOpts opts $ \opts_ptr ->
223 | BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
224 | throwIfErr "delete"
225 | $ c_leveldb_delete db_ptr opts_ptr key_ptr (intToCSize klen)
226 |
227 | -- | Perform a batch mutation.
228 | write :: MonadIO m => DB -> WriteOptions -> WriteBatch -> m ()
229 | write (DB db_ptr _ _) opts batch = liftIO $ withCWriteOpts opts $ \opts_ptr ->
230 | bracket c_leveldb_writebatch_create c_leveldb_writebatch_destroy $ \batch_ptr -> do
231 |
232 | mapM_ (batchAdd batch_ptr) batch
233 |
234 | throwIfErr "write" $ c_leveldb_write db_ptr opts_ptr batch_ptr
235 |
236 | -- ensure @ByteString@s (and respective shared @CStringLen@s) aren't GC'ed
237 | -- until here
238 | mapM_ (liftIO . touch) batch
239 |
240 | where
241 | batchAdd batch_ptr (Put key val) =
242 | BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
243 | BU.unsafeUseAsCStringLen val $ \(val_ptr, vlen) ->
244 | c_leveldb_writebatch_put batch_ptr
245 | key_ptr (intToCSize klen)
246 | val_ptr (intToCSize vlen)
247 |
248 | batchAdd batch_ptr (Del key) =
249 | BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
250 | c_leveldb_writebatch_delete batch_ptr key_ptr (intToCSize klen)
251 |
252 | touch (Put (PS p _ _) (PS p' _ _)) = do
253 | touchForeignPtr p
254 | touchForeignPtr p'
255 |
256 | touch (Del (PS p _ _)) = touchForeignPtr p
257 |
258 | -- | Return the runtime version of the underlying LevelDB library as a (major,
259 | -- minor) pair.
260 | version :: MonadIO m => m (Int, Int)
261 | version = do
262 | major <- liftIO c_leveldb_major_version
263 | minor <- liftIO c_leveldb_minor_version
264 |
265 | return (cIntToInt major, cIntToInt minor)
266 |
267 | createBloomFilter :: MonadIO m => Int -> m BloomFilter
268 | createBloomFilter i = do
269 | let i' = fromInteger . toInteger $ i
270 | fp_ptr <- liftIO $ c_leveldb_filterpolicy_create_bloom i'
271 | return $ BloomFilter fp_ptr
272 |
273 | releaseBloomFilter :: MonadIO m => BloomFilter -> m ()
274 | releaseBloomFilter (BloomFilter fp) = liftIO $ c_leveldb_filterpolicy_destroy fp
275 |
--------------------------------------------------------------------------------
/src/Database/LevelDB/C.hsc:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP #-}
2 | {-# LANGUAGE EmptyDataDecls #-}
3 | {-# LANGUAGE ForeignFunctionInterface #-}
4 |
5 | -- |
6 | -- Module : Database.LevelDB.C
7 | -- Copyright : (c) 2012-2014 The leveldb-haskell Authors
8 | -- License : BSD3
9 | -- Maintainer : kim.altintop@gmail.com
10 | -- Stability : experimental
11 | -- Portability : non-portable
12 | --
13 |
14 | module Database.LevelDB.C where
15 |
16 | import Foreign
17 | import Foreign.C.String
18 | import Foreign.C.Types
19 |
20 | #include
21 |
22 | data LevelDB
23 | data LCache
24 | data LComparator
25 | data LIterator
26 | data LLogger
27 | data LOptions
28 | data LReadOptions
29 | data LSnapshot
30 | data LWriteBatch
31 | data LWriteOptions
32 | data LFilterPolicy
33 |
34 | type LevelDBPtr = Ptr LevelDB
35 | type CachePtr = Ptr LCache
36 | type ComparatorPtr = Ptr LComparator
37 | type IteratorPtr = Ptr LIterator
38 | type LoggerPtr = Ptr LLogger
39 | type OptionsPtr = Ptr LOptions
40 | type ReadOptionsPtr = Ptr LReadOptions
41 | type SnapshotPtr = Ptr LSnapshot
42 | type WriteBatchPtr = Ptr LWriteBatch
43 | type WriteOptionsPtr = Ptr LWriteOptions
44 | type FilterPolicyPtr = Ptr LFilterPolicy
45 |
46 | type DBName = CString
47 | type ErrPtr = Ptr CString
48 | type Key = CString
49 | type Val = CString
50 |
51 | newtype CompressionOpt = CompressionOpt { compressionOpt :: CInt }
52 | deriving (Eq, Show)
53 | #{enum CompressionOpt, CompressionOpt
54 | , noCompression = 0
55 | , snappyCompression = 1
56 | }
57 |
58 |
59 | -- N.B. unsafe calls are used where there is no chance of blocking.
60 |
61 | foreign import ccall safe "leveldb/c.h leveldb_open"
62 | c_leveldb_open :: OptionsPtr -> DBName -> ErrPtr -> IO LevelDBPtr
63 |
64 | foreign import ccall safe "leveldb/c.h leveldb_close"
65 | c_leveldb_close :: LevelDBPtr -> IO ()
66 |
67 |
68 | foreign import ccall safe "leveldb/c.h leveldb_put"
69 | c_leveldb_put :: LevelDBPtr
70 | -> WriteOptionsPtr
71 | -> Key -> CSize
72 | -> Val -> CSize
73 | -> ErrPtr
74 | -> IO ()
75 |
76 | foreign import ccall safe "leveldb/c.h leveldb_delete"
77 | c_leveldb_delete :: LevelDBPtr
78 | -> WriteOptionsPtr
79 | -> Key -> CSize
80 | -> ErrPtr
81 | -> IO ()
82 |
83 | foreign import ccall safe "leveldb/c.h leveldb_write"
84 | c_leveldb_write :: LevelDBPtr
85 | -> WriteOptionsPtr
86 | -> WriteBatchPtr
87 | -> ErrPtr
88 | -> IO ()
89 |
90 | -- | Returns NULL if not found. A malloc()ed array otherwise. Stores the length
91 | -- of the array in *vallen.
92 | foreign import ccall safe "leveldb/c.h leveldb_get"
93 | c_leveldb_get :: LevelDBPtr
94 | -> ReadOptionsPtr
95 | -> Key -> CSize
96 | -> Ptr CSize -- ^ value length
97 | -> ErrPtr
98 | -> IO CString
99 |
100 | foreign import ccall safe "leveldb/c.h leveldb_create_snapshot"
101 | c_leveldb_create_snapshot :: LevelDBPtr -> IO SnapshotPtr
102 |
103 | foreign import ccall safe "leveldb/c.h leveldb_release_snapshot"
104 | c_leveldb_release_snapshot :: LevelDBPtr -> SnapshotPtr -> IO ()
105 |
106 | -- | Returns NULL if property name is unknown. Else returns a pointer to a
107 | -- malloc()-ed null-terminated value.
108 | foreign import ccall safe "leveldb/c.h leveldb_property_value"
109 | c_leveldb_property_value :: LevelDBPtr -> CString -> IO CString
110 |
111 | foreign import ccall safe "leveldb/c.h leveldb_approximate_sizes"
112 | c_leveldb_approximate_sizes :: LevelDBPtr
113 | -> CInt -- ^ num ranges
114 | -> Ptr CString -> Ptr CSize -- ^ range start keys (array)
115 | -> Ptr CString -> Ptr CSize -- ^ range limit keys (array)
116 | -> Ptr Word64 -- ^ array of approx. sizes of ranges
117 | -> IO ()
118 |
119 | foreign import ccall safe "leveldb/c.h leveldb_compact_range"
120 | c_leveldb_compact_range :: LevelDBPtr
121 | -> CString -> CSize -- ^ start key
122 | -> CString -> CSize -- ^ limit key
123 | -> IO ()
124 |
125 | foreign import ccall safe "leveldb/c.h leveldb_destroy_db"
126 | c_leveldb_destroy_db :: OptionsPtr -> DBName -> ErrPtr -> IO ()
127 |
128 | foreign import ccall safe "leveldb/c.h leveldb_repair_db"
129 | c_leveldb_repair_db :: OptionsPtr -> DBName -> ErrPtr -> IO ()
130 |
131 |
132 | --
133 | -- Iterator
134 | --
135 |
136 | foreign import ccall safe "leveldb/c.h leveldb_create_iterator"
137 | c_leveldb_create_iterator :: LevelDBPtr -> ReadOptionsPtr -> IO IteratorPtr
138 |
139 | foreign import ccall safe "leveldb/c.h leveldb_iter_destroy"
140 | c_leveldb_iter_destroy :: IteratorPtr -> IO ()
141 |
142 | foreign import ccall unsafe "leveldb/c.h leveldb_iter_valid"
143 | c_leveldb_iter_valid :: IteratorPtr -> IO CUChar
144 |
145 | foreign import ccall safe "leveldb/c.h leveldb_iter_seek_to_first"
146 | c_leveldb_iter_seek_to_first :: IteratorPtr -> IO ()
147 |
148 | foreign import ccall safe "leveldb/c.h leveldb_iter_seek_to_last"
149 | c_leveldb_iter_seek_to_last :: IteratorPtr -> IO ()
150 |
151 | foreign import ccall safe "leveldb/c.h leveldb_iter_seek"
152 | c_leveldb_iter_seek :: IteratorPtr -> Key -> CSize -> IO ()
153 |
154 | foreign import ccall safe "leveldb/c.h leveldb_iter_next"
155 | c_leveldb_iter_next :: IteratorPtr -> IO ()
156 |
157 | foreign import ccall safe "leveldb/c.h leveldb_iter_prev"
158 | c_leveldb_iter_prev :: IteratorPtr -> IO ()
159 |
160 | foreign import ccall unsafe "leveldb/c.h leveldb_iter_key"
161 | c_leveldb_iter_key :: IteratorPtr -> Ptr CSize -> IO Key
162 |
163 | foreign import ccall unsafe "leveldb/c.h leveldb_iter_value"
164 | c_leveldb_iter_value :: IteratorPtr -> Ptr CSize -> IO Val
165 |
166 | foreign import ccall safe "leveldb/c.h leveldb_iter_get_error"
167 | c_leveldb_iter_get_error :: IteratorPtr -> ErrPtr -> IO ()
168 |
169 |
170 | --
171 | -- Write batch
172 | --
173 |
174 | foreign import ccall safe "leveldb/c.h leveldb_writebatch_create"
175 | c_leveldb_writebatch_create :: IO WriteBatchPtr
176 |
177 | foreign import ccall safe "leveldb/c.h leveldb_writebatch_destroy"
178 | c_leveldb_writebatch_destroy :: WriteBatchPtr -> IO ()
179 |
180 | foreign import ccall safe "leveldb/c.h leveldb_writebatch_clear"
181 | c_leveldb_writebatch_clear :: WriteBatchPtr -> IO ()
182 |
183 | foreign import ccall safe "leveldb/c.h leveldb_writebatch_put"
184 | c_leveldb_writebatch_put :: WriteBatchPtr
185 | -> Key -> CSize
186 | -> Val -> CSize
187 | -> IO ()
188 |
189 | foreign import ccall safe "leveldb/c.h leveldb_writebatch_delete"
190 | c_leveldb_writebatch_delete :: WriteBatchPtr -> Key -> CSize -> IO ()
191 |
192 | foreign import ccall safe "leveldb/c.h leveldb_writebatch_iterate"
193 | c_leveldb_writebatch_iterate :: WriteBatchPtr
194 | -> Ptr () -- ^ state
195 | -> FunPtr (Ptr () -> Key -> CSize -> Val -> CSize) -- ^ put
196 | -> FunPtr (Ptr () -> Key -> CSize) -- ^ delete
197 | -> IO ()
198 |
199 |
200 | --
201 | -- Options
202 | --
203 |
204 | foreign import ccall safe "leveldb/c.h leveldb_options_create"
205 | c_leveldb_options_create :: IO OptionsPtr
206 |
207 | foreign import ccall safe "leveldb/c.h leveldb_options_destroy"
208 | c_leveldb_options_destroy :: OptionsPtr -> IO ()
209 |
210 | foreign import ccall safe "leveldb/c.h leveldb_options_set_comparator"
211 | c_leveldb_options_set_comparator :: OptionsPtr -> ComparatorPtr -> IO ()
212 |
213 | foreign import ccall safe "leveldb/c.h leveldb_options_set_filter_policy"
214 | c_leveldb_options_set_filter_policy :: OptionsPtr -> FilterPolicyPtr -> IO ()
215 |
216 | foreign import ccall safe "leveldb/c.h leveldb_options_set_create_if_missing"
217 | c_leveldb_options_set_create_if_missing :: OptionsPtr -> CUChar -> IO ()
218 |
219 | foreign import ccall safe "leveldb/c.h leveldb_options_set_error_if_exists"
220 | c_leveldb_options_set_error_if_exists :: OptionsPtr -> CUChar -> IO ()
221 |
222 | foreign import ccall safe "leveldb/c.h leveldb_options_set_paranoid_checks"
223 | c_leveldb_options_set_paranoid_checks :: OptionsPtr -> CUChar -> IO ()
224 |
225 | foreign import ccall safe "leveldb/c.h leveldb_options_set_info_log"
226 | c_leveldb_options_set_info_log :: OptionsPtr -> LoggerPtr -> IO ()
227 |
228 | foreign import ccall safe "leveldb/c.h leveldb_options_set_write_buffer_size"
229 | c_leveldb_options_set_write_buffer_size :: OptionsPtr -> CSize -> IO ()
230 |
231 | foreign import ccall safe "leveldb/c.h leveldb_options_set_max_open_files"
232 | c_leveldb_options_set_max_open_files :: OptionsPtr -> CInt -> IO ()
233 |
234 | foreign import ccall safe "leveldb/c.h leveldb_options_set_block_size"
235 | c_leveldb_options_set_block_size :: OptionsPtr -> CSize -> IO ()
236 |
237 | foreign import ccall safe "leveldb/c.h leveldb_options_set_block_restart_interval"
238 | c_leveldb_options_set_block_restart_interval :: OptionsPtr -> CInt -> IO ()
239 |
240 | foreign import ccall safe "leveldb/c.h leveldb_options_set_compression"
241 | c_leveldb_options_set_compression :: OptionsPtr -> CompressionOpt -> IO ()
242 |
243 | foreign import ccall safe "leveldb/c.h leveldb_options_set_cache"
244 | c_leveldb_options_set_cache :: OptionsPtr -> CachePtr -> IO ()
245 |
246 |
247 | --
248 | -- Comparator
249 | --
250 |
251 | type StatePtr = Ptr ()
252 | type Destructor = StatePtr -> ()
253 | type CompareFun = StatePtr -> CString -> CSize -> CString -> CSize -> IO CInt
254 | type NameFun = StatePtr -> CString
255 |
256 | -- | Make a FunPtr to a user-defined comparator function
257 | foreign import ccall "wrapper" mkCmp :: CompareFun -> IO (FunPtr CompareFun)
258 |
259 | -- | Make a destructor FunPtr
260 | foreign import ccall "wrapper" mkDest :: Destructor -> IO (FunPtr Destructor)
261 |
262 | -- | Make a name FunPtr
263 | foreign import ccall "wrapper" mkName :: NameFun -> IO (FunPtr NameFun)
264 |
265 | foreign import ccall safe "leveldb/c.h leveldb_comparator_create"
266 | c_leveldb_comparator_create :: StatePtr
267 | -> FunPtr Destructor
268 | -> FunPtr CompareFun
269 | -> FunPtr NameFun
270 | -> IO ComparatorPtr
271 |
272 | foreign import ccall safe "leveldb/c.h leveldb_comparator_destroy"
273 | c_leveldb_comparator_destroy :: ComparatorPtr -> IO ()
274 |
275 |
276 | --
277 | -- Filter Policy
278 | --
279 |
280 | type CreateFilterFun = StatePtr
281 | -> Ptr CString -- ^ key array
282 | -> Ptr CSize -- ^ key length array
283 | -> CInt -- ^ num keys
284 | -> Ptr CSize -- ^ filter length
285 | -> IO CString -- ^ the filter
286 | type KeyMayMatchFun = StatePtr
287 | -> CString -- ^ key
288 | -> CSize -- ^ key length
289 | -> CString -- ^ filter
290 | -> CSize -- ^ filter length
291 | -> IO CUChar -- ^ whether key is in filter
292 |
293 | -- | Make a FunPtr to a user-defined create_filter function
294 | foreign import ccall "wrapper" mkCF :: CreateFilterFun -> IO (FunPtr CreateFilterFun)
295 |
296 | -- | Make a FunPtr to a user-defined key_may_match function
297 | foreign import ccall "wrapper" mkKMM :: KeyMayMatchFun -> IO (FunPtr KeyMayMatchFun)
298 |
299 | foreign import ccall safe "leveldb/c.h leveldb_filterpolicy_create"
300 | c_leveldb_filterpolicy_create :: StatePtr
301 | -> FunPtr Destructor
302 | -> FunPtr CreateFilterFun
303 | -> FunPtr KeyMayMatchFun
304 | -> FunPtr NameFun
305 | -> IO FilterPolicyPtr
306 |
307 | foreign import ccall safe "leveldb/c.h leveldb_filterpolicy_destroy"
308 | c_leveldb_filterpolicy_destroy :: FilterPolicyPtr -> IO ()
309 |
310 | foreign import ccall safe "leveldb/c.h leveldb_filterpolicy_create_bloom"
311 | c_leveldb_filterpolicy_create_bloom :: CInt -> IO FilterPolicyPtr
312 |
313 | --
314 | -- Read options
315 | --
316 |
317 | foreign import ccall safe "leveldb/c.h leveldb_readoptions_create"
318 | c_leveldb_readoptions_create :: IO ReadOptionsPtr
319 |
320 | foreign import ccall safe "leveldb/c.h leveldb_readoptions_destroy"
321 | c_leveldb_readoptions_destroy :: ReadOptionsPtr -> IO ()
322 |
323 | foreign import ccall safe "leveldb/c.h leveldb_readoptions_set_verify_checksums"
324 | c_leveldb_readoptions_set_verify_checksums :: ReadOptionsPtr -> CUChar -> IO ()
325 |
326 | foreign import ccall safe "leveldb/c.h leveldb_readoptions_set_fill_cache"
327 | c_leveldb_readoptions_set_fill_cache :: ReadOptionsPtr -> CUChar -> IO ()
328 |
329 | foreign import ccall safe "leveldb/c.h leveldb_readoptions_set_snapshot"
330 | c_leveldb_readoptions_set_snapshot :: ReadOptionsPtr -> SnapshotPtr -> IO ()
331 |
332 |
333 | --
334 | -- Write options
335 | --
336 |
337 | foreign import ccall safe "leveldb/c.h leveldb_writeoptions_create"
338 | c_leveldb_writeoptions_create :: IO WriteOptionsPtr
339 |
340 | foreign import ccall safe "leveldb/c.h leveldb_writeoptions_destroy"
341 | c_leveldb_writeoptions_destroy :: WriteOptionsPtr -> IO ()
342 |
343 | foreign import ccall safe "leveldb/c.h leveldb_writeoptions_set_sync"
344 | c_leveldb_writeoptions_set_sync :: WriteOptionsPtr -> CUChar -> IO ()
345 |
346 |
347 | --
348 | -- Cache
349 | --
350 |
351 | foreign import ccall safe "leveldb/c.h leveldb_cache_create_lru"
352 | c_leveldb_cache_create_lru :: CSize -> IO CachePtr
353 |
354 | foreign import ccall safe "leveldb/c.h leveldb_cache_destroy"
355 | c_leveldb_cache_destroy :: CachePtr -> IO ()
356 |
357 | --
358 | -- Utility
359 | --
360 |
361 | -- Calls free(ptr).
362 | -- REQUIRES: ptr was malloc()-ed and returned by one of the routines
363 | -- in this file. Note that in certain cases (typically on Windows), you
364 | -- may need to call this routine instead of free(ptr) to dispose of
365 | -- malloc()-ed memory returned by this library. */
366 | foreign import ccall safe "leveldb/c.h leveldb_free"
367 | c_leveldb_free :: Ptr a -> IO ()
368 |
369 | foreign import ccall unsafe "leveldb/c.h leveldb_major_version"
370 | c_leveldb_major_version :: IO CInt
371 |
372 | foreign import ccall unsafe "leveldb/c.h leveldb_minor_version"
373 | c_leveldb_minor_version :: IO CInt
374 |
--------------------------------------------------------------------------------
/src/Database/LevelDB/Internal.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE RecordWildCards #-}
2 | {-# LANGUAGE CPP #-}
3 |
4 | -- |
5 | -- Module : Database.LevelDB.Internal
6 | -- Copyright : (c) 2012-2013 The leveldb-haskell Authors
7 | -- License : BSD3
8 | -- Maintainer : kim.altintop@gmail.com
9 | -- Stability : experimental
10 | -- Portability : non-portable
11 | --
12 |
13 | module Database.LevelDB.Internal
14 | ( -- * Types
15 | DB (..)
16 | , Comparator'
17 | , FilterPolicy'
18 | , Options' (..)
19 |
20 | , unsafeClose
21 |
22 | -- * \"Smart\" constructors and deconstructors
23 | , freeCReadOpts
24 | , freeComparator
25 | , freeFilterPolicy
26 | , freeOpts
27 | , mkCReadOpts
28 | , mkComparator
29 | , mkCompareFun
30 | , mkCreateFilterFun
31 | , mkFilterPolicy
32 | , mkKeyMayMatchFun
33 | , mkOpts
34 |
35 | -- * combinators
36 | , withCWriteOpts
37 | , withCReadOpts
38 |
39 | -- * Utilities
40 | , throwIfErr
41 | , cSizeToInt
42 | , intToCSize
43 | , intToCInt
44 | , cIntToInt
45 | , boolToNum
46 | )
47 | where
48 |
49 | import Control.Applicative ((<$>))
50 | import Control.Exception (bracket, finally, onException, throwIO)
51 | import Control.Monad (when)
52 | import Data.ByteString (ByteString)
53 | import Data.IORef
54 | import Foreign
55 | import Foreign.C.String (peekCString, withCString)
56 | import Foreign.C.Types (CInt, CSize)
57 |
58 | import Database.LevelDB.C
59 | import Database.LevelDB.Types
60 |
61 | import qualified Data.ByteString as BS
62 |
63 |
64 | -- | Database handle
65 | data DB = DB LevelDBPtr Options' (IORef Bool)
66 |
67 | instance Eq DB where
68 | (DB pt1 _ _) == (DB pt2 _ _) = pt1 == pt2
69 |
70 | -- | Internal representation of a 'Comparator'
71 | data Comparator' = Comparator' (FunPtr CompareFun)
72 | (FunPtr Destructor)
73 | (FunPtr NameFun)
74 | ComparatorPtr
75 |
76 | -- | Internal representation of a 'FilterPolicy'
77 | data FilterPolicy' = FilterPolicy' (FunPtr CreateFilterFun)
78 | (FunPtr KeyMayMatchFun)
79 | (FunPtr Destructor)
80 | (FunPtr NameFun)
81 | FilterPolicyPtr
82 |
83 | -- | Internal representation of the 'Options'
84 | data Options' = Options'
85 | { _optsPtr :: !OptionsPtr
86 | , _cachePtr :: !(Maybe CachePtr)
87 | , _comp :: !(Maybe Comparator')
88 | , _fpPtr :: !(Maybe (Either FilterPolicyPtr FilterPolicy'))
89 | }
90 |
91 |
92 | -- | Closes the database.
93 | --
94 | -- The function is safe in that it doesn't double-free the pointer, but is
95 | -- /unsafe/ because other functions which use the 'DB' handle do /not/ check if
96 | -- the handle is live. If the handle is used after it was freed, the program
97 | -- will segfault (internally, leveldb performs a @delete@ on the pointer).
98 | unsafeClose :: DB -> IO ()
99 | unsafeClose (DB db_ptr opts_ptr ref) = do
100 | alive <- modify ref ((,) False)
101 | when alive $
102 | c_leveldb_close db_ptr `finally` freeOpts opts_ptr
103 |
104 | modify :: IORef a -> (a -> (a,b)) -> IO b
105 | #if MIN_VERSION_base(4,6,0)
106 | modify = atomicModifyIORef'
107 | #else
108 | modify ref f = do
109 | b <- atomicModifyIORef ref
110 | (\x -> let (a, b) = f x
111 | in (a, a `seq` b))
112 | b `seq` return b
113 | #endif
114 |
115 | mkOpts :: Options -> IO Options'
116 | mkOpts Options{..} = do
117 | opts_ptr <- c_leveldb_options_create
118 |
119 | c_leveldb_options_set_block_restart_interval opts_ptr
120 | $ intToCInt blockRestartInterval
121 | c_leveldb_options_set_block_size opts_ptr
122 | $ intToCSize blockSize
123 | c_leveldb_options_set_compression opts_ptr
124 | $ ccompression compression
125 | c_leveldb_options_set_create_if_missing opts_ptr
126 | $ boolToNum createIfMissing
127 | c_leveldb_options_set_error_if_exists opts_ptr
128 | $ boolToNum errorIfExists
129 | c_leveldb_options_set_max_open_files opts_ptr
130 | $ intToCInt maxOpenFiles
131 | c_leveldb_options_set_paranoid_checks opts_ptr
132 | $ boolToNum paranoidChecks
133 | c_leveldb_options_set_write_buffer_size opts_ptr
134 | $ intToCSize writeBufferSize
135 |
136 | cache <- maybeSetCache opts_ptr cacheSize
137 | cmp <- maybeSetCmp opts_ptr comparator
138 | fp <- maybeSetFilterPolicy opts_ptr filterPolicy
139 |
140 | return (Options' opts_ptr cache cmp fp)
141 |
142 | where
143 | ccompression NoCompression = noCompression
144 | ccompression Snappy = snappyCompression
145 |
146 | maybeSetCache :: OptionsPtr -> Int -> IO (Maybe CachePtr)
147 | maybeSetCache opts_ptr size =
148 | if size <= 0
149 | then return Nothing
150 | else do
151 | cache_ptr <- c_leveldb_cache_create_lru $ intToCSize size
152 | c_leveldb_options_set_cache opts_ptr cache_ptr
153 | return . Just $ cache_ptr
154 |
155 | maybeSetCmp :: OptionsPtr -> Maybe Comparator -> IO (Maybe Comparator')
156 | maybeSetCmp opts_ptr (Just mcmp) = Just <$> setcmp opts_ptr mcmp
157 | maybeSetCmp _ Nothing = return Nothing
158 |
159 | setcmp :: OptionsPtr -> Comparator -> IO Comparator'
160 | setcmp opts_ptr (Comparator cmp) = do
161 | cmp'@(Comparator' _ _ _ cmp_ptr) <- mkComparator "user-defined" cmp
162 | c_leveldb_options_set_comparator opts_ptr cmp_ptr
163 | return cmp'
164 |
165 | maybeSetFilterPolicy :: OptionsPtr
166 | -> Maybe (Either BloomFilter FilterPolicy)
167 | -> IO (Maybe (Either FilterPolicyPtr FilterPolicy'))
168 | maybeSetFilterPolicy _ Nothing =
169 | return Nothing
170 | maybeSetFilterPolicy opts_ptr (Just (Left (BloomFilter bloom_ptr))) = do
171 | c_leveldb_options_set_filter_policy opts_ptr bloom_ptr
172 | return Nothing -- bloom filter is freed automatically
173 | maybeSetFilterPolicy opts_ptr (Just (Right fp)) = do
174 | fp'@(FilterPolicy' _ _ _ _ fp_ptr) <- mkFilterPolicy fp
175 | c_leveldb_options_set_filter_policy opts_ptr fp_ptr
176 | return . Just . Right $ fp'
177 |
178 | freeOpts :: Options' -> IO ()
179 | freeOpts (Options' opts_ptr mcache_ptr mcmp_ptr mfp) = do
180 | c_leveldb_options_destroy opts_ptr
181 | maybe (return ()) c_leveldb_cache_destroy mcache_ptr
182 | maybe (return ()) freeComparator mcmp_ptr
183 | maybe (return ())
184 | (either c_leveldb_filterpolicy_destroy freeFilterPolicy)
185 | mfp
186 |
187 | return ()
188 |
189 | withCWriteOpts :: WriteOptions -> (WriteOptionsPtr -> IO a) -> IO a
190 | withCWriteOpts WriteOptions{..} = bracket mkCWriteOpts freeCWriteOpts
191 | where
192 | mkCWriteOpts = do
193 | opts_ptr <- c_leveldb_writeoptions_create
194 | onException
195 | (c_leveldb_writeoptions_set_sync opts_ptr $ boolToNum sync)
196 | (c_leveldb_writeoptions_destroy opts_ptr)
197 | return opts_ptr
198 |
199 | freeCWriteOpts = c_leveldb_writeoptions_destroy
200 |
201 | mkCompareFun :: (ByteString -> ByteString -> Ordering) -> CompareFun
202 | mkCompareFun cmp = cmp'
203 | where
204 | cmp' _ a alen b blen = do
205 | a' <- BS.packCStringLen (a, fromInteger . toInteger $ alen)
206 | b' <- BS.packCStringLen (b, fromInteger . toInteger $ blen)
207 | return $ case cmp a' b' of
208 | EQ -> 0
209 | GT -> 1
210 | LT -> -1
211 |
212 | mkComparator :: String -> (ByteString -> ByteString -> Ordering) -> IO Comparator'
213 | mkComparator name f =
214 | withCString name $ \cs -> do
215 | ccmpfun <- mkCmp . mkCompareFun $ f
216 | cdest <- mkDest $ const ()
217 | cname <- mkName $ const cs
218 | ccmp <- c_leveldb_comparator_create nullPtr cdest ccmpfun cname
219 | return $ Comparator' ccmpfun cdest cname ccmp
220 |
221 |
222 | freeComparator :: Comparator' -> IO ()
223 | freeComparator (Comparator' ccmpfun cdest cname ccmp) = do
224 | c_leveldb_comparator_destroy ccmp
225 | freeHaskellFunPtr ccmpfun
226 | freeHaskellFunPtr cdest
227 | freeHaskellFunPtr cname
228 |
229 | mkCreateFilterFun :: ([ByteString] -> ByteString) -> CreateFilterFun
230 | mkCreateFilterFun f = f'
231 | where
232 | f' _ ks ks_lens n_ks flen = do
233 | let n_ks' = fromInteger . toInteger $ n_ks
234 | ks' <- peekArray n_ks' ks
235 | ks_lens' <- peekArray n_ks' ks_lens
236 | keys <- mapM bstr (zip ks' ks_lens')
237 | let res = f keys
238 | poke flen (fromIntegral . BS.length $ res)
239 | BS.useAsCString res $ \cstr -> return cstr
240 |
241 | bstr (x,len) = BS.packCStringLen (x, fromInteger . toInteger $ len)
242 |
243 | mkKeyMayMatchFun :: (ByteString -> ByteString -> Bool) -> KeyMayMatchFun
244 | mkKeyMayMatchFun g = g'
245 | where
246 | g' _ k klen f flen = do
247 | k' <- BS.packCStringLen (k, fromInteger . toInteger $ klen)
248 | f' <- BS.packCStringLen (f, fromInteger . toInteger $ flen)
249 | return . boolToNum $ g k' f'
250 |
251 |
252 | mkFilterPolicy :: FilterPolicy -> IO FilterPolicy'
253 | mkFilterPolicy FilterPolicy{..} =
254 | withCString fpName $ \cs -> do
255 | cname <- mkName $ const cs
256 | cdest <- mkDest $ const ()
257 | ccffun <- mkCF . mkCreateFilterFun $ createFilter
258 | ckmfun <- mkKMM . mkKeyMayMatchFun $ keyMayMatch
259 | cfp <- c_leveldb_filterpolicy_create nullPtr cdest ccffun ckmfun cname
260 |
261 | return $ FilterPolicy' ccffun ckmfun cdest cname cfp
262 |
263 | freeFilterPolicy :: FilterPolicy' -> IO ()
264 | freeFilterPolicy (FilterPolicy' ccffun ckmfun cdest cname cfp) = do
265 | c_leveldb_filterpolicy_destroy cfp
266 | freeHaskellFunPtr ccffun
267 | freeHaskellFunPtr ckmfun
268 | freeHaskellFunPtr cdest
269 | freeHaskellFunPtr cname
270 |
271 | mkCReadOpts :: ReadOptions -> IO ReadOptionsPtr
272 | mkCReadOpts ReadOptions{..} = do
273 | opts_ptr <- c_leveldb_readoptions_create
274 | flip onException (c_leveldb_readoptions_destroy opts_ptr) $ do
275 | c_leveldb_readoptions_set_verify_checksums opts_ptr $ boolToNum verifyCheckSums
276 | c_leveldb_readoptions_set_fill_cache opts_ptr $ boolToNum fillCache
277 |
278 | case useSnapshot of
279 | Just (Snapshot snap_ptr) -> c_leveldb_readoptions_set_snapshot opts_ptr snap_ptr
280 | Nothing -> return ()
281 |
282 | return opts_ptr
283 |
284 | freeCReadOpts :: ReadOptionsPtr -> IO ()
285 | freeCReadOpts = c_leveldb_readoptions_destroy
286 |
287 | withCReadOpts :: ReadOptions -> (ReadOptionsPtr -> IO a) -> IO a
288 | withCReadOpts opts = bracket (mkCReadOpts opts) freeCReadOpts
289 |
290 | throwIfErr :: String -> (ErrPtr -> IO a) -> IO a
291 | throwIfErr s f = alloca $ \err_ptr -> do
292 | poke err_ptr nullPtr
293 | res <- f err_ptr
294 | erra <- peek err_ptr
295 | when (erra /= nullPtr) $ do
296 | err <- peekCString erra
297 | throwIO $ userError $ s ++ ": " ++ err
298 | return res
299 |
300 | cSizeToInt :: CSize -> Int
301 | cSizeToInt = fromIntegral
302 | {-# INLINE cSizeToInt #-}
303 |
304 | intToCSize :: Int -> CSize
305 | intToCSize = fromIntegral
306 | {-# INLINE intToCSize #-}
307 |
308 | intToCInt :: Int -> CInt
309 | intToCInt = fromIntegral
310 | {-# INLINE intToCInt #-}
311 |
312 | cIntToInt :: CInt -> Int
313 | cIntToInt = fromIntegral
314 | {-# INLINE cIntToInt #-}
315 |
316 | boolToNum :: Num b => Bool -> b
317 | boolToNum True = fromIntegral (1 :: Int)
318 | boolToNum False = fromIntegral (0 :: Int)
319 | {-# INLINE boolToNum #-}
320 |
--------------------------------------------------------------------------------
/src/Database/LevelDB/Iterator.hs:
--------------------------------------------------------------------------------
1 | -- |
2 | -- Module : Database.LevelDB.Iterator
3 | -- Copyright : (c) 2012-2013 The leveldb-haskell Authors
4 | -- License : BSD3
5 | -- Maintainer : kim.altintop@gmail.com
6 | -- Stability : experimental
7 | -- Portability : non-portable
8 | --
9 | -- Iterating over key ranges.
10 | --
11 |
12 | module Database.LevelDB.Iterator
13 | ( Iterator
14 | , createIter
15 | , iterEntry
16 | , iterFirst
17 | , iterGetError
18 | , iterKey
19 | , iterLast
20 | , iterNext
21 | , iterPrev
22 | , iterSeek
23 | , iterValid
24 | , iterValue
25 | , releaseIter
26 | , withIter
27 | )
28 | where
29 |
30 | import Control.Applicative ((<$>), (<*>))
31 | import Control.Monad (when)
32 | import Control.Monad.Catch
33 | import Control.Monad.IO.Class (MonadIO (liftIO))
34 | import Data.ByteString (ByteString)
35 | import Foreign
36 | import Foreign.C.Error (throwErrnoIfNull)
37 | import Foreign.C.String (CString, peekCString)
38 | import Foreign.C.Types (CSize)
39 |
40 | import Database.LevelDB.C
41 | import Database.LevelDB.Internal
42 | import Database.LevelDB.Types
43 |
44 | import qualified Data.ByteString as BS
45 | import qualified Data.ByteString.Char8 as BC
46 | import qualified Data.ByteString.Unsafe as BU
47 |
48 | -- | Iterator handle
49 | --
50 | -- Note that an 'Iterator' requires external synchronization if it is shared
51 | -- between multiple threads which mutate it's state. See
52 | -- @examples/iterforkio.hs@ for a simple example of how to do that.
53 | data Iterator = Iterator !IteratorPtr !ReadOptionsPtr deriving (Eq)
54 |
55 | -- | Create an 'Iterator'.
56 | --
57 | -- The iterator should be released with 'releaseIter'.
58 | --
59 | -- Note that an 'Iterator' creates a snapshot of the database implicitly, so
60 | -- updates written after the iterator was created are not visible. You may,
61 | -- however, specify an older 'Snapshot' in the 'ReadOptions'.
62 | createIter :: MonadIO m => DB -> ReadOptions -> m Iterator
63 | createIter (DB db_ptr _ _) opts = liftIO $ do
64 | opts_ptr <- mkCReadOpts opts
65 | flip onException (freeCReadOpts opts_ptr) $ do
66 | iter_ptr <- throwErrnoIfNull "create_iterator" $
67 | c_leveldb_create_iterator db_ptr opts_ptr
68 | return $ Iterator iter_ptr opts_ptr
69 |
70 | -- | Release an 'Iterator'.
71 | --
72 | -- The handle will be invalid after calling this action and should no
73 | -- longer be used. Calling this function with an already released 'Iterator'
74 | -- will cause a double-free error!
75 | releaseIter :: MonadIO m => Iterator -> m ()
76 | releaseIter (Iterator iter_ptr opts) = liftIO $
77 | c_leveldb_iter_destroy iter_ptr `finally` freeCReadOpts opts
78 |
79 | -- | Run an action with an 'Iterator'
80 | withIter :: (MonadMask m, MonadIO m) => DB -> ReadOptions -> (Iterator -> m a) -> m a
81 | withIter db opts = bracket (createIter db opts) releaseIter
82 |
83 | -- | An iterator is either positioned at a key/value pair, or not valid. This
84 | -- function returns /true/ iff the iterator is valid.
85 | iterValid :: MonadIO m => Iterator -> m Bool
86 | iterValid (Iterator iter_ptr _) = liftIO $ do
87 | x <- c_leveldb_iter_valid iter_ptr
88 | return (x /= 0)
89 |
90 | -- | Position at the first key in the source that is at or past target. The
91 | -- iterator is /valid/ after this call iff the source contains an entry that
92 | -- comes at or past target.
93 | iterSeek :: MonadIO m => Iterator -> ByteString -> m ()
94 | iterSeek (Iterator iter_ptr _) key = liftIO $
95 | BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->
96 | c_leveldb_iter_seek iter_ptr key_ptr (intToCSize klen)
97 |
98 | -- | Position at the first key in the source. The iterator is /valid/ after this
99 | -- call iff the source is not empty.
100 | iterFirst :: MonadIO m => Iterator -> m ()
101 | iterFirst (Iterator iter_ptr _) = liftIO $ c_leveldb_iter_seek_to_first iter_ptr
102 |
103 | -- | Position at the last key in the source. The iterator is /valid/ after this
104 | -- call iff the source is not empty.
105 | iterLast :: MonadIO m => Iterator -> m ()
106 | iterLast (Iterator iter_ptr _) = liftIO $ c_leveldb_iter_seek_to_last iter_ptr
107 |
108 | -- | Moves to the next entry in the source. After this call, 'iterValid' is
109 | -- /true/ iff the iterator was not positioned at the last entry in the source.
110 | --
111 | -- If the iterator is not valid, this function does nothing. Note that this is a
112 | -- shortcoming of the C API: an 'iterPrev' might still be possible, but we can't
113 | -- determine if we're at the last or first entry.
114 | iterNext :: MonadIO m => Iterator -> m ()
115 | iterNext (Iterator iter_ptr _) = liftIO $ do
116 | valid <- c_leveldb_iter_valid iter_ptr
117 | when (valid /= 0) $ c_leveldb_iter_next iter_ptr
118 |
119 | -- | Moves to the previous entry in the source. After this call, 'iterValid' is
120 | -- /true/ iff the iterator was not positioned at the first entry in the source.
121 | --
122 | -- If the iterator is not valid, this function does nothing. Note that this is a
123 | -- shortcoming of the C API: an 'iterNext' might still be possible, but we can't
124 | -- determine if we're at the last or first entry.
125 | iterPrev :: MonadIO m => Iterator -> m ()
126 | iterPrev (Iterator iter_ptr _) = liftIO $ do
127 | valid <- c_leveldb_iter_valid iter_ptr
128 | when (valid /= 0) $ c_leveldb_iter_prev iter_ptr
129 |
130 | -- | Return the key for the current entry if the iterator is currently
131 | -- positioned at an entry, ie. 'iterValid'.
132 | iterKey :: MonadIO m => Iterator -> m (Maybe ByteString)
133 | iterKey = liftIO . flip iterString c_leveldb_iter_key
134 |
135 | -- | Return the value for the current entry if the iterator is currently
136 | -- positioned at an entry, ie. 'iterValid'.
137 | iterValue :: MonadIO m => Iterator -> m (Maybe ByteString)
138 | iterValue = liftIO . flip iterString c_leveldb_iter_value
139 |
140 | -- | Return the current entry as a pair, if the iterator is currently positioned
141 | -- at an entry, ie. 'iterValid'.
142 | iterEntry :: MonadIO m => Iterator -> m (Maybe (ByteString, ByteString))
143 | iterEntry iter = liftIO $ do
144 | mkey <- iterKey iter
145 | mval <- iterValue iter
146 | return $ (,) <$> mkey <*> mval
147 |
148 | -- | Check for errors
149 | --
150 | -- Note that this captures somewhat severe errors such as a corrupted database.
151 | iterGetError :: MonadIO m => Iterator -> m (Maybe ByteString)
152 | iterGetError (Iterator iter_ptr _) = liftIO $
153 | alloca $ \err_ptr -> do
154 | poke err_ptr nullPtr
155 | c_leveldb_iter_get_error iter_ptr err_ptr
156 | erra <- peek err_ptr
157 | if erra == nullPtr
158 | then return Nothing
159 | else do
160 | err <- peekCString erra
161 | return . Just . BC.pack $ err
162 |
163 | --
164 | -- Internal
165 | --
166 |
167 | iterString :: Iterator
168 | -> (IteratorPtr -> Ptr CSize -> IO CString)
169 | -> IO (Maybe ByteString)
170 | iterString (Iterator iter_ptr _) f = do
171 | valid <- c_leveldb_iter_valid iter_ptr
172 | if valid == 0
173 | then return Nothing
174 | else alloca $ \len_ptr -> do
175 | ptr <- f iter_ptr len_ptr
176 | if ptr == nullPtr
177 | then return Nothing
178 | else do
179 | len <- peek len_ptr
180 | Just <$> BS.packCStringLen (ptr, cSizeToInt len)
181 |
--------------------------------------------------------------------------------
/src/Database/LevelDB/MonadResource.hs:
--------------------------------------------------------------------------------
1 | -- |
2 | -- Module : Database.LevelDB.MonadResource
3 | -- Copyright : (c) 2012-2013 The leveldb-haskell Authors
4 | -- License : BSD3
5 | -- Maintainer : kim.altintop@gmail.com
6 | -- Stability : experimental
7 | -- Portability : non-portable
8 | --
9 |
10 | module Database.LevelDB.MonadResource
11 | ( -- * Exported Types
12 | DB
13 | , BatchOp(..)
14 | , Comparator(..)
15 | , Compression(..)
16 | , Options(..)
17 | , ReadOptions(..)
18 | , Snapshot
19 | , WriteBatch
20 | , WriteOptions(..)
21 | , Range
22 |
23 | -- * Defaults
24 | , defaultOptions
25 | , defaultWriteOptions
26 | , defaultReadOptions
27 |
28 | -- * Basic Database Manipulation
29 | , withSnapshot
30 | , open
31 | , put
32 | , delete
33 | , write
34 | , get
35 | , createSnapshot
36 | , createSnapshot'
37 |
38 | -- * Filter Policy / Bloom Filter
39 | , FilterPolicy(..)
40 | , bloomFilter
41 |
42 | -- * Administrative Functions
43 | , Property(..), getProperty
44 | , destroy
45 | , repair
46 | , approximateSize
47 | , compactRange
48 | , version
49 |
50 | -- * Iteration
51 | , Iterator
52 | , withIterator
53 | , iterOpen
54 | , iterOpen'
55 | , iterValid
56 | , iterSeek
57 | , iterFirst
58 | , iterLast
59 | , iterNext
60 | , iterPrev
61 | , iterKey
62 | , iterValue
63 | , iterGetError
64 |
65 | -- * Re-exports
66 | , MonadResource (..)
67 | , runResourceT
68 | , resourceForkIO
69 | )
70 | where
71 |
72 | import Control.Applicative ((<$>))
73 | import Control.Monad.Trans.Resource
74 | import Database.LevelDB.Base (BatchOp, BloomFilter, Comparator,
75 | Compression, DB, FilterPolicy,
76 | Iterator, Options, Property,
77 | Range, ReadOptions, Snapshot,
78 | WriteBatch, WriteOptions,
79 | approximateSize, compactRange,
80 | defaultOptions,
81 | defaultReadOptions,
82 | defaultWriteOptions, delete,
83 | destroy, get, getProperty,
84 | iterFirst, iterGetError, iterKey,
85 | iterLast, iterNext, iterPrev,
86 | iterSeek, iterValid, iterValue,
87 | put, repair, version, write)
88 | import qualified Database.LevelDB.Base as Base
89 | import qualified Database.LevelDB.Internal as Internal
90 |
91 |
92 | -- | Create a 'BloomFilter'
93 | bloomFilter :: MonadResource m => Int -> m BloomFilter
94 | bloomFilter i =
95 | snd <$> allocate (Base.createBloomFilter i)
96 | Base.releaseBloomFilter
97 |
98 | -- | Open a database
99 | --
100 | -- The returned handle will automatically be released when the enclosing
101 | -- 'runResourceT' terminates.
102 | open :: MonadResource m => FilePath -> Options -> m DB
103 | open path opts = snd <$> open' path opts
104 |
105 | open' :: MonadResource m => FilePath -> Options -> m (ReleaseKey, DB)
106 | open' path opts = allocate (Base.open path opts) Internal.unsafeClose
107 | {-# INLINE open' #-}
108 |
109 | -- | Run an action with a snapshot of the database.
110 | --
111 | -- The snapshot will be released when the action terminates or throws an
112 | -- exception. Note that this function is provided for convenience and does not
113 | -- prevent the 'Snapshot' handle to escape. It will, however, be invalid after
114 | -- this function returns and should not be used anymore.
115 | withSnapshot :: MonadResource m => DB -> (Snapshot -> m a) -> m a
116 | withSnapshot db f = do
117 | (rk, snap) <- createSnapshot' db
118 | res <- f snap
119 | release rk
120 | return res
121 |
122 | -- | Create a snapshot of the database.
123 | --
124 | -- The returned 'Snapshot' will be released automatically when the enclosing
125 | -- 'runResourceT' terminates. It is recommended to use 'createSnapshot'' instead
126 | -- and release the resource manually as soon as possible.
127 | createSnapshot :: MonadResource m => DB -> m Snapshot
128 | createSnapshot db = snd <$> createSnapshot' db
129 |
130 | -- | Create a snapshot of the database which can (and should) be released early.
131 | createSnapshot' :: MonadResource m => DB -> m (ReleaseKey, Snapshot)
132 | createSnapshot' db = allocate (Base.createSnapshot db) (Base.releaseSnapshot db)
133 |
134 | -- | Run an action with an Iterator. The iterator will be closed after the
135 | -- action returns or an error is thrown. Thus, the iterator will /not/ be valid
136 | -- after this function terminates.
137 | withIterator :: MonadResource m => DB -> ReadOptions -> (Iterator -> m a) -> m a
138 | withIterator db opts f = do
139 | (rk, iter) <- iterOpen' db opts
140 | res <- f iter
141 | release rk
142 | return res
143 |
144 | -- | Create an 'Iterator'.
145 | --
146 | -- The iterator will be released when the enclosing 'runResourceT' terminates.
147 | -- You may consider to use 'iterOpen'' instead and manually release the iterator
148 | -- as soon as it is no longer needed (alternatively, use 'withIterator').
149 | --
150 | -- Note that an 'Iterator' creates a snapshot of the database implicitly, so
151 | -- updates written after the iterator was created are not visible. You may,
152 | -- however, specify an older 'Snapshot' in the 'ReadOptions'.
153 | iterOpen :: MonadResource m => DB -> ReadOptions -> m Iterator
154 | iterOpen db opts = snd <$> iterOpen' db opts
155 |
156 | -- | Create an 'Iterator' which can be released early.
157 | iterOpen' :: MonadResource m => DB -> ReadOptions -> m (ReleaseKey, Iterator)
158 | iterOpen' db opts = allocate (Base.createIter db opts) Base.releaseIter
159 |
--------------------------------------------------------------------------------
/src/Database/LevelDB/Streaming.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns #-}
2 |
3 | -- |
4 | -- Module : Database.LevelDB.Streaming
5 | -- Copyright : (c) 2014 Kim Altintop
6 | -- License : BSD3
7 | -- Maintainer : kim.altintop@gmail.com
8 | -- Stability : experimental
9 | -- Portability : non-portable
10 | --
11 | -- High-level, "Data.List"-like, streaming interface to
12 | -- "Database.LevelDB.Iterator".
13 | --
14 | -- This module contains types and functions to construct 'Stream's from
15 | -- 'Database.LevelDB.Iterator.Iterator's, and re-exports the functions operating
16 | -- on 'Stream's from "Data.Stream.Monadic".
17 | --
18 | -- __Note__ that most of the functions from the latter module are
19 | -- (intentionally) conflicting with the "Prelude", it is thus recommended to
20 | -- import this module qualified:
21 | --
22 | -- > import Database.LevelDB -- or Database.LevelDB.Base
23 | -- > import qualified Database.LevelDB.Streaming as S
24 |
25 | module Database.LevelDB.Streaming
26 | ( KeyRange (..)
27 | , Direction (..)
28 | , Key
29 | , Value
30 | , Entry
31 |
32 | -- * Constructing streams
33 | -- $caveats
34 | , keySlice
35 | , entrySlice
36 |
37 | -- * Re-exports
38 | , module Data.Stream.Monadic
39 | )
40 | where
41 |
42 | import Control.Applicative
43 | import Control.Monad.IO.Class
44 | import Data.ByteString (ByteString)
45 | import Data.Stream.Monadic
46 | import Database.LevelDB.Base
47 |
48 | import Prelude hiding (drop, filter, foldl, map, mapM, mapM_, take)
49 |
50 |
51 | data KeyRange
52 | = KeyRange { start :: !ByteString
53 | , end :: ByteString -> Ordering
54 | }
55 | | AllKeys
56 |
57 | data Direction = Asc | Desc
58 | deriving Show
59 |
60 | type Key = ByteString
61 | type Value = ByteString
62 | type Entry = (Key, Value)
63 |
64 |
65 | -- $caveats
66 | -- Caveats:
67 | --
68 | -- * remember that 'Iterator's are /not/ threadsafe
69 | -- * consider that traversing a 'Stream' mutates the underlying 'Iterator', so
70 | -- the above applies to the 'Stream' as well
71 | -- * because of the destructive update semantics of 'Iterator's, the following
72 | -- example will (perhaps obviously) /not/ work as expected:
73 | --
74 | -- > withIter db def $ \ i ->
75 | -- > toList $ zip (keySlice i AllKeys Asc) (keySlice i AllKeys Desc)
76 | --
77 | -- However, the following /will/ work:
78 | --
79 | -- > withIter db def $ \ i ->
80 | -- > foldl (+) 0 . map (*2) . map ByteString.length $ keySlice i AllKeys Asc
81 | --
82 | -- Here, fusion ensures the key slice is traversed only once, while the next
83 | -- example will incur rewinding the 'Iterator' and traversing it a second time:
84 | --
85 | -- > withIter db def $ \ i ->
86 | -- > let slice = keySlice i AllKeys Asc
87 | -- > count f = foldl' (\ c k -> c + f k) 0
88 | -- > in liftM2 (+) (count ByteString.length slice) (count (const 1) slice)
89 | --
90 | -- To summarise: it is recommended to always create 'Stream's with their own
91 | -- exclusive 'Iterator', and to not share them across threads.
92 |
93 | -- | Create a 'Stream' which yields only the keys of the given 'KeyRange' (in
94 | -- the given 'Direction').
95 | keySlice :: (Applicative m, MonadIO m)
96 | => Iterator
97 | -> KeyRange
98 | -> Direction
99 | -> Stream m Key
100 | keySlice i (KeyRange s e) d = Stream next (iterSeek i s >> pure i)
101 | where
102 | next it = do
103 | key <- iterKey it
104 | case key of
105 | Nothing -> pure Done
106 | Just k -> case d of
107 | Asc | e k < GT -> Yield k <$> (iterNext it >> pure it)
108 | | otherwise -> pure Done
109 | Desc | e k > LT -> Yield k <$> (iterPrev it >> pure it)
110 | | otherwise -> pure Done
111 |
112 | keySlice i AllKeys Asc = Stream next (iterFirst i >> pure i)
113 | where
114 | next it = iterKey it
115 | >>= maybe (pure Done) (\ k -> Yield k <$> (iterNext it >> pure it))
116 |
117 | keySlice i AllKeys Desc = Stream next (iterLast i >> pure i)
118 | where
119 | next it = iterKey it
120 | >>= maybe (pure Done) (\ k -> Yield k <$> (iterPrev it >> pure it))
121 |
122 | -- | Create a 'Stream' which yields key/value pairs of the given 'KeyRange' (in
123 | -- the given 'Direction').
124 | entrySlice :: (Applicative m, MonadIO m)
125 | => Iterator
126 | -> KeyRange
127 | -> Direction
128 | -> Stream m Entry
129 | entrySlice i (KeyRange s e) d = Stream next (iterSeek i s >> pure i)
130 | where
131 | next it = do
132 | entry <- iterEntry it
133 | case entry of
134 | Nothing -> pure Done
135 | Just x@(!k,_) -> case d of
136 | Asc | e k < GT -> Yield x <$> (iterNext it >> pure it)
137 | | otherwise -> pure Done
138 | Desc | e k > LT -> Yield x <$> (iterPrev it >> pure it)
139 | | otherwise -> pure Done
140 |
141 | entrySlice i AllKeys Asc = Stream next (iterFirst i >> pure i)
142 | where
143 | next it = iterEntry it
144 | >>= maybe (pure Done) (\ x -> Yield x <$> (iterNext it >> pure it))
145 |
146 | entrySlice i AllKeys Desc = Stream next (iterLast i >> pure i)
147 | where
148 | next it = iterEntry it
149 | >>= maybe (pure Done) (\ x -> Yield x <$> (iterPrev it >> pure it))
150 |
--------------------------------------------------------------------------------
/src/Database/LevelDB/Types.hs:
--------------------------------------------------------------------------------
1 | -- |
2 | -- Module : Database.LevelDB.Types
3 | -- Copyright : (c) 2012-2013 The leveldb-haskell Authors
4 | -- License : BSD3
5 | -- Maintainer : kim.altintop@gmail.com
6 | -- Stability : experimental
7 | -- Portability : non-portable
8 | --
9 |
10 | module Database.LevelDB.Types
11 | ( BatchOp (..)
12 | , BloomFilter (..)
13 | , Comparator (..)
14 | , Compression (..)
15 | , FilterPolicy (..)
16 | , Options (..)
17 | , Property (..)
18 | , ReadOptions (..)
19 | , Snapshot (..)
20 | , WriteBatch
21 | , WriteOptions (..)
22 |
23 | , defaultOptions
24 | , defaultReadOptions
25 | , defaultWriteOptions
26 | )
27 | where
28 |
29 | import Data.ByteString (ByteString)
30 | import Data.Default
31 | import Foreign
32 |
33 | import Database.LevelDB.C
34 |
35 | -- | Snapshot handle
36 | newtype Snapshot = Snapshot SnapshotPtr deriving (Eq)
37 |
38 | -- | Compression setting
39 | data Compression = NoCompression | Snappy deriving (Eq, Show)
40 |
41 | -- | User-defined comparator
42 | newtype Comparator = Comparator (ByteString -> ByteString -> Ordering)
43 |
44 | -- | User-defined filter policy
45 | data FilterPolicy = FilterPolicy
46 | { fpName :: String
47 | , createFilter :: [ByteString] -> ByteString
48 | , keyMayMatch :: ByteString -> ByteString -> Bool
49 | }
50 |
51 | -- | Represents the built-in Bloom Filter
52 | newtype BloomFilter = BloomFilter FilterPolicyPtr
53 |
54 | -- | Options when opening a database
55 | data Options = Options
56 | { blockRestartInterval :: !Int
57 | -- ^ Number of keys between restart points for delta encoding of keys.
58 | --
59 | -- This parameter can be changed dynamically. Most clients should leave
60 | -- this parameter alone.
61 | --
62 | -- Default: 16
63 | , blockSize :: !Int
64 | -- ^ Approximate size of user data packed per block.
65 | --
66 | -- Note that the block size specified here corresponds to uncompressed
67 | -- data. The actual size of the unit read from disk may be smaller if
68 | -- compression is enabled.
69 | --
70 | -- This parameter can be changed dynamically.
71 | --
72 | -- Default: 4k
73 | , cacheSize :: !Int
74 | -- ^ Control over blocks (user data is stored in a set of blocks, and a
75 | -- block is the unit of reading from disk).
76 | --
77 | -- If > 0, use the specified cache (in bytes) for blocks. If 0, leveldb
78 | -- will automatically create and use an 8MB internal cache.
79 | --
80 | -- Default: 0
81 | , comparator :: !(Maybe Comparator)
82 | -- ^ Comparator used to defined the order of keys in the table.
83 | --
84 | -- If 'Nothing', the default comparator is used, which uses lexicographic
85 | -- bytes-wise ordering.
86 | --
87 | -- NOTE: the client must ensure that the comparator supplied here has the
88 | -- same name and orders keys /exactly/ the same as the comparator provided
89 | -- to previous open calls on the same DB.
90 | --
91 | -- Default: Nothing
92 | , compression :: !Compression
93 | -- ^ Compress blocks using the specified compression algorithm.
94 | --
95 | -- This parameter can be changed dynamically.
96 | --
97 | -- Default: 'Snappy'
98 | , createIfMissing :: !Bool
99 | -- ^ If true, the database will be created if it is missing.
100 | --
101 | -- Default: False
102 | , errorIfExists :: !Bool
103 | -- ^ It true, an error is raised if the database already exists.
104 | --
105 | -- Default: False
106 | , maxOpenFiles :: !Int
107 | -- ^ Number of open files that can be used by the DB.
108 | --
109 | -- You may need to increase this if your database has a large working set
110 | -- (budget one open file per 2MB of working set).
111 | --
112 | -- Default: 1000
113 | , paranoidChecks :: !Bool
114 | -- ^ If true, the implementation will do aggressive checking of the data
115 | -- it is processing and will stop early if it detects any errors.
116 | --
117 | -- This may have unforeseen ramifications: for example, a corruption of
118 | -- one DB entry may cause a large number of entries to become unreadable
119 | -- or for the entire DB to become unopenable.
120 | --
121 | -- Default: False
122 | , writeBufferSize :: !Int
123 | -- ^ Amount of data to build up in memory (backed by an unsorted log on
124 | -- disk) before converting to a sorted on-disk file.
125 | --
126 | -- Larger values increase performance, especially during bulk loads. Up to
127 | -- to write buffers may be held in memory at the same time, so you may
128 | -- with to adjust this parameter to control memory usage. Also, a larger
129 | -- write buffer will result in a longer recovery time the next time the
130 | -- database is opened.
131 | --
132 | -- Default: 4MB
133 | , filterPolicy :: !(Maybe (Either BloomFilter FilterPolicy))
134 | }
135 |
136 | defaultOptions :: Options
137 | defaultOptions = Options
138 | { blockRestartInterval = 16
139 | , blockSize = 4096
140 | , cacheSize = 0
141 | , comparator = Nothing
142 | , compression = Snappy
143 | , createIfMissing = False
144 | , errorIfExists = False
145 | , maxOpenFiles = 1000
146 | , paranoidChecks = False
147 | , writeBufferSize = 4 `shift` 20
148 | , filterPolicy = Nothing
149 | }
150 |
151 | instance Default Options where
152 | def = defaultOptions
153 |
154 | -- | Options for write operations
155 | data WriteOptions = WriteOptions
156 | { sync :: !Bool
157 | -- ^ If true, the write will be flushed from the operating system buffer
158 | -- cache (by calling WritableFile::Sync()) before the write is considered
159 | -- complete. If this flag is true, writes will be slower.
160 | --
161 | -- If this flag is false, and the machine crashes, some recent writes may
162 | -- be lost. Note that if it is just the process that crashes (i.e., the
163 | -- machine does not reboot), no writes will be lost even if sync==false.
164 | --
165 | -- In other words, a DB write with sync==false has similar crash semantics
166 | -- as the "write()" system call. A DB write with sync==true has similar
167 | -- crash semantics to a "write()" system call followed by "fsync()".
168 | --
169 | -- Default: False
170 | } deriving (Eq, Show)
171 |
172 | defaultWriteOptions :: WriteOptions
173 | defaultWriteOptions = WriteOptions { sync = False }
174 |
175 | instance Default WriteOptions where
176 | def = defaultWriteOptions
177 |
178 | -- | Options for read operations
179 | data ReadOptions = ReadOptions
180 | { verifyCheckSums :: !Bool
181 | -- ^ If true, all data read from underlying storage will be verified
182 | -- against corresponding checksums.
183 | --
184 | -- Default: False
185 | , fillCache :: !Bool
186 | -- ^ Should the data read for this iteration be cached in memory? Callers
187 | -- may with to set this field to false for bulk scans.
188 | --
189 | -- Default: True
190 | , useSnapshot :: !(Maybe Snapshot)
191 | -- ^ If 'Just', read as of the supplied snapshot (which must belong to the
192 | -- DB that is being read and which must not have been released). If
193 | -- 'Nothing', use an implicit snapshot of the state at the beginning of
194 | -- this read operation.
195 | --
196 | -- Default: Nothing
197 | } deriving (Eq)
198 |
199 | defaultReadOptions :: ReadOptions
200 | defaultReadOptions = ReadOptions
201 | { verifyCheckSums = False
202 | , fillCache = True
203 | , useSnapshot = Nothing
204 | }
205 |
206 | instance Default ReadOptions where
207 | def = defaultReadOptions
208 |
209 | type WriteBatch = [BatchOp]
210 |
211 | -- | Batch operation
212 | data BatchOp = Put ByteString ByteString | Del ByteString
213 | deriving (Eq, Show)
214 |
215 | -- | Properties exposed by LevelDB
216 | data Property = NumFilesAtLevel Int | Stats | SSTables
217 | deriving (Eq, Show)
218 |
--------------------------------------------------------------------------------
/test/Main.hs:
--------------------------------------------------------------------------------
1 | module Main (main) where
2 |
3 | import qualified Test.Streaming as Streaming
4 | import Test.Tasty
5 |
6 |
7 | main :: IO ()
8 | main = defaultMain $ testGroup "Tests" [ Streaming.tests ]
9 |
--------------------------------------------------------------------------------
/test/Test/Streaming.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns #-}
2 | {-# LANGUAGE OverloadedStrings #-}
3 |
4 | {-# OPTIONS_GHC -fno-warn-orphans #-}
5 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
6 |
7 | module Test.Streaming (tests) where
8 |
9 | import Control.Applicative hiding (empty)
10 | import Control.Monad (liftM2, foldM)
11 | import Control.Monad.Catch
12 | import Control.Monad.Identity
13 | import Control.Monad.IO.Class
14 | import qualified Data.ByteString as BS
15 | import Data.ByteString.Char8 (ByteString, singleton, unpack)
16 | import Data.Default
17 | import Data.Foldable (foldMap)
18 | import Data.List hiding (singleton)
19 | import Data.Monoid
20 | import Database.LevelDB.Base
21 | import Database.LevelDB.Internal (unsafeClose)
22 | import qualified Database.LevelDB.Streaming as S
23 | import System.Directory
24 | import System.IO.Temp
25 | import Test.QuickCheck
26 | import Test.QuickCheck.Monadic
27 | import Test.Tasty
28 | import Test.Tasty.QuickCheck
29 |
30 | import Text.Show.Functions () -- Show instance for a -> b
31 |
32 | type Prop = Test.Tasty.QuickCheck.Property
33 |
34 | data Range' = Range' S.Direction Char Char
35 | deriving Show
36 |
37 | asKeyRange :: Range' -> S.KeyRange
38 | asKeyRange (Range' _ s e) =
39 | let s' = singleton s
40 | e' = singleton e
41 | in S.KeyRange s' (`compare` e')
42 |
43 | asList :: Range' -> [ByteString]
44 | asList (Range' _ '{' '}') = []
45 | asList (Range' S.Asc !s !e)
46 | | s > 'Z' = []
47 | | e > 'Z' = map singleton [s..'Z']
48 | | otherwise = map singleton [s..e]
49 | asList (Range' S.Desc !s !e)
50 | | s > 'Z' = reverse . map singleton $ [e..'Z']
51 | | e > 'Z' = []
52 | | otherwise = reverse . map singleton $ [e..s]
53 |
54 | asAssocList :: Range' -> [(ByteString, ByteString)]
55 | asAssocList r = let r' = asList r in zip r' r'
56 |
57 | mkKeySlice :: (Applicative m, MonadIO m) => Range' -> Iterator -> S.Stream m S.Key
58 | mkKeySlice r@(Range' d _ _) i = S.keySlice i (asKeyRange r) d
59 |
60 | mkEntrySlice :: (Applicative m, MonadIO m) => Range' -> Iterator -> S.Stream m S.Entry
61 | mkEntrySlice r@(Range' d _ _) i = S.entrySlice i (asKeyRange r) d
62 |
63 |
64 | instance Arbitrary Range' where
65 | arbitrary = do
66 | d <- arbitrary
67 | oneof [ empty d, nonempty d ]
68 | where
69 | nonempty d = do
70 | s <- elements ['A'..'Z']
71 | e <- case d of
72 | S.Asc -> arbitrary `suchThat` (<= 'Z') `suchThat` (>= s)
73 | S.Desc -> arbitrary `suchThat` (>= 'A') `suchThat` (<= s)
74 | return $ Range' d s e
75 |
76 | empty d = return $ Range' d '{' '}'
77 |
78 | instance Arbitrary S.Direction where
79 | arbitrary = elements [ S.Asc, S.Desc ]
80 |
81 | instance Arbitrary ByteString where
82 | arbitrary = BS.pack <$> arbitrary
83 |
84 | instance CoArbitrary ByteString where
85 | coarbitrary = coarbitrary . unpack
86 |
87 | data Rs = Rs DB FilePath
88 |
89 | tests :: TestTree
90 | tests = withResource initDB destroyDB $ \ rs ->
91 | testGroup "List-like Iterators"
92 | [ testGroup "conversions"
93 | [ testProperty "toList . fromList = id" prop_fromList
94 | ]
95 | , testGroup "basic functions"
96 | [ testProperty "head" (prop_head rs)
97 | , testProperty "append" (prop_append rs)
98 | , testProperty "cons" (prop_cons rs)
99 | , testProperty "snoc" (prop_snoc rs)
100 | , testProperty "last" (prop_last rs)
101 | , testProperty "tail" (prop_tail rs)
102 | , testProperty "init" (prop_init rs)
103 | , testProperty "null" (prop_null rs)
104 | , testProperty "length" (prop_length rs)
105 | ]
106 | , testGroup "transformations"
107 | [ testProperty "map" (prop_map rs)
108 | , testProperty "mapM" (prop_mapM rs)
109 | , testProperty "reverse" (prop_reverse rs)
110 | , testProperty "intersperse" (prop_intersperse rs)
111 | , testProperty "intercalate" prop_intercalate
112 | ]
113 | , testGroup "searching"
114 | [ testProperty "elem" (prop_elem rs)
115 | , testProperty "notElem" (prop_notElem rs)
116 | , testProperty "lookup" (prop_lookup rs)
117 | , testProperty "find" (prop_find rs)
118 | , testProperty "filter" (prop_filter rs)
119 | ]
120 | , testGroup "folds"
121 | [ testProperty "foldl" (prop_foldl rs)
122 | , testProperty "foldl'" (prop_foldl' rs)
123 | , testProperty "foldr" (prop_foldr rs)
124 | , testProperty "foldMap" (prop_foldMap rs)
125 | , testProperty "foldM" (prop_foldM rs)
126 | ]
127 | , testGroup "special folds"
128 | [ testProperty "concat" prop_concat
129 | , testProperty "concatMap" (prop_concatMap rs)
130 | , testProperty "and" prop_and
131 | , testProperty "or" prop_or
132 | , testProperty "any" prop_any
133 | , testProperty "all" prop_all
134 | , testProperty "sum" prop_sum
135 | , testProperty "product" prop_product
136 | ]
137 | , testGroup "scans"
138 | [ testProperty "scanl" (prop_scanl rs)
139 | , testProperty "last (scanl f z xs) == foldl f z xs" (prop_scanl_last rs)
140 | ]
141 | , testGroup "infinite streams"
142 | [ testProperty "iterate" prop_iterate
143 | , testProperty "repeat" prop_repeat
144 | , testProperty "replicate" prop_replicate
145 | , testProperty "cycle" prop_cycle
146 | ]
147 | , testGroup "unfolding"
148 | [ testProperty "unfoldr" prop_unfoldr
149 | ]
150 | , testGroup "predicates"
151 | [ testProperty "isPrefixOf" (prop_isPrefixOf rs)
152 | , testProperty "isSuffixOf" (prop_isSuffixOf rs)
153 | ]
154 | , testGroup "substreams"
155 | [ testProperty "take" (prop_take rs)
156 | , testProperty "drop" (prop_drop rs)
157 | , testProperty "splitAt" (prop_splitAt rs)
158 | , testProperty "takeWhile" (prop_takeWhile rs)
159 | , testProperty "dropWhile" (prop_dropWhile rs)
160 | , testProperty "span" (prop_span rs)
161 | , testProperty "break" (prop_break rs)
162 | ]
163 | , testGroup "zipping and unzipping"
164 | [ testProperty "zip" (prop_zip rs)
165 | , testProperty "zip3" (prop_zip3 rs)
166 | , testProperty "zip4" (prop_zip4 rs)
167 | , testProperty "zipWith" (prop_zipWith rs)
168 | , testProperty "zipWith3" (prop_zipWith3 rs)
169 | , testProperty "zipWith4" (prop_zipWith4 rs)
170 | , testProperty "unzip" (prop_unzip rs)
171 | , testProperty "unzip3" (prop_unzip3 rs)
172 | , testProperty "unzip4" (prop_unzip4 rs)
173 | ]
174 | , testGroup "generalized functions"
175 | [ testProperty "deleteBy" (prop_deleteBy rs)
176 | , testProperty "insertBy" (prop_insertBy rs)
177 | ]
178 | ]
179 | where
180 | initDB = do
181 | tmp <- getTemporaryDirectory
182 | dir <- createTempDirectory tmp "leveldb-streaming-tests"
183 | db <- open dir defaultOptions { createIfMissing = True }
184 | write db def
185 | . map ( \ c -> let c' = singleton c in Put c' c')
186 | $ ['A'..'Z']
187 | return $ Rs db dir
188 |
189 | destroyDB (Rs db dir) = unsafeClose db `finally` destroy dir defaultOptions
190 |
191 |
192 | with_iter rs f = liftIO $ rs >>= \ (Rs db _) -> withIter db def f
193 | run_prop rs !a b = monadicIO $ with_iter rs b >>= assert . (a ==)
194 |
195 |
196 | --
197 | -- conversions
198 | --
199 |
200 | prop_fromList :: [ByteString] -> Prop
201 | prop_fromList xs = monadic runIdentity $
202 | assert . (xs ==) =<< (S.toList . S.fromList $ xs)
203 |
204 | --
205 | -- basic functions
206 | --
207 |
208 | prop_append rs range1 range2 = monadicIO $
209 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> b i1 i2)
210 | >>= assert . (a ==)
211 | where
212 | a = asList range1 ++ asList range2
213 | b i1 i2 = S.toList $ S.append (mkKeySlice range1 i1) (mkKeySlice range2 i2)
214 |
215 | prop_cons rs range w = run_prop rs a b
216 | where
217 | a = w : asList range
218 | b = S.toList . S.cons w . mkKeySlice range
219 |
220 | prop_snoc rs range y = run_prop rs a b
221 | where
222 | a = asList range ++ [y]
223 | b = S.toList . (`S.snoc` y) . mkKeySlice range
224 |
225 | prop_head rs range = run_prop rs a b
226 | where
227 | a = case asList range of
228 | [] -> Nothing
229 | xs -> Just . head $ xs
230 | b = S.head . mkKeySlice range
231 |
232 | prop_last rs range = run_prop rs a b
233 | where
234 | a = case asList range of
235 | [] -> Nothing
236 | xs -> Just . last $ xs
237 | b = S.last . mkKeySlice range
238 |
239 | prop_tail rs range = run_prop rs a b
240 | where
241 | a = case asList range of
242 | [] -> []
243 | xs -> tail xs
244 | b = S.toList . S.tail . mkKeySlice range
245 |
246 | prop_init rs range = run_prop rs a b
247 | where
248 | a = case asList range of
249 | [] -> []
250 | xs -> init xs
251 | b = S.toList . S.init . mkKeySlice range
252 |
253 | prop_null rs range = run_prop rs a b
254 | where
255 | a = null $ asList range
256 | b = S.null . mkKeySlice range
257 |
258 | prop_length rs range = run_prop rs a b
259 | where
260 | a = length $ asList range
261 | b = S.length . mkKeySlice range
262 |
263 |
264 | --
265 | -- transformations
266 | --
267 |
268 | prop_map :: IO Rs -> Range' -> (ByteString -> Int) -> Prop
269 | prop_map rs range f = run_prop rs a b
270 | where
271 | a = map f $ asList range
272 | b = S.toList . S.map f . mkKeySlice range
273 |
274 | prop_mapM rs range = monadicIO . with_iter rs $ liftM2 (===) a . b
275 | where
276 | a = mapM f $ asList range
277 | b = S.toList . S.mapM f . mkKeySlice range
278 |
279 | f = return . BS.length
280 |
281 | prop_reverse rs range = run_prop rs a b
282 | where
283 | a = reverse $ asList range
284 | b = (>>= S.toList) . S.reverse . mkKeySlice range
285 |
286 | prop_intersperse rs range x = run_prop rs a b
287 | where
288 | a = intersperse x $ asList range
289 | b = S.toList . S.intersperse x . mkKeySlice range
290 |
291 | prop_intercalate :: [Int] -> [[Int]] -> Prop
292 | prop_intercalate xs xss = monadic runIdentity $! assert . (a ==) =<< b
293 | where
294 | a = intercalate xs xss
295 | b = S.toList $ S.intercalate (S.fromList xs) (S.fromList xss)
296 |
297 | --
298 | -- folds
299 | --
300 |
301 | prop_foldl rs range f = run_prop rs a b
302 | where
303 | a = foldl f BS.empty $ asList range
304 | b = S.foldl f BS.empty . mkKeySlice range
305 |
306 | prop_foldl' rs range f = run_prop rs a b
307 | where
308 | a = foldl' f BS.empty $ asList range
309 | b = S.foldl' f BS.empty . mkKeySlice range
310 |
311 | prop_foldr rs range f = run_prop rs a b
312 | where
313 | a = foldr f BS.empty $ asList range
314 | b = S.foldr f BS.empty . mkKeySlice range
315 |
316 | prop_foldMap :: IO Rs -> Range' -> (ByteString -> ByteString) -> Prop
317 | prop_foldMap rs range f = run_prop rs a b
318 | where
319 | a = foldMap f $ asList range
320 | b = S.foldMap f . mkKeySlice range
321 |
322 | prop_foldM rs range = monadicIO . with_iter rs $ \ i -> do
323 | a' <- a
324 | b' <- b i
325 | return $! a' === b'
326 | where
327 | a = foldM f BS.empty $ asList range
328 | b = S.foldM f BS.empty . mkKeySlice range
329 |
330 | f z x = return $ z <> x
331 |
332 | -- TODO: foldM_ ?
333 |
334 |
335 | --
336 | -- special folds
337 | --
338 |
339 | prop_concat :: [[Int]] -> Prop
340 | prop_concat xss = monadic runIdentity $! assert . (a ==) =<< b
341 | where
342 | a = concat xss
343 | b = S.toList . S.concat . S.fromList $ xss
344 |
345 | prop_concatMap rs range = run_prop rs a b
346 | where
347 | a = concatMap ( replicate 10) $ asList range
348 | b = S.toList . S.concatMap (S.replicate 10) . mkKeySlice range
349 |
350 | prop_and ts = monadic runIdentity $! assert . (a ==) =<< b
351 | where
352 | a = and ts
353 | b = S.and . S.fromList $ ts
354 |
355 | prop_or ts = monadic runIdentity $! assert . (a ==) =<< b
356 | where
357 | a = or ts
358 | b = S.or . S.fromList $ ts
359 |
360 | prop_any :: (Int -> Bool) -> [Int] -> Prop
361 | prop_any p xs = monadic runIdentity $! assert . (a ==) =<< b
362 | where
363 | a = any p xs
364 | b = S.any p . S.fromList $ xs
365 |
366 | prop_all :: (Int -> Bool) -> [Int] -> Prop
367 | prop_all p xs = monadic runIdentity $! assert . (a ==) =<< b
368 | where
369 | a = all p xs
370 | b = S.all p . S.fromList $ xs
371 |
372 | prop_sum :: [Int] -> Prop
373 | prop_sum xs = monadic runIdentity $! assert . (a ==) =<< b
374 | where
375 | a = sum xs
376 | b = S.sum . S.fromList $ xs
377 |
378 | prop_product :: [Int] -> Prop
379 | prop_product xs = monadic runIdentity $! assert . (a ==) =<< b
380 | where
381 | a = product xs
382 | b = S.product . S.fromList $ xs
383 |
384 | --
385 | -- scans
386 | --
387 |
388 | prop_scanl rs f range = run_prop rs a b
389 | where
390 | a = scanl f BS.empty $ asList range
391 | b = S.toList . S.scanl f BS.empty . mkKeySlice range
392 |
393 | prop_scanl_last rs f range = monadicIO $ do
394 | (a',b') <- with_iter rs $ \ i -> liftM2 (,) (a i) (b i)
395 | assert $ a' == Just b'
396 | where
397 | a = S.last . S.scanl f BS.empty . mkKeySlice range
398 | b = S.foldl f BS.empty . mkKeySlice range
399 |
400 | --
401 | -- infinite streams
402 | --
403 |
404 | prop_iterate :: (Int -> Int) -> Int -> Prop
405 | prop_iterate f x = monadic runIdentity $! assert . (a ==) =<< b
406 | where
407 | a = take 100 $ iterate f x
408 | b = S.toList . S.take 100 $ S.iterate f x
409 |
410 | prop_repeat :: Int -> Prop
411 | prop_repeat x = monadic runIdentity $! assert . (a ==) =<< b
412 | where
413 | a = take 100 $ repeat x
414 | b = S.toList . S.take 100 $ S.repeat x
415 |
416 | prop_replicate :: Int -> Int -> Prop
417 | prop_replicate n x = monadic runIdentity $! assert . (a ==) =<< b
418 | where
419 | a = replicate n x
420 | b = S.toList $ S.replicate n x
421 |
422 | prop_cycle :: NonNegative Int -> Prop
423 | prop_cycle (NonNegative !n) = monadic runIdentity $! assert . (a ==) =<< b
424 | where
425 | a | n == 0 = xs
426 | | otherwise = take (n*2) . cycle $ xs
427 |
428 | b = S.toList . S.take (n*2) . S.cycle . S.fromList $ xs
429 |
430 | xs :: [Int]
431 | xs | n == 0 = []
432 | | otherwise = [0..(n `div` 2)]
433 |
434 | --
435 | -- unfolding
436 | --
437 |
438 | prop_unfoldr :: (Int -> Maybe (Int, Int)) -> Int -> Prop
439 | prop_unfoldr f z = monadic runIdentity $! assert . (a ==) =<< b
440 | where
441 | a = take 100 $ unfoldr f z
442 | b = S.toList . S.take 100 $ S.unfoldr f z
443 |
444 | --
445 | -- predicates
446 | --
447 |
448 | prop_isPrefixOf rs range1 range2 = monadicIO $
449 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> b i1 i2)
450 | >>= assert . (a ==)
451 | where
452 | a = asList range1 `isPrefixOf` asList range2
453 | b i1 i2 = mkKeySlice range1 i1 `S.isPrefixOf` mkKeySlice range2 i2
454 |
455 |
456 | prop_isSuffixOf rs range1 range2 = monadicIO $
457 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> b i1 i2)
458 | >>= assert . (a ==)
459 | where
460 | a = asList range1 `isSuffixOf` asList range2
461 | b i1 i2 = mkKeySlice range1 i1 `S.isSuffixOf` mkKeySlice range2 i2
462 |
463 | --
464 | -- searching
465 | --
466 |
467 | prop_elem rs range x = run_prop rs a b
468 | where
469 | a = x `elem` asList range
470 | b = (x `S.elem`) . mkKeySlice range
471 |
472 | prop_notElem rs range x = run_prop rs a b
473 | where
474 | a = x `notElem` asList range
475 | b = (x `S.notElem`) . mkKeySlice range
476 |
477 | prop_lookup rs range k = run_prop rs a b
478 | where
479 | a = lookup k $ asAssocList range
480 | b = S.lookup k . mkEntrySlice range
481 |
482 | prop_find rs range f = run_prop rs a b
483 | where
484 | a = find f $ asList range
485 | b = S.find f . mkKeySlice range
486 |
487 | prop_filter rs range f = run_prop rs a b
488 | where
489 | a = filter f $ asList range
490 | b = S.toList . S.filter f . mkKeySlice range
491 |
492 | --
493 | -- substreams
494 | --
495 |
496 | prop_take rs range i = run_prop rs a b
497 | where
498 | a = take i $ asList range
499 | b = S.toList . S.take i . mkKeySlice range
500 |
501 | prop_drop rs range i = run_prop rs a b
502 | where
503 | a = drop i $ asList range
504 | b = S.toList . S.drop i . mkKeySlice range
505 |
506 | prop_splitAt rs range i = run_prop rs a b
507 | where
508 | a = splitAt i $ asList range
509 | b = toLists . S.splitAt i . mkKeySlice range
510 |
511 | prop_takeWhile rs range f = run_prop rs a b
512 | where
513 | a = takeWhile f $ asList range
514 | b = S.toList . S.takeWhile f . mkKeySlice range
515 |
516 | prop_dropWhile rs range f = run_prop rs a b
517 | where
518 | a = dropWhile f $ asList range
519 | b = S.toList . S.dropWhile f . mkKeySlice range
520 |
521 | prop_span rs range p = run_prop rs a b
522 | where
523 | a = span p $ asList range
524 | b = toLists . S.span p . mkKeySlice range
525 |
526 | prop_break rs range p = run_prop rs a b
527 | where
528 | a = break p $ asList range
529 | b = toLists . S.break p . mkKeySlice range
530 |
531 | --
532 | -- zipping and unzipping
533 | --
534 |
535 | prop_zip rs range1 range2 = monadicIO $
536 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> b i1 i2)
537 | >>= assert . (a ==)
538 | where
539 | a = zip (asList range1) (asList range2)
540 | b i1 i2 = S.toList $ S.zip (mkKeySlice range1 i1) (mkKeySlice range2 i2)
541 |
542 | prop_zip3 rs range1 range2 range3 = monadicIO $
543 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> with_iter rs $ \ i3 -> b i1 i2 i3)
544 | >>= assert . (a ==)
545 | where
546 | a = zip3 (asList range1) (asList range2) (asList range3)
547 | b i1 i2 i3 = S.toList $ S.zip3 (mkKeySlice range1 i1) (mkKeySlice range2 i2) (mkKeySlice range3 i3)
548 |
549 | prop_zip4 rs range1 range2 range3 range4 = monadicIO $
550 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> with_iter rs $ \ i3 -> with_iter rs $ \ i4 -> b i1 i2 i3 i4)
551 | >>= assert . (a ==)
552 | where
553 | a = zip4 (asList range1) (asList range2) (asList range3) (asList range4)
554 | b i1 i2 i3 i4 = S.toList $ S.zip4 (mkKeySlice range1 i1) (mkKeySlice range2 i2) (mkKeySlice range3 i3) (mkKeySlice range4 i4)
555 |
556 | prop_zipWith :: IO Rs
557 | -> (ByteString -> ByteString -> (ByteString,ByteString))
558 | -> Range'
559 | -> Range'
560 | -> Prop
561 | prop_zipWith rs f range1 range2 = monadicIO $
562 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> b i1 i2)
563 | >>= assert . (a ==)
564 | where
565 | a = zipWith f (asList range1) (asList range2)
566 | b i1 i2 = S.toList $ S.zipWith f (mkKeySlice range1 i1) (mkKeySlice range2 i2)
567 |
568 | prop_zipWith3 :: IO Rs
569 | -> (ByteString -> ByteString -> ByteString -> (ByteString, ByteString,ByteString))
570 | -> Range'
571 | -> Range'
572 | -> Range'
573 | -> Prop
574 | prop_zipWith3 rs f range1 range2 range3 = monadicIO $
575 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> with_iter rs $ \ i3 -> b i1 i2 i3)
576 | >>= assert . (a ==)
577 | where
578 | a = zipWith3 f (asList range1) (asList range2) (asList range3)
579 | b i1 i2 i3 = S.toList $ S.zipWith3 f (mkKeySlice range1 i1) (mkKeySlice range2 i2) (mkKeySlice range3 i3)
580 |
581 | prop_zipWith4 :: IO Rs
582 | -> (ByteString -> ByteString -> ByteString -> ByteString -> (ByteString, ByteString, ByteString,ByteString))
583 | -> Range'
584 | -> Range'
585 | -> Range'
586 | -> Range'
587 | -> Prop
588 | prop_zipWith4 rs f range1 range2 range3 range4 = monadicIO $
589 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> with_iter rs $ \ i3 -> with_iter rs $ \ i4 -> b i1 i2 i3 i4)
590 | >>= assert . (a ==)
591 | where
592 | a = zipWith4 f (asList range1) (asList range2) (asList range3) (asList range4)
593 | b i1 i2 i3 i4 = S.toList $ S.zipWith4 f (mkKeySlice range1 i1) (mkKeySlice range2 i2) (mkKeySlice range3 i3) (mkKeySlice range4 i4)
594 |
595 | prop_unzip rs range1 range2 = monadicIO $
596 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> b i1 i2)
597 | >>= assert . (a ==)
598 | where
599 | a = unzip $ zip (asList range1) (asList range2)
600 | b i1 i2 = S.unzip $ S.zip (mkKeySlice range1 i1) (mkKeySlice range2 i2)
601 |
602 | prop_unzip3 rs range1 range2 range3 = monadicIO $
603 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> with_iter rs $ \ i3 -> b i1 i2 i3)
604 | >>= assert . (a ==)
605 | where
606 | a = unzip3 $ zip3 (asList range1) (asList range2) (asList range3)
607 | b i1 i2 i3 = S.unzip3 $ S.zip3 (mkKeySlice range1 i1) (mkKeySlice range2 i2) (mkKeySlice range3 i3)
608 |
609 | prop_unzip4 rs range1 range2 range3 range4 = monadicIO $
610 | (with_iter rs $ \ i1 -> with_iter rs $ \ i2 -> with_iter rs $ \ i3 -> with_iter rs $ \ i4 -> b i1 i2 i3 i4)
611 | >>= assert . (a ==)
612 | where
613 | a = unzip4 $ zip4 (asList range1) (asList range2) (asList range3) (asList range4)
614 | b i1 i2 i3 i4 = S.unzip4 $ S.zip4 (mkKeySlice range1 i1) (mkKeySlice range2 i2) (mkKeySlice range3 i3) (mkKeySlice range4 i4)
615 |
616 | --
617 | -- generalized
618 | --
619 |
620 | prop_deleteBy rs eq x range = run_prop rs a b
621 | where
622 | a = deleteBy eq x $ asList range
623 | b = S.toList . S.deleteBy eq x . mkKeySlice range
624 |
625 | prop_insertBy rs cmp x range = run_prop rs a b
626 | where
627 | a = insertBy cmp x $ asList range
628 | b = S.toList . S.insertBy cmp x . mkKeySlice range
629 |
630 | --
631 | -- Helpers
632 | --
633 |
634 | toLists :: (Functor m, Monad m) => (S.Stream m a, S.Stream m a) -> m ([a], [a])
635 | toLists (s1,s2) = liftM2 (,) (S.toList s1) (S.toList s2)
636 |
--------------------------------------------------------------------------------