Сериализация взаимно-рекурсивных данных

[lomeo]

На RSDN Tonal- задаёт вопрос о сериализации взаимно-рекурсивных данных.

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

Поэтому в голову приходит замечательный пакет data-reify от Andy Gill. О его применении можно прочитать в статье Type-Safe Observable Sharing in Haskell.

Смысл в том, что мы можем разложить рекурсивные данные на нерекурсивные данные со ссылками - то, что нам и нужно.

Т.е. для типов из примера Tonal-

data A = A {a_unuqId :: Int, a_refs :: [B]}
data B = B {b_unuqId :: Int, b_refs :: [A]}

это будет

data N u = AN { an_uniqId :: Int, an_refs :: [u] }
         | BN { bn_uniqId :: Int, bn_refs :: [u] }

Обратите внимание на дырки `u', оставленные для рекурсии - по сути A ~ N B и наоборот.
Пишем instance для MuRef

instance MuRef A where
    type DeRef A = N
    mapDeRef f (A i rs) = AN i <$> sequenceA (map f rs)

instance MuRef B where
    type DeRef B = N
    mapDeRef f (B i rs) = BN i <$> sequenceA (map f rs)

и получаем нужный граф, например

> let { a = A 1 [b] ; b = B 2 [a] }
> reifyGraph a
let [(1,AN {an_uniqId = 1, an_refs = [2]}),(2,BN {bn_uniqId = 2, bn_refs = [1]})] in 1

или

> let { a1 = A 1 [b1, b2] ; a2 = A 2 [b2] ; b1 = B 3 [a1] ; b2 = B 4 [a1, a2] }
> reifyGraph a1
let [(1,AN {an_uniqId = 1, an_refs = [2,3]}),
     (3,BN {bn_uniqId = 4, bn_refs = [1,4]}),
     (4,AN {an_uniqId = 2, an_refs = [3]}),
     (2,BN {bn_uniqId = 3, bn_refs = [1]})] in 1

Меня здесь смущает тип [(Unique, g Unique)], всё таки хочется IntMap (g Unique) - быстрее и десериализация будет проще. Впрочем, переписать библиотеку должно быть несложно.

При десериализации придётся обращать граф в конкретный тип, например, A. Это дополнительные телодвижения, но зато весь код у нас более общий и не привязан конкретно к сериализации. Например, необходимо использовать мемоизацию:

graphToA :: Graph (DeRef A) -> A
graphToA (Graph gs i) = ma ! i
    where
        ma = fromList [ (i, A ai $ map (mb!) rs) | (i, AN ai rs) <- gs ]
        mb = fromList [ (i, B bi $ map (ma!) rs) | (i, BN bi rs) <- gs ]

Покритикуйте.

Comments

[migmit.vox.com (from livejournal.com)]

Мне не слишком нравится сваливание всех типов в один. Если у них будут по нескольку конструкторов - станет messy. Not terribly, но всё же.

Надо будет подумать, как это получше написать.

[lomeo.livejournal.com]

Меня это тоже смутило. Но я не нашёл, как выкрутиться, DeRef у них, похоже должен быть общим :(

[migmit.vox.com (from livejournal.com)]

Хотя бы разнести, чтобы они не перемешивались:

data N :: * -> * -> * where
    N_A :: Int -> [u] -> N A u
    N_B :: Int -> [u] -> N B u

[voidex.livejournal.com]

Как раз недавно возился с такой задачей, жаль на библиотеку не наткнулся. Правда, у меня были некоторые особенности, так что библиотека вряд ли подошла бы именно в таком виде, но возможно я бы её подправил.

[lomeo.livejournal.com]

Я вот тут подумал, а что если подправить uniplate так, чтобы он возвращал только уникальные значения? Тогда легко можно делать что-то вроде

[ id | A id _ <- universeBi a ]

чтобы получить _конечный_ список всех нужных полей.

спасибо

[nealar.livejournal.com]

Для одной задачи нужно то же самое преобразование. Только не для сериализации.

[permea-kra.livejournal.com]

может, правильней добавить в конструктор поле, которому будет при создании экземпляра типа присваиваться уникальное значение? (как это сделать - вопрос отдельный)

[lomeo.livejournal.com]

Не понял, разве при создании графа не то же самое происходит?

[permea-kra.livejournal.com]

протупил.

для
data A = A {a_unuqId :: Int, a_refs :: [B]}
data B = B {b_unuqId :: Int, b_refs :: [A]}
сериализуем в монаде
type Ser a = StateT (Set.Set Int) (Writer [Word8]) a


посещённые Id добавляем в стейт, рекурсивный обход можно делать чем угодно, главное, чтоб было удобно.
Чем плохо такое решение в лоб ?

[lomeo.livejournal.com]

Тем, что всё делаем руками.

[permea-kra.livejournal.com]

Что - всё ?

[lomeo.livejournal.com]

Руками работаем с Id - добавляем их в стейт.

[permea-kra.livejournal.com]

есть мнение, что Data.Generics.mkM , Data.Data.gmapQ и один newtype Id = Id Int deriving (Data,Typeable) позволят всё написать один раз (и достаточно компактно) и забыть. И по крайней мере для меня это было бы проще, чем разбираться с тараканами в чужих библиотеках.

[lomeo.livejournal.com]

Покажи код.

[permea-kra.livejournal.com]

inspired by Data.Generics.Text

 
module Ser
where
import Data.Generics
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Identity
import qualified Data.Set as Set
import Data.Maybe

ifIsId :: (Monad m, MonadState (Set.Set Id) m ) => Id -> m () -> m () -> m ()
ifIsId iD onS onF =	do
			s <- get
			let is = Set.member iD s
			if is then onS else onF

newtype Id = Id { unId :: Int} deriving (Data,Typeable,Show,Read,Ord,Eq)

getIdMaybe :: (Data a, Typeable a) => a -> Maybe Id 
-- ^ get Id for this node. 
-- Limitation : no more then one id per node or undefined behaivor
getIdMaybe = listToMaybe . catMaybes . (gmapQ (mkQ Nothing (Just :: Id -> Maybe Id)))

type SerM a = StateT (Set.Set Id) (WriterT String Identity) a

serV :: (Data v, Typeable v) => v -> SerM ()
serV v =	do
		tell "{ " 
		case (getIdMaybe v) of -- brunch if value has identifier
			Just iD	-> ifIsId iD ( tell $ "linkTo " ++ (show $ unId iD) ) (serRi v iD)
			Nothing -> (serRs v)
		tell " }"
		where 	serRi v iD = 	(modify $ Set.insert iD) >>
					tell (showConstr $ toConstr v) >>
		                     	tell (" id = " ++ (show $ unId iD) ) >>
					(sequence_ $ gmapQ serV v)  
			serRs v = tell (showConstr $ toConstr v) >> (sequence_ $ gmapQ serV v)
		
runSer :: (Data v, Typeable v) => v -> String
runSer v = runIdentity $ execWriterT $ evalStateT (serV v) Set.empty

data A = A { id_A :: Id , ref_B :: Maybe B } 			deriving (Data,Typeable)
data B = B { id_B :: Id , ref_A :: Maybe A, ref_C :: Maybe C } 	deriving (Data,Typeable)
data C = C { ind_ref_A :: Maybe A }				deriving (Data,Typeable)

test :: A
test = 	let 	top = A (Id 1) (Just sb)
		sb  = B (Id 2) (Just top) (Just sc)
		sc  = C (Just top)
	in top

Тест:

*Ser> runSer test
"{ A id = 1{ Id{ 1 } }{ Just{ B id = 2{ Id{ 2 } }{ Just{ linkTo 1 } }{ Just{ C{ Just{ linkTo 1 } } } } } } }"

Десериализацию с ходу не напишу, надо будет gread покурить. По идее, пишется.

[lomeo.livejournal.com]

Да, понял, спасибо за код.

Версия, которая не зависит от Id (пользую StableName)
http://hpaste.org/fastcgi/hpaste.fcgi/view?id=17329#a17329

В uniplate, чтобы поддерживал рекурсивные данные, это красиво не засунешь :-( Потому что IO.

[permea-kra.livejournal.com]

Ошибка базы. Может, в pre-теге в коммент кинете ?

[lomeo.livejournal.com]

А я уже убил. Но вот uniplate-like с unsafePerformIO

{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
module Ser
where
import Data.Generics
import Control.Monad.State
import Control.Monad.Writer
import qualified Data.Set as Set
import Data.Maybe
import System.Mem.StableName
import System.IO.Unsafe
import Debug.Trace

type LinkSet = Set.Set Int

presents :: (Monad m, MonadState LinkSet m) => Int -> m Bool
presents iD = gets (Set.member iD)

type SerM r a = StateT LinkSet (WriterT [r] IO) a

goRec :: (Data v, Data r) => v -> SerM r ()
goRec v = do
    iD <- v `seq` (hashStableName `fmap` liftIO (makeStableName v))
    p <- presents iD
    unless p $ do
        modify $ Set.insert iD
        case cast v of
            Just v0 -> serRi v0 iD
            Nothing -> continue
    where
        serRi v iD = tell [v] >> continue
        continue = sequence_ $ gmapQ goRec v

recUniplate :: (Data v, Data r) => v -> [r]
recUniplate v = unsafePerformIO $ execWriterT $ evalStateT (goRec v) Set.empty

data Rose = Rose { roseId :: Int, roses :: [Rose] }
    deriving (Data,Typeable)

testRose = let
        a = Rose 1 [b,c]
        b = Rose 2 [a,c]
        c = Rose 3 [a,b]
    in a

Работаем...

> [id | Rose id _ <- recUniplate testRose]
[1,2,3]

[permea-kra.livejournal.com]

Ага. Спасибо, симпатичненько.

[permea-kra.livejournal.com]

Хм. Это вы ручками код выправили или какой-то тульзой ?

[lomeo.livejournal.com]

Ручками, пока разбирался с вашим :)

[permea-kra.livejournal.com]

Бгы. Надо бы какие-то гайдлайны по форматированию хаскельного кода что ли поискать...

[lomeo.livejournal.com]

http://www.haskell.org/haskellwiki/Programming_guidelines
http://haskell.org/haskellwiki/Things_to_avoid - тут не форматирование

Ещё есть соглашения для GHC sources, оттуда тоже можно взять что-нибудь полезное.

Поиск haskell beautifier не дал ничего полезного :(

[permea-kra.livejournal.com]

Спасибо, почитаем.

[migmit.vox.com (from livejournal.com)]

Вообще, смахивает на подходящую работу для multirec.

[nealar.livejournal.com]

WtF multirec?

[migmit.vox.com (from livejournal.com)]

http://hackage.haskell.org/package/multirec

а оно уже работает?

[nealar.livejournal.com]

build failure: ghc-6.12

Re: а оно уже работает?

[migmit.vox.com (from livejournal.com)]

http://hackage.haskell.org/packages/archive/multirec/0.4.1/logs/failure/ghc-6.12

haddock: internal Haddock or GHC error: dist/doc/html/multirec/haddock-prolog4983.txt: hGetContents: invalid argument (Invalid or incomplete multibyte or wide character)

Я думаю, мы переживём отсутствие автодокументации. Но даже если оно не скомпилится - идея там достаточно простая, можно и самостоятельно воспроизвести.

Re: а оно уже работает?

[nealar.livejournal.com]

Это понятно, просто если оно хотя бы теоретически работает, то можно идею вкуривать. А если нет - лень время тратить. Уж очень я медленно по-английски читаю.

Re: а оно уже работает?

[migmit.vox.com (from livejournal.com)]

Под ghc 6.10 сбилдилось нормально.

[lomeo.livejournal.com]

Спасибо! Посмотрю.