{-# OPTIONS -fglasgow-exts -XOverlappingInstances #-} ----------------------------------------------------------------------------- -- -- 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 seri<alized. This is a waste of space in the filesystem -- and also a waste of serialization time. but the worst consequence is that, when the serialized data is read, -- it allocates multiple copies for the same object when referenced multiple times. Because multiple referenced -- data is very typical in a pure language such is Haskell, this means that the resulting data loose the beatiful -- economy of space and processing time that referential transparency permits. -- -- Here comes a brief tutorial: -- -- @runW applies showp, the serialization parser of the instance Int for the RefSerialize class -- -- Data.RefSerialize>let 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 ) ,showSR ,readSR ,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) import Data.Map 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 Prelude.null l then Left . Error $ "not readable: " ++ s else let ((x,str2):_)= l in Right(Stat(c,dropWhile isSpace str2,v),x) ) <?> "readHexp " -- |if a is an instance of Read, readSR can be used as the readp method -- the drawback is that the data inside is not inspected for common references -- so it is recommended to create your own readp method for your complex data structures readSR :: Read a => ST a readSR = ST(\(Stat(c,s,v)) -> let l= readsPrec 1 s in if Prelude.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 " -- |if a is an instance of Show, showSR can be used as the showp method -- the drawback is that the data inside is not inspected for common references -- so it is recommended to create your own readp method for your complex data structures 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 Prelude.null vars then "" else " where {"++vars ++ "}" in str ++ strContext Left (Error s) -> error s -- | insert a variable at this position. The expression value is inserted in the "where" section 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 -- -------------Instances instance Serialize String where showp = showSR readp = readSR instance Serialize a => Serialize [a] where showp []= return "[]" showp (x:xs)= do s1<- rshowp x sn<- mapM f xs return $ "["++ s1++ concat sn ++"]" where f x= do str <- rshowp (x:: a) return $ ", "++str readp = (brackets $ commaSep $ rreadp) <?> "rreadp:: [] " instance (Serialize a, Serialize b) => Serialize (a, b) where showp (x, y)= do sx <- rshowp x sy <- rshowp y return $ "("++ sx ++ "," ++ sy ++ ")" readp = parens (do x <- rreadp comma y <- rreadp return (x,y)) <?> "rreadp:: (,) " instance (Serialize a, Serialize b, Serialize c) => Serialize (a, b,c) where showp (x, y, z)= do sx <- rshowp x sy <- rshowp y sz <- rshowp z return $ "("++ sx ++ "," ++ sy ++"," ++ sz ++ ")" readp = parens (do x <- rreadp comma y <- rreadp comma z <- rreadp return (x,y,z)) <?> "rreadp:: (,,) " instance (Serialize a, Serialize b, Serialize c, Serialize d) => Serialize (a, b,c, d) where showp (x, y, z, t)= do sx <- rshowp x sy <- rshowp y sz <- rshowp z st <- rshowp t return $ "("++ sx ++ "," ++ sy ++"," ++ sz ++ "," ++ st ++ ")" readp = parens (do x <- rreadp comma y <- rreadp comma z <- rreadp comma t <- rreadp return (x,y,z,t)) <?> "rreadp:: (,,,) " instance (Serialize a, Ord a, Serialize b) => Serialize (Map a b) where showp m= showp $ M.toList m readp= do list <- readp :: ST [(a,b)] return $ M.fromList list instance Serialize a => Serialize (Maybe a) where showp Nothing = return "Nothing" showp (Just x) = showp x >>= \sx -> return $ "Just " ++ sx readp = choice [rNothing, rJust] where rNothing = symbol "Nothing" >> return Nothing rJust = symbol "Just" >> readp >>= \x -> return $ Just x instance (Serialize a, Serialize b) => Serialize (Either a b) where showp (Left x) = rshowp x >>= \sx -> return $ "Left " ++ sx showp (Right x) = rshowp x >>= \sx -> return $ "Right " ++ sx readp = choice [rLeft, rRight] where rLeft = symbol "Left" >> rreadp >>= \x -> return $ Left x rRight = symbol "Right" >> rreadp >>= \x -> return $ Right x instance Serialize Bool where showp = showSR readp = readSR instance Serialize Char where showp = showSR readp = readSR instance Serialize Double where showp = showSR readp = readSR instance Serialize Float where showp = showSR readp = readSR instance Serialize Int where showp = showSR readp = readSR instance Serialize Integer where showp = showSR readp = readSR instance Serialize Ordering where showp = showSR readp = readSR instance Serialize () where showp = showSR readp = readSR