RefSerialize 0.2.7 → 0.2.8

raw patch · 6 files changed

+920/−737 lines, 6 filesdep +binarydep +bytestringdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: binary, bytestring

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/Parser.hs +0/−428
• Data/RefSerialize.hs +399/−240
• Data/RefSerialize/Parser.hs +428/−0
• Data/RefSerialize/Serialize.hs +72/−0
• Data/Serialize.hs +0/−49
• RefSerialize.cabal +21/−20

@@ -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)--

@@ -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 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; }@+{- | 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   

@@ -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)++

@@ -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+++

@@ -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---

@@ -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