diff --git a/Data/RefSerialize.hs b/Data/RefSerialize.hs --- a/Data/RefSerialize.hs +++ b/Data/RefSerialize.hs @@ -25,94 +25,35 @@ This package leverages Show, Read and Data.Binary instances while it permits textual as well as binary serialization keeping internal references. - 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]; }" + NOTE: to avoid long lists of variables with only one reference, + now variables not referenced two or more times are inlined + so rshowp serializes the same result than showp in these cases. + However, showp is faster. + In correspondence, rreadp call readp when there is no variable serialized. - "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 --- insertString "S" - rshowp x -- rshowp parsers can be inside showp parser - rshowp y - + This is an example of a showp parser for a simple data structure. - readp = do - symbol "S" -- I included a (almost) complete Parsec for deserialization - x <- rreadp - y <- rreadp - return $ S x y +> data S= S Int Int deriving ( Show, Eq) +> +> instance Serialize S where +> showp (S x y)= do +> insertString "S" +> rshowp x -- rshowp parsers can be inside showp parser +> rshowp y +> +> +> 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: + 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; }@ +> Data.RefSerialize>putStrLn $ runW $ showp $ S x x +> S v23 v23 where {v23= 5; } -} @@ -127,16 +68,18 @@ showp ,readp ) - ,Context - ,newContext ,rshowp ,rreadp ,showps + ,rshowps + ,runR + ,runW ,showpText ,readpText - ,takep + ,showpBinary ,readpBinary + ,insertString ,insertChar ,rShow @@ -144,14 +87,17 @@ ,insertVar ,readVar ,varName - ,runR - ,runRC - ,runW - + ,takep ,readHexp ,showHexp - ,getContext - +-- * Context handling + ,Context + ,getRContext + ,getWContext + ,newContext + ,showContext + ,runRC + ,runWC ) where @@ -162,30 +108,33 @@ import Data.Char(isAlpha, isSpace, isAlphaNum) import Numeric(readHex,showHex) import Data.ByteString.Lazy.Char8 as B ---import Data.ByteString(breakSubstring) import Debug.Trace import Data.Binary import System.IO.Unsafe import qualified Data.Map as M +import Data.Monoid +import Data.Maybe +import Debug.Trace +(!>) = flip . trace newContext :: IO Context newContext = Data.RefSerialize.Serialize.empty class Serialize c where - showp :: c -> ST () -- ^ 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 + showp :: c -> STW () -- ^ shows the content of a expression, must be defined bu the user + readp :: STR c -- ^ read the content of a expression, must be user defined -- | insert a reference (a variable in the where section). -- @rshowp = insertVar showp @ -rshowp :: Serialize c => c -> ST () +rshowp :: Serialize c => c -> STW () rshowp = insertVar showp -- | read a variable in the where section (to use for deserializing rshowp output). -- @rreadp = readVar readp@ -rreadp :: Serialize c => ST c +rreadp :: Serialize c => STR c rreadp = readVar readp {- @@ -213,9 +162,13 @@ -- useful for delayed deserialzation of expresions, in case of dynamic variables were deserialization -- is done when needed, once the type is known with `runRC` -getContext :: ST (Context, ByteString) -getContext = ST(\(Stat(c,s,v)) -> Right (Stat (c,s,v), (c,v))) +getRContext :: STR (Context, ByteString) +getRContext = STR(\(StatR(c,s,v)) -> Right (StatR (c,s,v), (c,v))) +getWContext :: STW (Context, ByteString) +getWContext = STW(\(StatW(c,s,v)) -> (StatW (c,s,v), (c,""))) + + -- | use the rshowp parser to serialize the object -- @ rShow c= runW $ rshowp c@ rShow :: Serialize c => c -> ByteString @@ -226,81 +179,130 @@ rRead :: Serialize c => ByteString -> c rRead str= runR readp $ str -readHexp :: (Num a, Integral a) => ST a -readHexp = ST(\(Stat(c,s,v)) -> +readHexp :: (Num a, Integral a) => STR a +readHexp = STR(\(StatR(c,s,v)) -> let us= unpack s l= readHex us in if Prelude.null l then Left . Error $ "readHexp: not readable: " ++ us else let ((x,str2):_)= l - in Right(Stat(c, pack $ Prelude.dropWhile isSpace str2,v),x) ) + in Right(StatR(c, pack $ Prelude.dropWhile isSpace str2,v),x) ) "readHexp " -showHexp :: (Num a,Integral a,Show a) => a -> ST () -showHexp var= ST(\(Stat(c,s,v)) -> Right(Stat(c, s `append` " " `append` (pack $ showHex var ""),v),())) "showHexp " +showHexp :: (Num a,Integral a,Show a) => a -> STW () +showHexp var= STW(\(StatW(c,s,v)) -> (StatW(c, mappend s [Expr (pack $ showHex var "")],v),())) -- |if a is an instance of Show, showpText 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 -showpText :: Show a => a -> ST () -showpText var= ST(\(Stat(c,s,v)) -> Right(Stat(c, s `append` (snoc (pack $ show var) ' ') ,v),())) "showp: show " +showpText :: Show a => a -> STW () +showpText var= STW(\(StatW(c,s,v)) -> (StatW(c, s `mappend` [Expr $ snoc (pack $ show var) ' '] ,v),())) -- |if a is an instance of Read, readpText 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 -readpText :: Read a => ST a -readpText = ST(\(Stat(c,s,v)) -> +readpText :: Read a => STR a +readpText = STR(\(StatR(c,s,v)) -> let us= unpack s l= readsPrec 1 us in if Prelude.null l then Left . Error $ "not readable: " ++ us else let ((x,str2):_)= l - in Right(Stat(c, pack $ Prelude.dropWhile isSpace str2,v),x) ) + in Right(StatR(c, pack $ Prelude.dropWhile isSpace str2,v),x) ) "readp: readsPrec " -- | deserialize the string with the parser -runR:: ST a -> ByteString -> a +runR:: STR a -> ByteString -> a runR p str=unsafePerformIO $ do c <- newContext let (struct, vars)= readContext whereSep str return $ runRC (c, vars) p struct -- | read an expression with the variables definedd in a context passed as parameter. -runRC :: (Context, ByteString) -> ST a -> ByteString -> a -runRC (c,vars) (ST f) struct= - case f (Stat(c,struct,vars) ) of - Right (Stat _, a) -> a +runRC :: (Context, ByteString) -> STR a -> ByteString -> a +runRC (c,vars) (STR f) struct= + case f (StatR(c,struct,vars) ) of + Right (StatR _, a) -> a Left (Error s) -> error s whereSep= "\r\nwhere{\r\n " + -- | serialize x with the parser -runW :: ST () -> ByteString -runW (ST f) = unsafePerformIO $ do - c <- newContext - return $ case f (Stat(c,"","")) of - Right (Stat (c,str,_), _) -> - let scontext= assocs c - vars= B.concat $ Prelude.map (\(n,(_,_,v))->"v" `append` (pack $ show n) `append` "= " `append` v `append` ";\r\n ") scontext +runW :: STW () -> ByteString +runW f = unsafePerformIO $ do + c <- newContext + return $ runWC (c,"") f `append` showContext c True - strContext= if Prelude.null scontext then "" else whereSep `append` vars `append` "\r\n}" +-- | serialize x witn a given context and the parser +runWC ::(Context, ByteString) -> STW () -> ByteString +runWC (c,vars) (STW f) = + let + (StatW(c',str,_), _) = f (StatW(c,[],vars)) + in showExpr str c' - in str `append` strContext +-- | serialize the variables. if the Bool flag is true, it prepend the text with the string "where" +showContext :: Context -> Bool -> ByteString +showContext c False= + let scontext= assocs c + in B.concat $ Prelude.map (\(n,(_,_,v,_))->"v" `append` (pack $ show n) `append` "= " `append` showExpr v c `append` ";\r\n ") scontext - Left (Error s) -> error s +showContext c True= + let vars= showContext c False + in if B.null vars then "" else whereSep `append` vars `append` "\r\n}" --- | output the string of the serialized variable -showps :: Serialize a => a -> ST ByteString -showps x= ST(\(Stat(c,s,v))-> +showExpr :: [ShowF] -> Context -> ByteString +showExpr [] _ = B.empty +showExpr (Expr s:xs) c = s `mappend` (cons ' ' $ showExpr xs c) +showExpr ex@(Var v:xs) c= + case Data.RefSerialize.Serialize.lookup v c of + Nothing -> error $ "showp: not found first variable in "++ show ex + Just (_,_,exp,1) -> delete v c `seq` showExpr exp c `mappend` (cons ' ' $ showExpr xs c) + Just (_,_,exp,n) -> pack ('v':show v) `mappend` (cons ' ' $ showExpr xs c) + + + + -- Prelude.concat $ runRC (context,"") proc exp +-- where +-- proc = many $ choice[stringLiteral, isvar, other] +-- other= manyTill anyChar whiteSpace +-- isvar= do +-- char 'v' +-- n <- integer +-- let var= 'v': show n +-- mvar <- findVar n +-- case mvar of +-- Nothing -> return var +-- Just varExpr -> return $ showExpr varExpr context +-- +-- findVar x = ST $ \(Stat(c,s,v1))-> +-- case Data.RefSerialize.Serialize.lookup x c of +-- Nothing -> Right(Stat(c,s,v1), Nothing) +-- Just (_,_,v,n) -> +-- if n==1 then Right(Stat(delete c x,s,v1), Just v) +-- else Right(Stat(c,s,v1), Nothing) + + + +-- | return the serialization instead of updating the writer +showps :: Serialize a => a -> STW ByteString +showps x= STW(\(StatW(c,s,v))-> let - ST f= showp x - Right (Stat (c',str,_), _) = f (Stat(c,"",v)) + STW f= showp x + (StatW (c',str,_), _) = f (StatW(c,[],v)) - in Right(Stat(c',s ,v), str)) + in (StatW(c',s ,v), showExpr str c')) +-- | return the variable name of the serialized data, which is put in the context +-- and does not update the writer +rshowps x= STW(\(StatW(c,s,v))-> + let + STW f= rshowp x + (StatW (c',str,_), _) = f (StatW(c,[],v)) + in (StatW(c',s ,v), showExpr str c')) -- | 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 @@ -310,79 +312,80 @@ -- runW (insertVar showp) [(1::Int) ,1] -> [v1.v1] where { v1=1}@ -- This is useful when the object is referenced many times -insertVar :: (a -> ST ()) -> a -> ST () -insertVar parser x= ST(\(Stat(c,s,v))-> - let mf = trytofindEntireObject x c in +insertVar :: (a -> STW ()) -> a -> STW () +insertVar parser x= STW(\(StatW(c,s,v))-> + let mf = x `seq`findVar x c in case mf of - Just var -> Right(Stat(c,s `append` " " `append` var,v),()) - Nothing -> + True -> (StatW(c,s `mappend` [Var hash],v),()) + False -> let - ST f= parser x - Right (Stat (c',str,_), _) = f (Stat(c,"",v)) + STW f= parser x + (StatW (c',str,_), _) = f (StatW(c,[],v)) - in Right(Stat(addc str c',s `append` (cons ' ' varname) ,v), ())) + in (StatW(addc str c',s `mappend` [Var hash] ,v), ())) where - addc str c= insert ( hash) (st,unsafeCoerce x, str) c + addc str c= insert ( hash) (st,unsafeCoerce x, str,1) c + (hash,st) = hasht x - varname= pack$ "v" ++ show hash - trytofindEntireObject x c= - case Data.RefSerialize.Serialize.lookup hash c of - Nothing -> Nothing - Just _ -> Just varname + findVar x c= + case Data.RefSerialize.Serialize.lookup hash c of + Nothing -> False + Just (x,y,z,n) -> insert hash (x,y,z,n+1) c `seq` True -- | inform if the expression iwas already referenced and return @Right varname@ -- otherwise, add the expresion to the context and giive it a name and return @Left varname@ -- The varname is not added to the serialized expression. The user must serialize it -- This is usefu for expressions that admit different syntax depending or recursiviity, such are lists -isInVars :: (a -> ST ()) -> a -> ST (Either ByteString ByteString) -isInVars parser x= ST(\(Stat(c,s,v))-> +isInVars :: (a -> STW ()) -> a -> STW (Either ByteString ByteString) +isInVars parser x= STW(\(StatW(c,s,v))-> let mf = trytofindEntireObject x c in case mf of - Just var -> Right(Stat(c,s,v),Right var) + Just var -> (StatW(c,s,v),Right var) Nothing -> let - ST f= parser x - Right (Stat (c',str,_), _) = f (Stat(c,"",v)) + STW f= parser x + (StatW (c',str,_), _) = f (StatW(c,[],v)) - in Right(Stat(addc str c',s ,v), Left varname)) + in (StatW(addc str c',s ,v), Left varname)) where - addc str c= insert ( hash) (st,unsafeCoerce x, str) c + addc str c= insert ( hash) (st,unsafeCoerce x, str,1) c (hash,st) = hasht x varname= pack$ "v" ++ show hash trytofindEntireObject x c= case Data.RefSerialize.Serialize.lookup hash c of Nothing -> Nothing - Just _ -> Just varname + Just(x,y,z,n) -> insert hash (x,y,z,n+1) `seq` Just varname -- | deserialize a variable serialized with insertVar. Memory references are restored -readVar :: Serialize c => ST c -> ST c -readVar (ST f)= ST(\(Stat(c,s,v))-> +readVar :: Serialize c => STR c -> STR c +readVar (STR f)= STR(\stat@(StatR(c,s,v))-> let s1= B.dropWhile isSpace s (var, str2) = B.span isAlphaNum s1 str3= B.dropWhile isSpace str2 - nvar= numVar $ unpack var + mnvar= numVar $ unpack var + nvar= fromJust mnvar - in if B.null var then Left (Error "expected variable name" ) + in if isNothing mnvar then f stat else case trytofindEntireObject nvar c of - Just (_,x,_) -> Right(Stat(c,str3,v),unsafeCoerce x) + Just (_,x,_,_) -> Right(StatR(c,str3,v),unsafeCoerce x) Nothing -> let (_, rest)= readContext (var `append` "= ") v in if B.null rest then Left (Error ( "RedSerialize: readVar: " ++ unpack var ++ "value not found" )) - else case f (Stat(c,rest,v)) of + else case f (StatR(c,rest,v)) of - Right (Stat(c',s',v'),x) -> - let c''= insert nvar ( undefined, unsafeCoerce x, "") c' - in Right (Stat(c'', str3,v),x) + Right (StatR(c',s',v'),x) -> + let c''= insert nvar ( undefined, unsafeCoerce x, [],0) c' + in Right (StatR(c'', str3,v),x) err -> err) where @@ -393,12 +396,13 @@ -- | Write a String in the serialized output with an added whitespace. Deserializable with `symbol` -insertString :: ByteString -> ST () -insertString s1= ST(\(Stat(c,s,v)) -> Right(Stat(c, s `append` ( snoc s1 ' '),v),())) +insertString :: ByteString -> STW () +insertString s1= STW(\(StatW(c,s,v)) -> (StatW(c, s `mappend` [ Expr s1 ],v),())) -- | Write a char in the serialized output (no spaces) -insertChar :: Char -> ST() -insertChar car= ST(\(Stat(c,s,v)) -> Right(Stat(c, snoc s car,v),())) +insertChar :: Char -> STW() +insertChar car= STW(\(StatW(c, s,v)) -> (StatW(c, s `mappend` [Expr $ pack [car]],v),())) + -- -- -------------Instances @@ -416,7 +420,7 @@ mapM f xs insertString "]" where - f :: Serialize a => a -> ST () + f :: Serialize a => a -> STW () f x= do insertChar ',' rshowp x @@ -432,7 +436,7 @@ showpl res xs= do is <- isInVars showp xs case is of - Right v ->parensdisp (Prelude.reverse res) v + Right v -> parensdisp (Prelude.reverse res) v Left v -> showpl (v:res) xs parensdisp xs t= do @@ -575,14 +579,14 @@ binPrefixSp= append (pack binPrefix) " " -- | serialize a variable which has a Binary instance -showpBinary :: Binary a => a -> ST () +showpBinary :: Binary a => a -> STW () showpBinary x = do let s = encode x let n = pack . show $ B.length s insertString $ binPrefixSp `append` n `append` " " `append` s -- | deserialize a variable serialized by `showpBinary` -readpBinary :: Binary a => ST a +readpBinary :: Binary a => STR a readpBinary = do symbol binPrefix n <- integer @@ -591,11 +595,12 @@ return x -- return n chars form the serialized data -takep :: Int -> ST ByteString -takep n= take1 "" n +takep :: Int -> STR ByteString +takep n= take1 "" n where - take1 s 0= return s - take1 s n= anyChar >>= \x -> take1 (snoc s x) (n-1) + take1 s 0= return s + take1 s n= anyChar >>= \x -> take1 (snoc s x ) (n-1) + -- | defualt instances diff --git a/Data/RefSerialize/Parser.hs b/Data/RefSerialize/Parser.hs --- a/Data/RefSerialize/Parser.hs +++ b/Data/RefSerialize/Parser.hs @@ -1,8 +1,8 @@ {- | A Parsec parser for the refSerialize monad. See package Parsec. all the functions have the same meaning -} -module Data.RefSerialize.Parser( ST(..),(),(<|>),char,anyChar, string, upper, space, digit +module Data.RefSerialize.Parser( STR(..),StatR(..),(),(<|>),char,anyChar, string, upper, space, digit , sepBy, between, choice, option, notFollowedBy, many, manyTill, oneOf, noneOf - , bool + , bool, try, Data.RefSerialize.Parser.empty, readContent , charLiteral -- :: ST Char , stringLiteral -- :: ST String @@ -42,18 +42,18 @@ import Data.RefSerialize.Serialize import Data.ByteString.Lazy.Char8 - -data ST a= ST(Stat-> Either Error (Stat , a) ) +data StatR= StatR (Context, ByteString, ByteString) +data STR a= STR(StatR-> Either Error (StatR , a) ) -- | monadic serialization & deserialization -instance Monad ST where - return x = ST (\s -> Right (s, x)) - ST g >>= f = ST (\s -> +instance Monad STR where + return x = STR (\s -> Right (s, x)) + STR g >>= f = STR (\s -> case g s of Right (s', x)-> let - ST fun = f x + STR fun = f x in case fun s' of left@(Left msg) -> left rigth-> rigth @@ -62,8 +62,8 @@ ) -instance MonadPlus ST where - mzero= ST (\(Stat (a,b,c)) -> Left $ Error "an error occurred") +instance MonadPlus STR where + mzero= STR (\(StatR (a,b,c)) -> Left $ Error "an error occurred") mplus p1 p2 = parsecPlus p1 p2 infixr 1 <|> @@ -72,9 +72,10 @@ p msg = label p msg -parsecPlus :: ST a -> ST a -> ST a -parsecPlus (ST p1) (ST p2) - = ST (\state -> + +parsecPlus :: STR a -> STR a -> STR a +parsecPlus (STR p1) (STR p2) + = STR (\state -> case (p1 state) of Left (Error s) -> case (p2 state) of Left (Error s') -> Left $ Error ( s++ "\n"++ s') @@ -83,75 +84,100 @@ ) -label :: ST a -> String -> ST a +label :: STR a -> String -> STR a label p msg = labels p [msg] -labels :: ST a -> [String] -> ST a -labels (ST p) msgs - = ST (\state -> +labels :: STR a -> [String] -> STR a +labels (STR p) msgs + = STR (\state -> case (p state) of Left(Error reply) -> Left $ Error ( reply ++Prelude.concatMap ("\n in "++) msgs) other -> other ) -char :: Char -> ST Char +---- return n chars form the serialized data +--takep :: Int -> STR ByteString +--takep n= STR $ \(StatR(cs,s,v)) -> +-- let (h,t)= Data.ByteString.Lazy.Char8.splitAt (fromIntegral n) s in h `seq` t `seq` Right(StatR(cs,t,v), h) +-- + +char :: Char -> STR Char + unexpectedEndOfInput= "unexpected end of input" -char c= ST(\(Stat(cs,s,v)) -> +char c= STR(\(StatR(cs,s,v)) -> if null s then Left (Error $ unexpectedEndOfInput) - else if c== head s then Right(Stat(cs,tail s,v), c) + else if c== head s then Right(StatR(cs,tail s,v), c) else Left (Error ( "char "++ c:" not match " ++ '\"':unpack s++"\"" ))) -anyChar = ST(\(Stat(cs,s,v)) -> +anyChar = STR(\(StatR(cs,s,v)) -> if null s then Left (Error $ unexpectedEndOfInput) - else Right(Stat(cs,tail s,v), head s)) + else Right(StatR(cs,tail s,v), head s)) -satisfy bf= ST(\(Stat(cs,s,v)) -> let heads= head s in +satisfy bf= STR(\(StatR(cs,s,v)) -> let heads= head s in if null s then Left (Error $ unexpectedEndOfInput) - else if bf heads then Right(Stat(cs,tail s,v), heads) + else if bf heads then Right(StatR(cs,tail s,v), heads) else Left (Error ( "satisfy not matching condition in " ++ '\"':unpack s++"\"" ))) -upper = ST(\(Stat(cs,s,v)) -> let heads= head s in +upper = STR(\(StatR(cs,s,v)) -> let heads= head s in if null s then Left (Error $ unexpectedEndOfInput) - else if isUpper (head s) then Right(Stat(cs,tail s,v), head s) + else if isUpper (head s) then Right(StatR(cs,tail s,v), head s) else Left (Error ( "upper not matching condition in " ++ '\"':unpack s++"\"" ))) -space =ST(\(Stat(cs,s,v)) -> let heads= head s in +space =STR(\(StatR(cs,s,v)) -> let heads= head s in if null s then Left (Error $ unexpectedEndOfInput) - else if isSpace heads then Right(Stat(cs,tail s,v), heads) + else if isSpace heads then Right(StatR(cs,tail s,v), heads) else Left (Error ( "expected space at the head of " ++ unpack s ))) -digit1 l1 l2= ST(\(Stat(cs,s,v)) -> let c= head s in if c >= l1 && c <= l2 then Right(Stat(cs,tail s,v), c) +digit1 l1 l2= STR(\(StatR(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else let c= head s in if c >= l1 && c <= l2 + then Right(StatR(cs,tail s,v), c) else Left (Error ( "expected digit at the head of " ++ unpack s ))) -empty = ST(\(Stat(cs,s,v)) -> if null s then Right(Stat(cs, s,v), ()) +empty = STR(\(StatR(cs,s,v)) -> if null s then Right(StatR(cs, s,v), ()) else Left (Error ( "expected empty list" ))) octDigit= digit1 '0' '7' digit= digit1 '0' '9' -hexDigit= ST(\(Stat(cs,s,v)) -> let c= head s in if c >= '0' && c <= '9' || c >= 'a' && c<='f' || c >= 'A' && c <= 'F' then Right(Stat(cs,tail s,v), c) +hexDigit= STR(\(StatR(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else let c= head s in if c >= '0' && c <= '9' || c >= 'a' && c<='f' || c >= 'A' && c <= 'F' then Right(StatR(cs,tail s,v), c) else Left (Error ( "expected space at the head of " ++ unpack s ))) -oneOf xs= ST(\(Stat(cs,s,v)) -> let c= head s in if c `Prelude.elem` xs then Right(Stat(cs,tail s,v), c) +oneOf xs= STR(\(StatR(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else let c= head s in if c `Prelude.elem` xs then Right(StatR(cs,tail s,v), c) else Left (Error ( "expected digit at the head of " ++ unpack s ))) -noneOf xs= ST(\(Stat(cs,s,v)) -> let c= head s in if not $ c `Prelude.elem` xs then Right(Stat(cs,tail s,v), c) +noneOf xs= STR(\(StatR(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else let c= head s in if not $ c `Prelude.elem` xs then Right(StatR(cs,tail s,v), c) else Left (Error ( "expected digit at the head of " ++ unpack s ))) -try p= p +try p= do + (cs,s,v)<- STR $ \(StatR(cs,s,v)) -> Right(StatR(cs, s,v), (cs,s,v)) + r <- p + STR(\(StatR _) -> Right(StatR(cs, s,v), r)) + + +readContent= STR $ \(StatR(cs,s,v)) -> Right(StatR(cs,Data.ByteString.Lazy.Char8.empty,v), s) + + + unexpected msg - = ST (\state -> Left (Error $ msg++ "unexpected")) + = STR (\state -> Left (Error $ msg++ "unexpected")) -sepBy1,sepBy :: ST a -> ST sep -> ST [a] +sepBy1,sepBy :: STR a -> STR sep -> STR [a] sepBy p sep = sepBy1 p sep <|> return [] sepBy1 p sep = do{ x <- p ; xs <- many (sep >> p) @@ -196,9 +222,9 @@ bool = lexeme ( do{ symbol "True" ; return True} <|> do{ symbol "False" ; return False}) "Bool" -many :: ST a -> ST [a] +many :: STR a -> STR [a] many p = many1 p <|> return [] -many1 :: ST a -> ST [a] +many1 :: STR a -> STR [a] many1 p = do {a <- p; as <- many p; return (a:as)} @@ -226,7 +252,7 @@ ----------------------------------------------------------- -- Chars & Strings ----------------------------------------------------------- --- charLiteral :: ST Char +-- charLiteral :: STR Char charLiteral = lexeme (between (char '\'') (char '\'' "end of character") characterChar ) @@ -240,7 +266,7 @@ --- stringLiteral :: ST String +-- stringLiteral :: STR String stringLiteral = lexeme ( do{ str <- between (char '"') (char '"' "end of string") @@ -249,7 +275,7 @@ } "literal string") --- stringChar :: ST (Maybe Char) +-- stringChar :: STR (Maybe Char) stringChar = do{ c <- stringLetter; return (Just c) } <|> stringEscape "string character" @@ -273,13 +299,13 @@ escapeCode = charEsc <|> charNum <|> charAscii <|> charControl "escape code" --- charControl :: ST Char +-- charControl :: STR Char charControl = do{ char '^' ; code <- upper ; return (toEnum (fromEnum code - fromEnum 'A')) } --- charNum :: ST Char +-- charNum :: STR Char charNum = do{ code <- decimal <|> do{ char 'o'; number 8 octDigit } <|> do{ char 'x'; number 16 hexDigit } @@ -315,7 +341,7 @@ ----------------------------------------------------------- -- Numbers ----------------------------------------------------------- --- naturalOrFloat :: ST (Either Integer Double) +-- naturalOrFloat :: STR (Either Integer Double) naturalOrFloat = lexeme (natFloat) "number" float = lexeme floating "float" @@ -384,7 +410,7 @@ ; return (f n) } --- sign :: ST (Integer -> Integer) +-- sign :: STR (Integer -> Integer) sign = (char '-' >> return negate) <|> (char '+' >> return id) <|> return id @@ -401,7 +427,7 @@ octal = do{ oneOf "oO"; number 8 octDigit } - -- number :: Integer -> ST Char -> ST Integer + -- number :: Integer -> STR Char -> STR Integer number base baseDigit = do{ digits <- many1 baseDigit ; let n = Prelude.foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits @@ -420,7 +446,7 @@ --whiteSpace -whiteSpace = skipMany (simpleSpace "") +whiteSpace = skipMany (simpleSpace " ") simpleSpace = skipMany1 (satisfy isSpace) diff --git a/Data/RefSerialize/Serialize.hs b/Data/RefSerialize/Serialize.hs --- a/Data/RefSerialize/Serialize.hs +++ b/Data/RefSerialize/Serialize.hs @@ -8,7 +8,7 @@ module Data.RefSerialize.Serialize where import GHC.Exts import Unsafe.Coerce -import Data.List(isPrefixOf,insertBy,elem) +import Data.List(isPrefixOf,insertBy,elem,sortBy) import Data.Char(isAlpha,isAlphaNum,isSpace,isUpper) import System.Mem.StableName @@ -16,30 +16,53 @@ import Control.Monad (MonadPlus(..)) import Data.ByteString.Lazy.Char8 as B import qualified Data.HashTable as HT -import Data.List(sortBy) + import Data.Ord type MFun= Char -- usafeCoherced to char to store simply the address of the function type VarName = String -type ShowF= ByteString -type Context = HT.HashTable Int ( StableName MFun, MFun,ShowF) +data ShowF= Expr ByteString | Var Int deriving Show +type Context = HT.HashTable Int ( StableName MFun, MFun,[ShowF],Int) data Error= Error String -data Stat= Stat (Context, ByteString, ByteString) +data StatW= StatW (Context, [ShowF], ByteString) + +data STW a= STW(StatW-> (StatW , a) ) + +-- | monadic serialization +instance Monad STW where + return x = STW (\s -> (s, x)) + STW g >>= f = STW (\s -> + + let (s', x)= g s + STW fun = f x + in fun s' + ) + + + -- HT to map -empty = HT.new (==) HT.hashInt +empty = HT.new (==) HT.hashInt assocs = sortBy (comparing fst) . unsafePerformIO . HT.toList -insert k v ht= unsafePerformIO $ HT.insert ht k v >> return ht -lookup k ht= unsafePerformIO $ HT.lookup ht k +insert k v ht= unsafePerformIO $! HT.update ht k v >> return ht + + +delete k ht= unsafePerformIO $! HT.delete ht k >> return ht + + +lookup k ht= unsafePerformIO $! HT.lookup ht k + + toList = unsafePerformIO . HT.toList + fromList = unsafePerformIO . HT.fromList HT.hashInt @@ -64,9 +87,10 @@ -numVar :: String -> Int -numVar "" = error "refSerialize: numVar: null variable" -numVar var= read $ Prelude.tail var +numVar :: String -> Maybe Int + +numVar ('v':var)= Just $ read var +numVar _ = Nothing diff --git a/RefSerialize.cabal b/RefSerialize.cabal --- a/RefSerialize.cabal +++ b/RefSerialize.cabal @@ -1,53 +1,19 @@ name: RefSerialize -version: 0.2.8.1 -synopsis: Write to and read from Strings maintaining internal memory references +version: 0.3.0.0 +synopsis: Write to and read from ByteStrings maintaining internal memory references description: - Read, Show and Data.Binary do not check for internal data references to the same address. + Read, Show and Binary instances do not check for internal data references to the same address. As a result, the data is duplicated when serialized. 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. . - Every instance of Show/Read can be an instance of Data.RefSerialize. - . - This package allows the serialization and deserialization of large data structures without duplication of data, with - the result of optimized performance and memory usage. Since the serialized data is also human readable, It is also - useful for debugging purposes. - . - The deserializer contains a subset of Parsec.Token for defining deserializing parsers. - . - the serialized string has the form: - . - @expr( var1, ...varn) where var1=value1,..valn=valueN @ - . - so that the string can agree with the haskell syntax. - . - See demo.hs and tutorial. - . - in this release: - . - * 0.2.8.1 fixed problem with showHex Show constraint in the latter version of Numeric - . - * Serialization instance now includes an internal wiriter - . - * Solved a criitical bug only appearing in structures with many references, when StableNames started to be - freed by the gartbage colllector before serialization was completed, which gave erroneous references - . - * Bug in 0.2.5 fixed: empty lists were written with two indirections (insertVar . insertVar). That caused an error in readp - . - * Bug in 0.2.6 fixed for lists - . - * Added instances for standard datatypes. More "deeper" instances favouring more variable usage - . - * Instance of Serialize [a] changed - . - * Derived Serialize instances for Data.Binary instances: readpBinary, showpBinary - . - *- Serialization now is to/from ByteStings - + See "Data.RefSerialize" for details -category: Parsing, Data, Database + + +category: Parsing, Data, Database license: BSD3 license-file: LICENSE author: Alberto Gómez Corona @@ -58,4 +24,5 @@ exposed-modules: Data.RefSerialize, Data.RefSerialize.Parser, Data.RefSerialize.Serialize -ghc-options: -O2 +ghc-options: +