diff --git a/Data/Parser.hs b/Data/Parser.hs deleted file mode 100644 --- a/Data/Parser.hs +++ /dev/null @@ -1,428 +0,0 @@ -{- | A Parsec parser for the refSerialize monad. See package Parsec. all the functions have the same meaning --} -module Data.Parser( ST(..),(),(<|>),char,anyChar, string, upper, space, digit - , sepBy, between, choice, option, notFollowedBy, many - , bool - - , charLiteral -- :: ST Char - , stringLiteral -- :: ST String - , natural -- :: ST Integer - , integer -- :: ST Integer - , float -- :: ST Double - , naturalOrFloat -- :: ST (Either Integer Double) - , decimal -- :: ST Integer - , hexadecimal -- :: ST Integer - , octal -- :: ST Integer - - , symbol -- :: String -> ST String - , lexeme -- :: forall a. ST a -> ST a - , whiteSpace -- :: ST () - - , parens -- :: forall a. ST a -> ST a - , braces -- :: forall a. ST a -> ST a - , angles -- :: forall a. ST a -> ST a - , brackets -- :: forall a. ST a -> ST a - -- "squares" is deprecated - - , semi -- :: ST String - , comma -- :: ST String - , colon -- :: ST String - , dot -- :: ST String - , semiSep -- :: forall a . ST a -> ST [a] - , semiSep1 -- :: forall a . ST a -> ST [a] - , commaSep -- :: forall a . ST a -> ST [a] - , commaSep1 -- :: forall a . ST a -> ST [a] - - - - ) where - -import Control.Monad -import Data.Char(isUpper,isSpace,digitToInt) -import qualified Data.Map as M -import Data.Serialize - - -data ST a= ST(Stat-> Either Error (Stat , a) ) - --- | monadic serialization & deserialization -instance Monad ST where - return x = ST (\s -> Right (s, x)) - ST g >>= f = ST (\s -> - - case g s of - Right (s', x)-> - let - ST fun = f x - in case fun s' of - left@(Left msg) -> left - rigth-> rigth - - Left msg -> Left msg - - ) - -instance MonadPlus ST where - mzero= ST (\(Stat (a,b,c)) -> Left $ Error "an error occurred") - mplus p1 p2 = parsecPlus p1 p2 - -infixr 1 <|> -(<|>) = parsecPlus -infix 0 - -p msg = label p msg - -parsecPlus :: ST a -> ST a -> ST a -parsecPlus (ST p1) (ST p2) - = ST (\state -> - case (p1 state) of - Left (Error s) -> case (p2 state) of - Left (Error s') -> Left $ Error ( s++ "\n"++ s') - consumed-> consumed - other -> other - ) - - - -label :: ST a -> String -> ST a -label p msg - = labels p [msg] - -labels :: ST a -> [String] -> ST a -labels (ST p) msgs - = ST (\state -> - case (p state) of - Left(Error reply) -> Left $ Error ( reply ++concatMap ("\n in "++) msgs) - - other -> other - ) - -char :: Char -> ST Char - -char c= ST(\(Stat(cs,s,v)) -> - if null s then Left (Error $ "unexpected end of input") - else if c== head s then Right(Stat(cs,tail s,v), c) - else Left (Error ( "char "++ c:" not match " ++ '\"':s++"\"" ))) - - -anyChar = ST(\(Stat(cs,s,v)) -> - if null s then Left (Error $ "unexpected end of input") - else Right(Stat(cs,tail s,v), head s)) - -satisfy bf= ST(\(Stat(cs,s,v)) -> let heads= head s in - if null s then Left (Error $ "unexpected end of input") - else if bf heads then Right(Stat(cs,tail s,v), heads) - else Left (Error ( "satisfy not matching condition in " ++ '\"':s++"\"" ))) - - -upper = ST(\(Stat(cs,s,v)) -> let heads= head s in - if null s then Left (Error $ "unexpected end of input") - else if isUpper (head s) then Right(Stat(cs,tail s,v), head s) - else Left (Error ( "upper not matching condition in " ++ '\"':s++"\"" ))) - - -space =ST(\(Stat(cs,s,v)) -> let heads= head s in - if null s then Left (Error $ "unexpected end of input") - else if isSpace heads then Right(Stat(cs,tail s,v), heads) - else Left (Error ( "expected space at the head of " ++ 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) - else Left (Error ( "expected digit at the head of " ++ s ))) - -empty = ST(\(Stat(cs,s,v)) -> if null s then Right(Stat(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) - else Left (Error ( "expected space at the head of " ++ s ))) - -oneOf xs= ST(\(Stat(cs,s,v)) -> let c= head s in if c `elem` xs then Right(Stat(cs,tail s,v), c) - else Left (Error ( "expected digit at the head of " ++ s ))) - -noneOf xs= ST(\(Stat(cs,s,v)) -> let c= head s in if not $ c `elem` xs then Right(Stat(cs,tail s,v), c) - else Left (Error ( "expected digit at the head of " ++ s ))) - -try p= p - -unexpected msg - = ST (\state -> Left (Error $ msg++ "unexpected")) - -sepBy1,sepBy :: ST a -> ST sep -> ST [a] -sepBy p sep = sepBy1 p sep <|> return [] -sepBy1 p sep = do{ x <- p - ; xs <- many (sep >> p) - ; return (x:xs) - } - "sepBy " -between open close p - = do{ open; x <- p; close; return x } - -choice ps = foldr (<|>) mzero ps "choice " - -option x p = p <|> return x - - -notFollowedBy p = try (do{ c <- p; unexpected (show [c]) } - <|> return () - ) - - "notFollowedBy " - -skipMany1 p = do{ p; skipMany p } - -skipMany p = scan - where - scan = do{ p; scan } <|> return () - - -manyTill p end = scan - where - scan = do{ end; return [] } - <|> - do{ x <- p; xs <- scan; return (x:xs) } - - -string ""= return "" -string ys@(x:xs)= do - char x - string xs - return ys - "string "++ys - - -bool = lexeme ( do{ symbol "True" ; return True} <|> do{ symbol "False" ; return False}) "Bool" - -many :: ST a -> ST [a] -many p = many1 p <|> return [] -many1 :: ST a -> ST [a] -many1 p = do {a <- p; as <- many p; return (a:as)} - - ---from Token.hs ------------------------------------------------------------ --- Bracketing ------------------------------------------------------------ -parens p = between (symbol "(") (symbol ")") p "parens " -braces p = between (symbol "{") (symbol "}") p "braces " -angles p = between (symbol "<") (symbol ">") p "angles " -brackets p = between (symbol "[") (symbol "]") p "brackets " - -semi = symbol ";" -comma = symbol "," -dot = symbol "." -colon = symbol ":" - -commaSep p = sepBy p comma -semiSep p = sepBy p semi - -commaSep1 p = sepBy1 p comma -semiSep1 p = sepBy1 p semi - - ------------------------------------------------------------ --- Chars & Strings ------------------------------------------------------------ --- charLiteral :: ST Char -charLiteral = lexeme (between (char '\'') - (char '\'' "end of character") - characterChar ) - "character" - -characterChar = charLetter <|> charEscape - "literal character" - -charEscape = do{ char '\\'; escapeCode } -charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) - - - --- stringLiteral :: ST String -stringLiteral = lexeme ( - do{ str <- between (char '"') - (char '"' "end of string") - (many stringChar) - ; return (foldr (maybe id (:)) "" str) - } - "literal string") - --- stringChar :: ST (Maybe Char) -stringChar = do{ c <- stringLetter; return (Just c) } - <|> stringEscape - "string character" - -stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) - -stringEscape = do{ char '\\' - ; do{ escapeGap ; return Nothing } - <|> do{ escapeEmpty; return Nothing } - <|> do{ esc <- escapeCode; return (Just esc) } - } - -escapeEmpty = char '&' -escapeGap = do{ many1 space - ; char '\\' "end of string gap" - } - - - --- escape codes -escapeCode = charEsc <|> charNum <|> charAscii <|> charControl - "escape code" - --- charControl :: ST Char -charControl = do{ char '^' - ; code <- upper - ; return (toEnum (fromEnum code - fromEnum 'A')) - } - --- charNum :: ST Char -charNum = do{ code <- decimal - <|> do{ char 'o'; number 8 octDigit } - <|> do{ char 'x'; number 16 hexDigit } - ; return (toEnum (fromInteger code)) - } - -charEsc = choice (map parseEsc escMap) - where - parseEsc (c,code) = do{ char c; return code } - -charAscii = choice (map parseAscii asciiMap) - where - parseAscii (asc,code) = try (do{ string asc; return code }) - - --- escape code tables -escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") -asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) - -ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", - "FS","GS","RS","US","SP"] -ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", - "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", - "CAN","SUB","ESC","DEL"] - -ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', - '\EM','\FS','\GS','\RS','\US','\SP'] -ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', - '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', - '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] - - ------------------------------------------------------------ --- Numbers ------------------------------------------------------------ --- naturalOrFloat :: ST (Either Integer Double) -naturalOrFloat = lexeme (natFloat) "number" - -float = lexeme floating "float" -integer = lexeme int "integer" -natural = lexeme nat "natural" - - --- floats -floating = do{ n <- decimal - ; fractExponent n - } - - -natFloat = do{ char '0' - ; zeroNumFloat - } - <|> decimalFloat - -zeroNumFloat = do{ n <- hexadecimal <|> octal - ; return (Left n) - } - <|> decimalFloat - <|> fractFloat 0 - <|> return (Left 0) - -decimalFloat = do{ n <- decimal - ; option (Left n) - (fractFloat n) - } - -fractFloat n = do{ f <- fractExponent n - ; return (Right f) - } - -fractExponent n = do{ fract <- fraction - ; expo <- option 1.0 exponent' - ; return ((fromInteger n + fract)*expo) - } - <|> - do{ expo <- exponent' - ; return ((fromInteger n)*expo) - } - -fraction = do{ char '.' - ; digits <- many1 digit "fraction" - ; return (foldr op 0.0 digits) - } - "fraction" - where - op d f = (f + fromIntegral (digitToInt d))/10.0 - -exponent' = do{ oneOf "eE" - ; f <- sign - ; e <- decimal "exponent" - ; return (power (f e)) - } - "exponent" - where - power e | e < 0 = 1.0/power(-e) - | otherwise = fromInteger (10^e) - - --- integers and naturals -int = do{ f <- lexeme sign - ; n <- nat - ; return (f n) - } - --- sign :: ST (Integer -> Integer) -sign = (char '-' >> return negate) - <|> (char '+' >> return id) - <|> return id - -nat = zeroNumber <|> decimal - -zeroNumber = do{ char '0' - ; hexadecimal <|> octal <|> decimal <|> return 0 - } - "" - -decimal = number 10 digit -hexadecimal = do{ oneOf "xX"; number 16 hexDigit } -octal = do{ oneOf "oO"; number 8 octDigit } - - - -- number :: Integer -> ST Char -> ST Integer -number base baseDigit - = do{ digits <- many1 baseDigit - ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits - ; seq n (return n) - } - - ------------------------------------------------------------ --- White space & symbols ------------------------------------------------------------ -symbol name - = lexeme (string name) "symbol" - -lexeme p - = do{ x <- p; whiteSpace ; return x } - - ---whiteSpace -whiteSpace = skipMany (simpleSpace "") - - -simpleSpace = skipMany1 (satisfy isSpace) - - diff --git a/Data/RefSerialize.hs b/Data/RefSerialize.hs --- a/Data/RefSerialize.hs +++ b/Data/RefSerialize.hs @@ -1,4 +1,9 @@ -{-# OPTIONS -fglasgow-exts -XOverlappingInstances #-} +{-# OPTIONS -XOverlappingInstances + -XTypeSynonymInstances + -XFlexibleInstances + -XUndecidableInstances + -XOverloadedStrings + #-} ----------------------------------------------------------------------------- -- @@ -10,158 +15,178 @@ -- 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; }@ +{- | Read, Show and Data.Binary do not check for repeated 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. + 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]; }" + + + + "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 + + + 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 + module Data.RefSerialize.Parser ,Serialize( showp - ,readp - - ,rshowp - - ,rreadp - - ) - ,showSR - ,readSR + ) + ,Context + ,newContext + ,rshowp + ,rreadp + ,showps + ,showpText + ,readpText + ,takep + ,showpBinary + ,readpBinary + ,insertString + ,insertChar ,rShow ,rRead ,insertVar ,readVar ,varName ,runR + ,runRC ,runW + ,readHexp ,showHexp + ,getContext + ) where -import qualified Data.Map as M -import Data.Serialize -import Data.Parser + +import Data.RefSerialize.Serialize +import Data.RefSerialize.Parser import Unsafe.Coerce import Data.Char(isAlpha, isSpace, isAlphaNum) import Numeric(readHex,showHex) -import Data.Map +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 -class Serialize c where - - showp :: c -> ST String -- ^ shows the content of a expression, must be defined bu the user +newContext :: IO Context +newContext = Data.RefSerialize.Serialize.empty - readp :: ST c -- ^ read the content of a expression, must be user defined +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 - rshowp :: c -> ST String -- ^ insert a reference (a variable in the where section). @rshowp = insertVar showp @ -- default definition +-- | insert a reference (a variable in the where section). - rshowp = insertVar showp +-- @rshowp = insertVar showp @ +rshowp :: Serialize c => c -> ST () +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 + -- | read a variable in the where section (to use for deserializing rshowp output). + -- @rreadp = readVar readp@ +rreadp :: Serialize c => ST c +rreadp = readVar readp {- #ifdef Axioms @@ -181,70 +206,99 @@ } #endif -} + + + +-- | return the serialized list of variable values +-- 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))) + -- | use the rshowp parser to serialize the object -- @ rShow c= runW $ rshowp c@ -rShow :: Serialize c => c -> String -rShow c= runW $ rshowp c +rShow :: Serialize c => c -> ByteString +rShow c= runW $ showp c -- | deserialize trough the rreadp parser -- @ rRead str= runR rreadp $ str@ -rRead :: Serialize c => String -> c -rRead str= runR rreadp $ str +rRead :: Serialize c => ByteString -> c +rRead str= runR readp $ 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 + let us= unpack s + l= readHex 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) ) + "readHexp " + + + +showHexp :: (Num a,Integral a) => a -> ST () +showHexp var= ST(\(Stat(c,s,v)) -> Right(Stat(c, s `append` " " `append` (pack $ showHex var ""),v),())) "showHexp " + +-- |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 -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 " +showpText :: Show a => a -> ST () +showpText var= ST(\(Stat(c,s,v)) -> Right(Stat(c, s `append` (snoc (pack $ show var) ' ') ,v),())) "showp: show " +-- |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)) -> + 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) ) + "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 " +runR:: ST a -> ByteString -> a +runR p str=unsafePerformIO $ do + c <- newContext + let (struct, vars)= readContext whereSep str + return $ runRC (c, vars) p struct --- |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 " +-- | 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 + Left (Error s) -> error s +whereSep= "\r\nwhere{\r\n " -- | 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 ++ "}" +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 - in str ++ strContext + strContext= if Prelude.null scontext then "" else whereSep `append` vars `append` "\r\n}" + in str `append` strContext + Left (Error s) -> error s +-- | output the string of the serialized variable +showps :: Serialize a => a -> ST ByteString +showps x= ST(\(Stat(c,s,v))-> + let + ST f= showp x + Right (Stat (c',str,_), _) = f (Stat(c,"",v)) + in Right(Stat(c',s ,v), str)) @@ -256,85 +310,175 @@ -- 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 :: (a -> ST ()) -> a -> ST () 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) + Just var -> Right(Stat(c,s `append` " " `append` var,v),()) Nothing -> let ST f= parser x - Right (Stat (c',_,_), str) = f (Stat(c,s,v)) + Right (Stat (c',str,_), _) = f (Stat(c,"",v)) - in Right(Stat(addc str c',s,v), ' ':varname)) + in Right(Stat(addc str c',s `append` (cons ' ' varname) ,v), ())) where - addc str c= M.insert ( hash) (unsafeCoerce x, str) c - hash = hasht x - varname= "v" ++ show hash + addc str c= insert ( hash) (st,unsafeCoerce x, str) c + (hash,st) = hasht x + varname= pack$ "v" ++ show hash trytofindEntireObject x c= - case M.lookup hash c of + case Data.RefSerialize.Serialize.lookup hash c of Nothing -> Nothing Just _ -> Just varname +-- | 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))-> + let mf = trytofindEntireObject x c in + case mf of + Just var -> Right(Stat(c,s,v),Right var) + Nothing -> + let + ST f= parser x + Right (Stat (c',str,_), _) = f (Stat(c,"",v)) + + in Right(Stat(addc str c',s ,v), Left varname)) + where + addc str c= insert ( hash) (st,unsafeCoerce x, str) 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 + + + -- | 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 +readVar (ST f)= ST(\(Stat(c,s,v))-> + let + s1= B.dropWhile isSpace s + (var, str2) = B.span isAlphaNum s1 + str3= B.dropWhile isSpace str2 + nvar= numVar $ unpack var - in case trytofindEntireObject (numVar var) c of + in if B.null var then Left (Error "expected variable name" ) + else + case trytofindEntireObject nvar c of - Just (x,_) -> Right(Stat(c,str2,v),unsafeCoerce x) + Just (_,x,_) -> Right(Stat(c,str3,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 + (_, 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 + Right (Stat(c',s',v'),x) -> - let c''= M.insert (numVar var) (unsafeCoerce x, "") c' - in Right (Stat(c'',str2,v),x) + let c''= insert nvar ( undefined, unsafeCoerce x, "") c' + in Right (Stat(c'', str3,v),x) err -> err) where trytofindEntireObject x c= - case M.lookup x c of + case Data.RefSerialize.Serialize.lookup x c of Nothing -> Nothing justx -> justx --- -------------Instances +-- | 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),())) +-- | 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),())) +-- +-- -------------Instances + instance Serialize String where - showp = showSR - readp = readSR + showp = showpText + readp = readpText + instance Serialize a => Serialize [a] where - showp []= return "[]" + showp []= insertString "[]" showp (x:xs)= do - s1<- rshowp x - sn<- mapM f xs - return $ "["++ s1++ concat sn ++"]" + insertChar '[' + rshowp x + mapM f xs + insertString "]" where - f x= do str <- rshowp (x:: a) - return $ ", "++str + f :: Serialize a => a -> ST () + f x= do + insertChar ',' + rshowp x - readp = (brackets $ commaSep $ rreadp) "rreadp:: [] " + readp = (brackets . commaSep $ rreadp) "readp:: [] " +{- +instance Serialize a => Serialize [a] where + showp xs= showpl [] xs + where + showpl res []= bracketdisp $ Prelude.reverse res + showpl res xs= do + is <- isInVars showp xs + case is of + Right v ->parensdisp (Prelude.reverse res) v + Left v -> showpl (v:res) xs + parensdisp xs t= do + insertChar '(' + disp ':' xs + insertChar ':' + insertString t + insertString ")" + bracketdisp []= insertString "[]" + bracketdisp xs= do + insertChar '[' + disp ',' xs + insertString "]" + disp sep (x:xs)= do + insertString x + mapM f xs + where + + f x= do + insertChar sep + insertString x + + readp= choice [bracketsscan, parensscan] "readp:: [] " + where + bracketsscan= (brackets . commaSep $ rreadp) "readp:: [] " + parensscan=parens $ do + xs <- many(rreadp >>= \x -> symbol ":" >> return x) + end <- rreadp + return $ xs ++ end + + +-} + + + instance (Serialize a, Serialize b) => Serialize (a, b) where showp (x, y)= do - sx <- rshowp x - sy <- rshowp y - return $ "("++ sx ++ "," ++ sy ++ ")" + insertString "(" + rshowp x + insertString "," + rshowp y + insertString ")" + readp = parens (do x <- rreadp comma @@ -344,11 +488,15 @@ 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 ++ ")" + insertString "(" + rshowp x + insertString "," + rshowp y + insertString "," + rshowp z + insertString ")" + readp = parens (do x <- rreadp comma @@ -360,12 +508,17 @@ 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 ++ ")" + insertString "(" + rshowp x + insertString "," + rshowp y + insertString "," + rshowp z + insertString "," + rshowp t + insertString ")" + readp = parens (do x <- rreadp comma @@ -377,26 +530,36 @@ return (x,y,z,t)) "rreadp:: (,,,) " -instance (Serialize a, Ord a, Serialize b) => Serialize (Map a b) where +instance (Serialize a, Ord a, Serialize b) => Serialize (M.Map a b) where showp m= showp $ M.toList m readp= do - list <- readp :: ST [(a,b)] + 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 + showp Nothing = insertString "Nothing" + showp (Just x) =do + insertString "Just" + showp x + readp = choice [rNothing, rJust] where rNothing = symbol "Nothing" >> return Nothing - rJust = symbol "Just" >> readp >>= \x -> return $ Just x + rJust = do + symbol "Just" + x <- readp + return $ Just x instance (Serialize a, Serialize b) => Serialize (Either a b) where - showp (Left x) = rshowp x >>= \sx -> return $ "Left " ++ sx + showp (Left x) = do + insertString "Left" + rshowp x - showp (Right x) = rshowp x >>= \sx -> return $ "Right " ++ sx + showp (Right x) = do + insertString "Right" + rshowp x readp = choice [rLeft, rRight] where rLeft = symbol "Left" >> rreadp >>= \x -> return $ Left x @@ -405,44 +568,40 @@ - -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 +-- binary serialization -instance Serialize Integer where - showp = showSR - readp = readSR - -instance Serialize Ordering where - showp = showSR - readp = readSR - -instance Serialize () where - showp = showSR - readp = readSR +binPrefix= "Bin " +binPrefixSp= append (pack binPrefix) " " +-- | serialize a variable which has a Binary instance +showpBinary :: Binary a => a -> ST () +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 = do + symbol binPrefix + n <- integer + str <- takep $ fromIntegral n + let x = decode str + return x +-- return n chars form the serialized data +takep :: Int -> ST ByteString +takep n= take1 "" n + where + take1 s 0= return s + take1 s n= anyChar >>= \x -> take1 (snoc s x) (n-1) +-- | defualt instances +instance (Show a, Read a )=> Serialize a where + showp= showpText + readp= readpText diff --git a/Data/RefSerialize/Parser.hs b/Data/RefSerialize/Parser.hs new file mode 100644 --- /dev/null +++ b/Data/RefSerialize/Parser.hs @@ -0,0 +1,428 @@ +{- | 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 + , sepBy, between, choice, option, notFollowedBy, many, manyTill, oneOf, noneOf + , bool + + , charLiteral -- :: ST Char + , stringLiteral -- :: ST String + , natural -- :: ST Integer + , integer -- :: ST Integer + , float -- :: ST Double + , naturalOrFloat -- :: ST (Either Integer Double) + , decimal -- :: ST Integer + , hexadecimal -- :: ST Integer + , octal -- :: ST Integer + + , symbol -- :: String -> ST String + , lexeme -- :: forall a. ST a -> ST a + , whiteSpace -- :: ST () + + , parens -- :: forall a. ST a -> ST a + , braces -- :: forall a. ST a -> ST a + , angles -- :: forall a. ST a -> ST a + , brackets -- :: forall a. ST a -> ST a + -- "squares" is deprecated + + , semi -- :: ST String + , comma -- :: ST String + , colon -- :: ST String + , dot -- :: ST String + , semiSep -- :: forall a . ST a -> ST [a] + , semiSep1 -- :: forall a . ST a -> ST [a] + , commaSep -- :: forall a . ST a -> ST [a] + , commaSep1 -- :: forall a . ST a -> ST [a] + + + ) where +import Prelude hiding(head,tail, null) +import Control.Monad +import Data.Char(isUpper,isSpace,digitToInt) +import qualified Data.Map as M +import Data.RefSerialize.Serialize +import Data.ByteString.Lazy.Char8 + + +data ST a= ST(Stat-> Either Error (Stat , a) ) + +-- | monadic serialization & deserialization +instance Monad ST where + return x = ST (\s -> Right (s, x)) + ST g >>= f = ST (\s -> + + case g s of + Right (s', x)-> + let + ST fun = f x + in case fun s' of + left@(Left msg) -> left + rigth-> rigth + + Left msg -> Left msg + + ) + +instance MonadPlus ST where + mzero= ST (\(Stat (a,b,c)) -> Left $ Error "an error occurred") + mplus p1 p2 = parsecPlus p1 p2 + +infixr 1 <|> +(<|>) = parsecPlus +infix 0 + +p msg = label p msg + +parsecPlus :: ST a -> ST a -> ST a +parsecPlus (ST p1) (ST p2) + = ST (\state -> + case (p1 state) of + Left (Error s) -> case (p2 state) of + Left (Error s') -> Left $ Error ( s++ "\n"++ s') + consumed-> consumed + other -> other + ) + + +label :: ST a -> String -> ST a +label p msg + = labels p [msg] + +labels :: ST a -> [String] -> ST a +labels (ST p) msgs + = ST (\state -> + case (p state) of + Left(Error reply) -> Left $ Error ( reply ++Prelude.concatMap ("\n in "++) msgs) + + other -> other + ) + +char :: Char -> ST Char + +unexpectedEndOfInput= "unexpected end of input" +char c= ST(\(Stat(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else if c== head s then Right(Stat(cs,tail s,v), c) + else Left (Error ( "char "++ c:" not match " ++ '\"':unpack s++"\"" ))) + + +anyChar = ST(\(Stat(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else Right(Stat(cs,tail s,v), head s)) + +satisfy bf= ST(\(Stat(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 Left (Error ( "satisfy not matching condition in " ++ '\"':unpack s++"\"" ))) + + +upper = ST(\(Stat(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 Left (Error ( "upper not matching condition in " ++ '\"':unpack s++"\"" ))) + + +space =ST(\(Stat(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 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) + 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), ()) + 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) + 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) + 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) + else Left (Error ( "expected digit at the head of " ++ unpack s ))) + +try p= p + +unexpected msg + = ST (\state -> Left (Error $ msg++ "unexpected")) + +sepBy1,sepBy :: ST a -> ST sep -> ST [a] +sepBy p sep = sepBy1 p sep <|> return [] +sepBy1 p sep = do{ x <- p + ; xs <- many (sep >> p) + ; return (x:xs) + } + "sepBy " +between open close p + = do{ open; x <- p; close; return x } + +choice ps = Prelude.foldr (<|>) mzero ps "choice " + +option x p = p <|> return x + + +notFollowedBy p = try (do{ c <- p; unexpected (show [c]) } + <|> return () + ) + + "notFollowedBy " + +skipMany1 p = do{ p; skipMany p } + +skipMany p = scan + where + scan = do{ p; scan } <|> return () + + +manyTill p end = scan + where + scan = do{ end; return [] } + <|> + do{ x <- p; xs <- scan; return (x:xs) } + + +string ""= return "" +string ys@(x:xs)= do + char x + string xs + return ys + "string "++ys + + +bool = lexeme ( do{ symbol "True" ; return True} <|> do{ symbol "False" ; return False}) "Bool" + +many :: ST a -> ST [a] +many p = many1 p <|> return [] +many1 :: ST a -> ST [a] +many1 p = do {a <- p; as <- many p; return (a:as)} + + +--from Token.hs +----------------------------------------------------------- +-- Bracketing +----------------------------------------------------------- +parens p = between (symbol "(") (symbol ")") p "parens " +braces p = between (symbol "{") (symbol "}") p "braces " +angles p = between (symbol "<") (symbol ">") p "angles " +brackets p = between (symbol "[") (symbol "]") p "brackets " + +semi = symbol ";" +comma = symbol "," +dot = symbol "." +colon = symbol ":" + +commaSep p = sepBy p comma +semiSep p = sepBy p semi + +commaSep1 p = sepBy1 p comma +semiSep1 p = sepBy1 p semi + + +----------------------------------------------------------- +-- Chars & Strings +----------------------------------------------------------- +-- charLiteral :: ST Char +charLiteral = lexeme (between (char '\'') + (char '\'' "end of character") + characterChar ) + "character" + +characterChar = charLetter <|> charEscape + "literal character" + +charEscape = do{ char '\\'; escapeCode } +charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) + + + +-- stringLiteral :: ST String +stringLiteral = lexeme ( + do{ str <- between (char '"') + (char '"' "end of string") + (many stringChar) + ; return (Prelude.foldr (maybe id (:)) "" str) + } + "literal string") + +-- stringChar :: ST (Maybe Char) +stringChar = do{ c <- stringLetter; return (Just c) } + <|> stringEscape + "string character" + +stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) + +stringEscape = do{ char '\\' + ; do{ escapeGap ; return Nothing } + <|> do{ escapeEmpty; return Nothing } + <|> do{ esc <- escapeCode; return (Just esc) } + } + +escapeEmpty = char '&' +escapeGap = do{ many1 space + ; char '\\' "end of string gap" + } + + + +-- escape codes +escapeCode = charEsc <|> charNum <|> charAscii <|> charControl + "escape code" + +-- charControl :: ST Char +charControl = do{ char '^' + ; code <- upper + ; return (toEnum (fromEnum code - fromEnum 'A')) + } + +-- charNum :: ST Char +charNum = do{ code <- decimal + <|> do{ char 'o'; number 8 octDigit } + <|> do{ char 'x'; number 16 hexDigit } + ; return (toEnum (fromInteger code)) + } + +charEsc = choice (Prelude.map parseEsc escMap) + where + parseEsc (c,code) = do{ char c; return code } + +charAscii = choice (Prelude.map parseAscii asciiMap) + where + parseAscii (asc,code) = try (do{ string asc; return code }) + + +-- escape code tables +escMap = Prelude.zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") +asciiMap = Prelude.zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) + +ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", + "FS","GS","RS","US","SP"] +ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", + "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", + "CAN","SUB","ESC","DEL"] + +ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', + '\EM','\FS','\GS','\RS','\US','\SP'] +ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', + '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', + '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] + + +----------------------------------------------------------- +-- Numbers +----------------------------------------------------------- +-- naturalOrFloat :: ST (Either Integer Double) +naturalOrFloat = lexeme (natFloat) "number" + +float = lexeme floating "float" +integer = lexeme int "integer" +natural = lexeme nat "natural" + + +-- floats +floating = do{ n <- decimal + ; fractExponent n + } + + +natFloat = do{ char '0' + ; zeroNumFloat + } + <|> decimalFloat + +zeroNumFloat = do{ n <- hexadecimal <|> octal + ; return (Left n) + } + <|> decimalFloat + <|> fractFloat 0 + <|> return (Left 0) + +decimalFloat = do{ n <- decimal + ; option (Left n) + (fractFloat n) + } + +fractFloat n = do{ f <- fractExponent n + ; return (Right f) + } + +fractExponent n = do{ fract <- fraction + ; expo <- option 1.0 exponent' + ; return ((fromInteger n + fract)*expo) + } + <|> + do{ expo <- exponent' + ; return ((fromInteger n)*expo) + } + +fraction = do{ char '.' + ; digits <- many1 digit "fraction" + ; return (Prelude.foldr op 0.0 digits) + } + "fraction" + where + op d f = (f + fromIntegral (digitToInt d))/10.0 + +exponent' = do{ oneOf "eE" + ; f <- sign + ; e <- decimal "exponent" + ; return (power (f e)) + } + "exponent" + where + power e | e < 0 = 1.0/power(-e) + | otherwise = fromInteger (10^e) + + +-- integers and naturals +int = do{ f <- lexeme sign + ; n <- nat + ; return (f n) + } + +-- sign :: ST (Integer -> Integer) +sign = (char '-' >> return negate) + <|> (char '+' >> return id) + <|> return id + +nat = zeroNumber <|> decimal + +zeroNumber = do{ char '0' + ; hexadecimal <|> octal <|> decimal <|> return 0 + } + "" + +decimal = number 10 digit +hexadecimal = do{ oneOf "xX"; number 16 hexDigit } +octal = do{ oneOf "oO"; number 8 octDigit } + + + -- number :: Integer -> ST Char -> ST Integer +number base baseDigit + = do{ digits <- many1 baseDigit + ; let n = Prelude.foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits + ; seq n (return n) + } + + +----------------------------------------------------------- +-- White space & symbols +----------------------------------------------------------- +symbol name + = lexeme (string name) "symbol" + +lexeme p + = do{ x <- p; whiteSpace ; return x } + + +--whiteSpace +whiteSpace = skipMany (simpleSpace "") + + +simpleSpace = skipMany1 (satisfy isSpace) + + diff --git a/Data/RefSerialize/Serialize.hs b/Data/RefSerialize/Serialize.hs new file mode 100644 --- /dev/null +++ b/Data/RefSerialize/Serialize.hs @@ -0,0 +1,72 @@ +{-# OPTIONS -XOverlappingInstances + -XTypeSynonymInstances + -XFlexibleInstances + -XUndecidableInstances + -XOverloadedStrings + -XNoMonomorphismRestriction + #-} +module Data.RefSerialize.Serialize where +import GHC.Exts +import Unsafe.Coerce +import Data.List(isPrefixOf,insertBy,elem) +import Data.Char(isAlpha,isAlphaNum,isSpace,isUpper) + +import System.Mem.StableName +import System.IO.Unsafe +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 Error= Error String +data Stat= Stat (Context, ByteString, ByteString) + + +-- HT to map +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 + +toList = unsafePerformIO . HT.toList + +fromList = unsafePerformIO . HT.fromList HT.hashInt + + +readContext :: ByteString -> ByteString -> (ByteString, ByteString) +readContext pattern str= readContext1 (pack "") str where + + readContext1 :: ByteString -> ByteString -> (ByteString, ByteString) + readContext1 s str| B.null str = (s, pack "") + | pattern `B.isPrefixOf` str = (s, B.drop n str) + | otherwise= readContext1 (snoc s (B.head str)) (B.tail str) + where n= fromIntegral $ B.length pattern + + +hasht x= unsafePerformIO $ do + st <- makeStableName $! x + return (hashStableName st,unsafeCoerce st) + +-- ! two variables that point to the same address will have identical varname (derived from import System.Mem.StableName)varName:: a -> String +varName x= "v"++ (show . hash) x + where hash x= let (ht,_)= hasht x in ht + + + + +numVar :: String -> Int +numVar "" = error "refSerialize: numVar: null variable" +numVar var= read $ Prelude.tail var + + + diff --git a/Data/Serialize.hs b/Data/Serialize.hs deleted file mode 100644 --- a/Data/Serialize.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -module Data.Serialize where -import GHC.Exts -import Unsafe.Coerce -import Data.List(isPrefixOf,insertBy,elem) -import Data.Char(isAlpha,isAlphaNum,isSpace,isUpper) -import qualified Data.Map as M -import System.Mem.StableName -import System.IO.Unsafe -import Control.Monad (MonadPlus(..)) - -import Debug.Trace - -debug a b= trace b a - - - -type MFun= Char -- usafeCoherced to char to store simply the address of the function -type VarName = String -type ShowF= String -type Context = M.Map Int (MFun,ShowF) - -data Error= Error String -data Stat= Stat (Context, String, String) - - - -readContext pattern str= readContext1 "" str where - readContext1 s str| null str = (s,"") - | pattern `isPrefixOf` str = (s,drop n str) - | otherwise= readContext1 (s++[head str]) (tail str) - where n= length pattern - - - -hasht x= (hashStableName . unsafePerformIO . makeStableName) x - --- ! two variables that point to the same address will have identical varname (derived from import System.Mem.StableName) -varName:: a -> String -varName x= "v"++ (show . hasht) x - - - - -numVar :: String -> Int -numVar var= read $ tail var - - - diff --git a/RefSerialize.cabal b/RefSerialize.cabal --- a/RefSerialize.cabal +++ b/RefSerialize.cabal @@ -1,5 +1,5 @@ name: RefSerialize -version: 0.2.7 +version: 0.2.8 synopsis: Write to and read from Strings maintaining internal memory references description: Read, Show and Data.Binary do not check for internal data references to the same address. @@ -27,32 +27,33 @@ . in this release: . - * bug in 0.2.5 corrected: empty lists were written with two indirections (insertVar . insertVar). That caused an error in readp + * Serialization instance now includes an internal wiriter . - * bug in 0.2.6 corrected for lists + * 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 . - * removed the problematic instance (Show a, Read a) => Serialize a + * 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 - . - To do: - . - -derived instances for Data.Binary - . - -serialization to/from ByteStings + * Instance of Serialize [a] changed + . + * Derived Serialize instances for Data.Binary instances: readpBinary, showpBinary + . + *- Serialization now is to/from ByteStings -category: Parsing, Data, Database -license: BSD3 -license-file: LICENSE -author: Alberto Gómez Corona -maintainer: agocorona@gmail.com -Tested-With: GHC == 6.8.2 +category: Parsing, Data, Database +license: BSD3 +license-file: LICENSE +author: Alberto Gómez Corona +maintainer: agocorona@gmail.com +Tested-With: GHC == 6.8.2 Build-Type: Simple -build-Depends: base >=3 && <4,containers -Cabal-Version: >= 1.2 +build-Depends: binary,bytestring, base >=4 && <5,containers -exposed-modules: Data.RefSerialize, Data.Parser, Data.Serialize + +exposed-modules: Data.RefSerialize, Data.RefSerialize.Parser, Data.RefSerialize.Serialize ghc-options: -O2