{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -XIncoherentInstances #-} ----------------------------------------------------------------------------- -- -- Module : Data.RefSerialize -- Copyright : Alberto Gómez Corona -- License : see LICENSE -- -- Maintainer : agocorona@gmail.com -- Stability : experimental -- | Read, Show and Data.Binary do not check for repeated references to the same address. -- As a result, the data is duplicated when serilet x= 5 :: Int -- Data.RefSerialize>runW $ showp x -- "5" -- -- every instance of Read and Show is an instance of RefSerialize. for how to construct showp and readp parsers, see the demo.hs -- -- rshowp is derived from showp, it labels the serialized data with a variable name -- -- Data.RefSerialize>runW $ rshowp x -- " v8 where {v8= 5; }" -- -- Data.RefSerialize>runW $ rshowp [2::Int,3::Int] -- " v6 where {v6= [ v9, v10]; v9= 2; v10= 3; }" -- -- while showp does a normal show serialization -- -- Data.RefSerialize>runW $ showp [x,x] -- "[5, 5]" -- -- rshowp variables are serialized memory references: no piece of data that point to the same addrees is serialized but one time -- -- Data.RefSerialize>runW $ rshowp [x,x] -- " v9 where {v6= 5; v9= [ v6, v6]; }" -- -- -- -- "this happens recursively" -- -- Data.RefSerialize>let xs= [x,x] in str = runW $ rshowp [xs,xs] -- Data.RefSerialize>str -- " v8 where {v8= [ v10, v10]; v9= 5; v10= [ v9, v9]; }" -- -- the rshowp serialized data is read with rreadp. The showp serialized data is read by readp -- -- Data.RefSerialize>let xss= runR rreadp str :: [[Int]] -- Data.RefSerialize>print xss -- [[5,5],[5,5]] -- -- this is the deserialized data -- -- the deserialized data keep the references!! pointers are restored! That is the whole point! -- -- Data.RefSerialize>varName xss !! 0 == varName xss !! 1 -- True -- -- -- rShow= runW rshowp -- rRead= runR rreadp -- -- Data.RefSerialize>rShow x -- " v11 where {v11= 5; }" -- -- -- In the definition of a referencing parser non referencing parsers can be used and viceversa. Use a referencing parser -- when the piece of data is being referenced many times inside the serialized data. -- -- by default the referencing parser is constructed by: -- -- -- rshowp= insertVar showp -- rreadp= readVar readp -- but this can be redefined. See for example the instance of [] in RefSerialize.hs -- -- This is an example of a showp parser for a simple data structure. -- -- data S= S Int Int deriving ( Show, Eq) -- -- instance Serialize S where -- showp (S x y)= do -- xs <- rshowp x -- rshowp parsers can be inside showp parser -- ys <- rshowp y -- return $ "S "++xs++" "++ys -- -- -- -- readp = do -- symbol "S" -- I included a (almost) complete Parsec for deserialization -- x <- rreadp -- y <- rreadp -- return $ S x y -- -- there is a mix between referencing and no referencing parser here: -- -- Data.RefSerialize>putStrLn $ runW $ showp $ S x x -- S v23 v23 where {v23= 5; }@ module Data.RefSerialize ( module Data.Parser ,Serialize( showp ,readp ,rshowp ,rreadp ) ,rShow ,rRead ,insertVar ,readVar ,varName ,runR ,runW ,readHexp ,showHexp ) where import qualified Data.Map as M import Data.Serialize import Data.Parser import Unsafe.Coerce import Data.Char(isAlpha, isSpace, isAlphaNum) import Numeric(readHex,showHex) class Serialize c where showp :: c -> ST String -- ^ shows the content of a expression, must be defined bu the user readp :: ST c -- ^ read the content of a expression, must be user defined rshowp :: c -> ST String -- ^ insert a reference (a variable in the where section). @rshowp = insertVar showp @ -- default definition rshowp = insertVar showp rreadp :: ST c -- ^ read a variable in the where section (to use for deserializing rshowp output). @rreadp = readVar readp@ -- default definition rreadp = readVar readp {- #ifdef Axioms serializeAxioms: Axioms c serializeAxioms= axioms{ unary= [Axiom "reverse" (\x -> let str= rShow x y = rRead xtr in y== x) AxioM "pointer equality" (\x -> let str= rShow[x,x] [y,z] = rRead str in varName y== varName z) ] } #endif -} -- | use the rshowp parser to serialize the object -- @ rShow c= runW $ rshowp c@ rShow :: Serialize c => c -> String rShow c= runW $ rshowp c -- | deserialize trough the rreadp parser -- @ rRead str= runR rreadp $ str@ rRead :: Serialize c => String -> c rRead str= runR rreadp $ str readHexp :: (Num a, Integral a) => ST a readHexp = ST(\(Stat(c,s,v)) -> let l= readHex s in if null l then Left . Error $ "not readable: " ++ s else let ((x,str2):_)= l in Right(Stat(c,dropWhile isSpace str2,v),x) ) "readHexp " readSR :: Read a => ST a readSR = ST(\(Stat(c,s,v)) -> let l= readsPrec 1 s in if null l then Left . Error $ "not readable: " ++ s else let ((x,str2):_)= l in Right(Stat(c,dropWhile isSpace str2,v),x) ) "readp: readsPrec " --readSR = ST(\(Stat(c,s,v)) -> let ((x,str2):_)= readsPrec 1 s in Right(Stat(c,str2,v),x) ) -- | deserialize the string with the parser runR:: ST a -> String -> a runR (ST f) str= let (struct, vars)= readContext "where " str in case f (Stat(M.empty,struct,vars) ) of Right (Stat _, a) -> a Left (Error s) -> error s showHexp :: (Num a,Integral a) => a -> ST String showHexp var= ST(\(Stat(c,s,v)) -> Right(Stat(c,s,v),showHex var "")) "showHexp " showSR :: Show a => a -> ST String showSR var= ST(\(Stat(c,s,v)) -> Right(Stat(c,s,v),show var)) "showp: show " -- | serialize x with the parser runW :: ST String -> String runW (ST f) = case f (Stat(M.empty,"","")) of Right (Stat (c,_,_), str) -> let scontext= M.assocs c show1 c= concatMap (\(n,(_,v))->"v"++ show n++"= "++v++"; ") scontext vars= show1 c strContext= if null vars then "" else " where {"++vars ++ "}" in str ++ strContext Left (Error s) -> error s -- -------------Instances instance Serialize String where showp = showSR readp = readSR instance Serialize a => Serialize [a] where showp []= return "[]" showp (x:xs)= do s1<- showp x sn<- mapM f xs return $ "["++ s1++ concat sn ++"]" where f x=do str <- showp (x:: a) return $ ", "++str readp = (brackets $ commaSep $ readp) "readp:: [] " rshowp = insertVar rshowp1 where rshowp1 []= insertVar return "[]" rshowp1 (x:xs)= do s1<- rshowp x sn<- mapM f xs return $ "["++ s1++ concat sn ++"]" where f x= do str <- rshowp (x:: a) return $ ", "++str rreadp = (readVar $ brackets $ commaSep $ rreadp) "rreadp:: [] " instance (Show a, Read a) => Serialize a where showp = showSR readp = readSR -- | insert a variable at this position. The expression value is inserted the where part if it is not already -- created. If the address of this object being parsed correspond with an address already parsed and -- it is in the where section, then the same variable name is used -- @runW showp (1::Int) -> "1" -- runW (insertVar showp) (1::Int) -> v1 where { v1=1} -- runW (insertVar showp) [(1::Int) ,1] -> [v1.v1] where { v1=1}@ -- This is useful when the object is referenced many times insertVar :: (a -> ST String) -> a -> ST String insertVar parser x= ST(\(Stat(c,s,v))-> let mf = trytofindEntireObject x c in case mf of Just var -> Right(Stat(c,s,v),var) Nothing -> let ST f= parser x Right (Stat (c',_,_), str) = f (Stat(c,s,v)) in Right(Stat(addc str c',s,v), ' ':varname)) where addc str c= M.insert ( hash) (unsafeCoerce x, str) c hash = hasht x varname= "v" ++ show hash trytofindEntireObject x c= case M.lookup hash c of Nothing -> Nothing Just _ -> Just varname -- | deserialize a variable serialized with insertVar. Memory references are restored readVar :: Serialize c => ST c -> ST c readVar parser= ST(\(Stat(c,s,v))-> let s1= dropWhile isSpace s (var, str2) = span isAlphaNum s1 in case trytofindEntireObject (numVar var) c of Just (x,_) -> Right(Stat(c,str2,v),unsafeCoerce x) Nothing -> let (_, rest)= readContext (var++"= ") v ST f= parser in case f (Stat(c,rest,v)) --`debug` ("s="++s++"var="++var++"rest="++rest ) of Right (Stat(c',s',v'),x) -> let c''= M.insert (numVar var) (unsafeCoerce x, "") c' in Right (Stat(c'',str2,v),x) err -> err) where trytofindEntireObject x c= case M.lookup x c of Nothing -> Nothing justx -> justx