Haskell database queries via mapM generate huge space leak

lvldb.cabal

name:                lvldb
version:             0.1.0.0
synopsis:            Haskell database queries via mapM generate huge space leak
description:         Simple LevelDB reader/writer to demonstrate the huge space leak that occurs when using mapM
homepage:            https://gist.github.com/mcmayer/57884805528632736d4e3bbc9a74b0af
license:             BSD3
author:              M Mayer
category:            Database
build-type:          Simple
cabal-version:       >=1.10

executable lvlRW
    hs-source-dirs:      .
    main-is:             lvlRW.hs
    ghc-options:         -O2
    build-depends:       base
                       , bytestring
                       , transformers
                       , mtl
                       , leveldb-haskell
                       , resourcet
                       , data-default
                       , list-t
    default-language:    Haskell2010

lvlRW.hs

module Main (main) where

-- The purpose of this simple LevelDB reader/writer is to demonstrate the huge space leak
-- that occurs when using mapM inside the ResourceT IO Bool Monad in the doRead function 
-- below.
-- The function writeR uses mapM_ and has no space leak, it's included to make the example 
-- self-contained.
-- Usage: 
-- lvlRW [R|W] dirName nRows
--   command W: Create a leveldb database with nRows entries under dirName
--   command R: Read the leveldb databaseunder dirName and check nRows of its content

import           Control.Monad                (when)
import           Control.Monad.Trans.Resource (ResourceT)
import           Data.ByteString.Char8        (ByteString, pack, unpack)
import           Data.Default                 (def)
import           Database.LevelDB
import           System.Environment           (getArgs)

intToBs :: Int -> ByteString
intToBs i = pack $ show i

bsToInt :: ByteString -> Int
bsToInt bs = read $ unpack bs

-- Essentially write key-value pairs [(1,2), .., (n,2*n)] to db at DirName
doWrite :: FilePath -> Int -> IO ()
doWrite dirName n = do
    runResourceT $ do
        db <- open dirName defaultOptions{ createIfMissing = True, cacheSize= 2048 }
        mapM_ (\i->put db def (intToBs i) (intToBs $ 2*i)) [1..n]   -- no space leak
    putStrLn $ "Wrote " ++ show n ++ " to " ++ dirName

-- get the value corresponding to key i from db and check it's correct
check db def i = do
    mv <- get db def (intToBs i)
    case mv of
        Just v  -> return $ (2*i) == bsToInt v
        Nothing -> return False

-- read keys [1..n] from db at DirName and check that the values are correct
doRead :: FilePath -> Int -> IO ()
doRead dirName n = do
    success <- runResourceT $ do
        db <- open dirName defaultOptions{ cacheSize= 2048 }
        let check' = check db def in        -- check' :: Int -> ResourceT IO Bool
            and <$> mapM check' [1..n]      -- the mapM generates a huge space leak
    putStrLn $ "Read " ++ show n ++ " from " ++ dirName ++ if success then ": OK" else ": Fail"


main :: IO ()
main = do
    args <- getArgs
    when (length args < 3) (error "Usage: lvlRW [R|W] dirName n")
    let doWhat:dirName:n':_ = args
    let n = read n' :: Int

    case doWhat of
        "W"       -> doWrite dirName n
        "R"       -> doRead  dirName n
        otherwise -> error $ "I don't understand command '" ++ doWhat ++ "'"

stack.yaml

flags: {}
extra-package-dbs: []
packages:
- '.'
extra-deps: []
resolver: lts-7.4