Why wrapping the Data.Binary.Put monad creates a memory leak?

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
import qualified Data.ByteString.Lazy as BL
import qualified Data.Binary.Put as P

-- -------------------------------------------------------------------
-- If you uncomment this code and comment out the code involving
-- Writer1M wrapper monad, then this program will use just a fraction
-- of memory compared to the version using Writer1M.

--type Writer = P.Put
--
--writer :: P.Put -> Writer
--writer put = put
--
--writeToFile :: String -> Writer -> IO ()
--writeToFile path writer = BL.writeFile path (P.runPut writer)

-- -------------------------------------------------------------------
-- One of the problematic wrapper monads.

data Writer1M a = Writer1M { write :: P.PutM a }

instance Monad Writer1M where
  return a = Writer1M $ return a
  ma >>= f = Writer1M $ write ma >>= write . f

type Writer = Writer1M ()

writer :: P.Put -> Writer
writer put = Writer1M $ put

writeToFile :: String -> Writer -> IO ()
writeToFile path writer = BL.writeFile path (P.runPut $ write writer)

-- -------------------------------------------------------------------
-- Test data.

data Tree = Node [Tree] | Leaf [Int] deriving Show

makeTree :: Tree
makeTree = makeTree' 9
  where makeTree' 0 = Leaf [0..100]
        makeTree' n = Node [ makeTree' $ n - 1
                           , makeTree' $ n - 1
                           , makeTree' $ n - 1
                           , makeTree' $ n - 1 ]

-- -------------------------------------------------------------------

putInt32 n = writer $ P.putWord32le n
putInt8  n = writer $ P.putWord8 n

putTree :: Tree -> Writer
putTree (Node childs) = do
  putInt8 123
  mapM_ putTree childs

putTree (Leaf nums) = do
  mapM_ (putInt32 . fromIntegral) nums

-- -------------------------------------------------------------------

main = do
  writeToFile "test-output.bin" $ putTree makeTree


-- -------------------------------------------------------------------