Как сохранить древовидную структуру данных в двоичный файл в Haskell

Вот реализация двухпроходного решения, предложенного sclv.

import qualified Data.ByteString.Lazy as L
import Data.Binary.Put
import Data.Word
import Data.List (foldl')

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

makeTree 0 = Leaf $ replicate 100 0xdeadbeef
makeTree n = Node $ replicate 4 $ makeTree $ n-1

SizeTree имитирует исходное дерево, оно не содержит данных, но в каждом узле хранит размер соответствующего дочернего элемента в дереве.
Нам нужно иметь SizeTree в памяти, поэтому стоит сделать его более компактным (например, заменить Ints словами в ubox) .

data SizeTree
  = SNode {sz :: Int, chld :: [SizeTree]}
  | SLeaf {sz :: Int}
  deriving Show

Имея SizeTree в памяти, можно сериализовать оригинальное дерево в потоковом режиме.

putTree :: Tree -> SizeTree -> Put
putTree (Node xs) (SNode _ ys) = do
  putWord8 $ fromIntegral $ length xs          -- number of children
  mapM_ (putWord32be . fromIntegral . sz) ys   -- sizes of children
  sequence_ [putTree x y | (x,y) <- zip xs ys] -- children data
putTree (Leaf xs) _ = do
  putWord8 0                                   -- zero means 'leaf'
  putWord32be $ fromIntegral $ length xs       -- data length
  mapM_ putWord32be xs                         -- leaf data


mkSizeTree :: Tree -> SizeTree
mkSizeTree (Leaf xs) = SLeaf (1 + 4 + 4 * length xs)
mkSizeTree (Node xs) = SNode (1 + 4 * length xs + sum' (map sz ys)) ys
  where
    ys = map mkSizeTree xs
    sum' = foldl' (+) 0

Важно предотвратить объединение GHC двух проходов в один (в этом случае дерево будет храниться в памяти). Здесь это делается путем подачи в функцию не дерева, а генератора дерева.

serialize mkTree size = runPut $ putTree (mkTree size) treeSize
  where
    treeSize = mkSizeTree $ mkTree size

main = L.writeFile "dump.bin" $ serialize makeTree 10

Есть два основных подхода, которые я бы рассмотрел. Если вся сериализованная структура легко поместится в памяти, вы можете сериализовать каждый узел в ленивую строку байтов и просто использовать длину каждого из них для вычисления смещения от текущей позиции.

serializeTree (Leaf nums)  = runPut (mapM_ putInt32 nums)
serializeTree (Node subtrees) = mconcat $ header : childBs
 where
  childBs = map serializeTree subtrees
  offsets = scanl (\acc bs -> acc+L.length bs) (fromIntegral $ 2*length subtrees) childBs
  header = runPut (mapM_ putInt32 $ init offsets)

Другой вариант — после сериализации узла вернуться назад и переписать поля смещения соответствующими данными. Это может быть единственный вариант, если дерево большое, но я не знаю библиотеки сериализации, поддерживающей это. Это потребует работы в IO и seek в правильных местах.

Я думаю, вам нужно явное двухпроходное решение. Первый преобразует ваше дерево в дерево с аннотациями размера. Этот проход форсирует дерево, но на самом деле его можно выполнить вообще без какой-либо монадической машины, просто завязав узел. Второй проход находится в старой доброй монаде Put, и, учитывая, что аннотации размера уже рассчитаны, он должен быть очень простым.

Вот реализация с использованием Builder, который является частью «бинарного» пакета. Я не профилировал его должным образом, но, согласно «сверху», он сразу выделяет 108 Мбайт, а затем зависает на этом до конца выполнения.

Обратите внимание, что я не пытался считывать данные обратно, поэтому в моих расчетах размера и смещения могут быть скрытые ошибки.

-- Paste this into TreeBinary.hs, and compile with
--    ghc -O2 --make TreeBinary.hs -o TreeBinary

module Main where


import qualified Data.ByteString.Lazy as BL
import qualified Data.Binary.Builder as B

import Data.List (init)
import Data.Monoid
import Data.Word


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

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

-- Approximate size in memory (ignoring laziness) I think is:
-- 101 * 4^9 * sizeof(Int) + 1/3 * 4^9 * sizeof(Node)

-- This version uses [Word32] instead of [Int] to avoid having to write
-- a builder for Int.  This is an example of lazy programming instead
-- of lazy evaluation. 

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

-- --------------------------------------------------------------------
-- The actual serialisation code.


-- | Given a tree, return a builder for it and its estimated length in bytes.
serialiseTree :: Tree -> (B.Builder, Word32)
serialiseTree (Leaf ns) = (mconcat (B.singleton 2 : map B.putWord32be ns), fromIntegral $ 4 * length ns + 1)
serialiseTree (Node ts) = (mconcat (B.singleton 1 : map B.putWord32be offsets ++ branches), 
                           baseLength + sum subLengths)
   where
      (branches, subLengths) = unzip $ map serialiseTree ts
      baseLength = fromIntegral $ 1 + 4 * length ts
      offsets = init $ scanl (+) baseLength subLengths


main = do
   putStrLn $ "Length = " ++ show (snd $ serialiseTree makeTree)
   BL.writeFile "test.bin" $ B.toLazyByteString $ fst $ serialiseTree makeTree