diff --git a/Data/RefSerialize/Parser.hs b/Data/RefSerialize/Parser.hs --- a/Data/RefSerialize/Parser.hs +++ b/Data/RefSerialize/Parser.hs @@ -1,454 +1,481 @@ -{- | A Parsec parser for the refSerialize monad. See package Parsec. all the functions have the same meaning --} -module Data.RefSerialize.Parser( STR(..),StatR(..),(),(<|>),char,anyChar, string, upper, space, digit - , sepBy, between, choice, option, notFollowedBy, many, manyTill, oneOf, noneOf - , bool, try, Data.RefSerialize.Parser.empty, readContent - - , 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 StatR= StatR (Context, ByteString, ByteString) -data STR a= STR(StatR-> Either Error (StatR , a) ) - --- | monadic serialization & deserialization -instance Monad STR where - return x = STR (\s -> Right (s, x)) - STR g >>= f = STR (\s -> - - case g s of - Right (s', x)-> - let - STR fun = f x - in case fun s' of - left@(Left msg) -> left - rigth-> rigth - - Left msg -> Left msg - - ) - -instance MonadPlus STR where - mzero= STR (\(StatR (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 :: STR a -> STR a -> STR a -parsecPlus (STR p1) (STR p2) - = STR (\state -> - case (p1 state) of - Left (Error s) -> case (p2 state) of - Left (Error s') -> Left $ Error ( s++ "\n"++ s') - consumed-> consumed - other -> other - ) - - -label :: STR a -> String -> STR a -label p msg - = labels p [msg] - -labels :: STR a -> [String] -> STR a -labels (STR p) msgs - = STR (\state -> - case (p state) of - Left(Error reply) -> Left $ Error ( reply ++Prelude.concatMap ("\n in "++) msgs) - - other -> other - ) - ----- return n chars form the serialized data ---takep :: Int -> STR ByteString ---takep n= STR $ \(StatR(cs,s,v)) -> --- let (h,t)= Data.ByteString.Lazy.Char8.splitAt (fromIntegral n) s in h `seq` t `seq` Right(StatR(cs,t,v), h) --- - - -char :: Char -> STR Char - -unexpectedEndOfInput= "unexpected end of input" -char c= STR(\(StatR(cs,s,v)) -> - if null s then Left (Error $ unexpectedEndOfInput) - else if c== head s then Right(StatR(cs,tail s,v), c) - else Left (Error ( "char "++ c:" not match " ++ '\"':unpack s++"\"" ))) - - -anyChar = STR(\(StatR(cs,s,v)) -> - if null s then Left (Error $ unexpectedEndOfInput) - else Right(StatR(cs,tail s,v), head s)) - -satisfy bf= STR(\(StatR(cs,s,v)) -> let heads= head s in - if null s then Left (Error $ unexpectedEndOfInput) - else if bf heads then Right(StatR(cs,tail s,v), heads) - else Left (Error ( "satisfy not matching condition in " ++ '\"':unpack s++"\"" ))) - - -upper = STR(\(StatR(cs,s,v)) -> let heads= head s in - if null s then Left (Error $ unexpectedEndOfInput) - else if isUpper (head s) then Right(StatR(cs,tail s,v), head s) - else Left (Error ( "upper not matching condition in " ++ '\"':unpack s++"\"" ))) - - -space =STR(\(StatR(cs,s,v)) -> let heads= head s in - if null s then Left (Error $ unexpectedEndOfInput) - else if isSpace heads then Right(StatR(cs,tail s,v), heads) - else Left (Error ( "expected space at the head of " ++ unpack s ))) - - -digit1 l1 l2= STR(\(StatR(cs,s,v)) -> - if null s then Left (Error $ unexpectedEndOfInput) - else let c= head s in if c >= l1 && c <= l2 - then Right(StatR(cs,tail s,v), c) - else Left (Error ( "expected digit at the head of " ++ unpack s ))) - -empty = STR(\(StatR(cs,s,v)) -> if null s then Right(StatR(cs, s,v), ()) - else Left (Error ( "expected empty list" ))) - -octDigit= digit1 '0' '7' - -digit= digit1 '0' '9' - -hexDigit= STR(\(StatR(cs,s,v)) -> - if null s then Left (Error $ unexpectedEndOfInput) - else let c= head s in if c >= '0' && c <= '9' || c >= 'a' && c<='f' || c >= 'A' && c <= 'F' then Right(StatR(cs,tail s,v), c) - else Left (Error ( "expected space at the head of " ++ unpack s ))) - -oneOf xs= STR(\(StatR(cs,s,v)) -> - if null s then Left (Error $ unexpectedEndOfInput) - else let c= head s in if c `Prelude.elem` xs then Right(StatR(cs,tail s,v), c) - else Left (Error ( "expected digit at the head of " ++ unpack s ))) - -noneOf xs= STR(\(StatR(cs,s,v)) -> - if null s then Left (Error $ unexpectedEndOfInput) - else let c= head s in if not $ c `Prelude.elem` xs then Right(StatR(cs,tail s,v), c) - else Left (Error ( "expected digit at the head of " ++ unpack s ))) - -try p= do - (cs,s,v)<- STR $ \(StatR(cs,s,v)) -> Right(StatR(cs, s,v), (cs,s,v)) - r <- p - STR(\(StatR _) -> Right(StatR(cs, s,v), r)) - - - -readContent= STR $ \(StatR(cs,s,v)) -> Right(StatR(cs,Data.ByteString.Lazy.Char8.empty,v), s) - - - -unexpected msg - = STR (\state -> Left (Error $ msg++ "unexpected")) - -sepBy1,sepBy :: STR a -> STR sep -> STR [a] -sepBy p sep = sepBy1 p sep <|> return [] -sepBy1 p sep = do{ x <- p - ; xs <- many (sep >> p) - ; 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 :: STR a -> STR [a] -many p = many1 p <|> return [] -many1 :: STR a -> STR [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 :: STR 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 :: STR String -stringLiteral = lexeme ( - do{ str <- between (char '"') - (char '"' "end of string") - (many stringChar) - ; return (Prelude.foldr (maybe id (:)) "" str) - } - "literal string") - --- stringChar :: STR (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 :: STR Char -charControl = do{ char '^' - ; code <- upper - ; return (toEnum (fromEnum code - fromEnum 'A')) - } - --- charNum :: STR 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 :: STR (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 :: STR (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 -> STR Char -> STR 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) - +{- | A Parsec parser for the refSerialize monad. See package Parsec. all the functions have the same meaning +-} +module Data.RefSerialize.Parser( STR(..),StatR(..),(),(<|>),char,anyChar, string, upper, space, digit + , sepBy, between, choice, option, notFollowedBy, many, manyTill, oneOf, noneOf + , bool, try, Data.RefSerialize.Parser.empty, readContent + + , 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 +import Control.Applicative hiding ( (<|>),many) +import qualified Control.Applicative as CA((<|>),many) + +data StatR= StatR (Context, ByteString, ByteString) +data STR a= STR(StatR -> Either Error (StatR , a) ) + +instance Functor STR where + fmap f (STR strx)= STR $ \s -> + let mr = strx s + in case mr of + Right (s',x) -> Right(s',f x) + Left err -> Left err + +instance Applicative STR where + pure x= STR (\s -> Right (s, x)) + STR g <*> STR f= STR $ \ s -> + let mr = g s + in case mr of + Left err -> Left err + Right (s' , x) -> + let mr = f s' + in case mr of + Left err -> Left err + Right(s'', y) -> Right(s'', x y) +instance Alternative STR where + empty= STR (\_ -> Left $ Error "an error occurred") + (<|>) = parsecPlus + +-- | monadic serialization & deserialization +instance Monad STR where + return x = STR (\s -> Right (s, x)) + STR g >>= f = STR (\s -> + + case g s of + Right (s', x)-> + let + STR fun = f x + in case fun s' of + left@(Left msg) -> left + rigth-> rigth + + Left msg -> Left msg + + ) + + + +instance MonadPlus STR where + mzero= STR (\(StatR (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 :: STR a -> STR a -> STR a +parsecPlus (STR p1) (STR p2) + = STR (\state -> + case (p1 state) of + Left (Error s) -> case (p2 state) of + Left (Error s') -> Left $ Error ( s++ "\n"++ s') + consumed-> consumed + other -> other + ) + + +label :: STR a -> String -> STR a +label p msg + = labels p [msg] + +labels :: STR a -> [String] -> STR a +labels (STR p) msgs + = STR (\state -> + case (p state) of + Left(Error reply) -> Left $ Error ( reply ++Prelude.concatMap ("\n in "++) msgs) + + other -> other + ) + +---- return n chars form the serialized data +--takep :: Int -> STR ByteString +--takep n= STR $ \(StatR(cs,s,v)) -> +-- let (h,t)= Data.ByteString.Lazy.Char8.splitAt (fromIntegral n) s in h `seq` t `seq` Right(StatR(cs,t,v), h) +-- + + +char :: Char -> STR Char + +unexpectedEndOfInput= "unexpected end of input" +char c= STR(\(StatR(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else if c== head s then Right(StatR(cs,tail s,v), c) + else Left (Error ( "char "++ c:" not match " ++ '\"':unpack s++"\"" ))) + + +anyChar = STR(\(StatR(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else Right(StatR(cs,tail s,v), head s)) + +satisfy bf= STR(\(StatR(cs,s,v)) -> let heads= head s in + if null s then Left (Error $ unexpectedEndOfInput) + else if bf heads then Right(StatR(cs,tail s,v), heads) + else Left (Error ( "satisfy not matching condition in " ++ '\"':unpack s++"\"" ))) + + +upper = STR(\(StatR(cs,s,v)) -> let heads= head s in + if null s then Left (Error $ unexpectedEndOfInput) + else if isUpper (head s) then Right(StatR(cs,tail s,v), head s) + else Left (Error ( "upper not matching condition in " ++ '\"':unpack s++"\"" ))) + + +space =STR(\(StatR(cs,s,v)) -> let heads= head s in + if null s then Left (Error $ unexpectedEndOfInput) + else if isSpace heads then Right(StatR(cs,tail s,v), heads) + else Left (Error ( "expected space at the head of " ++ unpack s ))) + + +digit1 l1 l2= STR(\(StatR(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else let c= head s in if c >= l1 && c <= l2 + then Right(StatR(cs,tail s,v), c) + else Left (Error ( "expected digit at the head of " ++ unpack s ))) + +empty = STR(\(StatR(cs,s,v)) -> if null s then Right(StatR(cs, s,v), ()) + else Left (Error ( "expected empty list" ))) + +octDigit= digit1 '0' '7' + +digit= digit1 '0' '9' + +hexDigit= STR(\(StatR(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else let c= head s in if c >= '0' && c <= '9' || c >= 'a' && c<='f' || c >= 'A' && c <= 'F' then Right(StatR(cs,tail s,v), c) + else Left (Error ( "expected space at the head of " ++ unpack s ))) + +oneOf xs= STR(\(StatR(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else let c= head s in if c `Prelude.elem` xs then Right(StatR(cs,tail s,v), c) + else Left (Error ( "expected digit at the head of " ++ unpack s ))) + +noneOf xs= STR(\(StatR(cs,s,v)) -> + if null s then Left (Error $ unexpectedEndOfInput) + else let c= head s in if not $ c `Prelude.elem` xs then Right(StatR(cs,tail s,v), c) + else Left (Error ( "expected digit at the head of " ++ unpack s ))) + +try p= do + (cs,s,v)<- STR $ \(StatR(cs,s,v)) -> Right(StatR(cs, s,v), (cs,s,v)) + r <- p + STR(\(StatR _) -> Right(StatR(cs, s,v), r)) + + + +readContent= STR $ \(StatR(cs,s,v)) -> Right(StatR(cs,Data.ByteString.Lazy.Char8.empty,v), s) + + + +unexpected msg + = STR (\state -> Left (Error $ msg++ "unexpected")) + +sepBy1,sepBy :: STR a -> STR sep -> STR [a] +sepBy p sep = sepBy1 p sep <|> return [] +sepBy1 p sep = do{ x <- p + ; xs <- many (sep >> p) + ; 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 :: STR a -> STR [a] +many p = many1 p <|> return [] +many1 :: STR a -> STR [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 :: STR 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 :: STR String +stringLiteral = lexeme ( + do{ str <- between (char '"') + (char '"' "end of string") + (many stringChar) + ; return (Prelude.foldr (maybe id (:)) "" str) + } + "literal string") + +-- stringChar :: STR (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 :: STR Char +charControl = do{ char '^' + ; code <- upper + ; return (toEnum (fromEnum code - fromEnum 'A')) + } + +-- charNum :: STR 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 :: STR (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 :: STR (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 -> STR Char -> STR 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 --- a/Data/RefSerialize/Serialize.hs +++ b/Data/RefSerialize/Serialize.hs @@ -1,140 +1,157 @@ -{-# LANGUAGE OverlappingInstances - ,TypeSynonymInstances - ,FlexibleInstances - ,UndecidableInstances - ,OverloadedStrings - ,NoMonomorphismRestriction - ,BangPatterns - #-} -module Data.RefSerialize.Serialize where -import GHC.Exts -import Unsafe.Coerce -import Data.List(isPrefixOf,insertBy,elem,sortBy) -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 Data.ByteString.Lazy.Search -import qualified Data.HashTable.IO as HT -import Data.Ord -import Data.Monoid - --- All this for myToStrict for compatibility with older versions of bytestring that --- lack a "toStrict" call -import qualified Data.ByteString as S -- S for strict (hmm...) -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Unsafe as S -import Data.ByteString.Lazy.Internal -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr - - -myToStrict :: ByteString -> S.ByteString -myToStrict Empty = S.empty -myToStrict (Chunk c Empty) = c -myToStrict cs0 = S.unsafeCreate totalLen $ \ptr -> go cs0 ptr - where - totalLen = foldlChunks (\a c -> a + S.length c) 0 cs0 - - go Empty !_ = return () - go (Chunk (S.PS fp off len) cs) !destptr = - withForeignPtr fp $ \p -> do - S.memcpy destptr (p `plusPtr` off) (fromIntegral len) - go cs (destptr `plusPtr` len) - -type MFun= Char -- usafeCoherced to char to store simply the address of the function -type VarName = String -data ShowF= Expr ByteString | Var Int deriving Show -type Context = HT.BasicHashTable Int ( StableName MFun, MFun,[ShowF],Int) - -data Error= Error String -data StatW= StatW (Context, [ShowF], ByteString) - - - -data STW a= STW(StatW-> (StatW , a) ) - --- | monadic serialization -instance Monad STW where - return x = STW (\s -> (s, x)) - STW g >>= f = STW (\s -> - - let (s', x)= g s - STW fun = f x - in fun s' - ) - - - --- HT to map -empty = HT.new -- (==) HT.hashInt - -assocs = sortBy (comparing fst) . unsafePerformIO . HT.toList - - -insert k v ht= unsafePerformIO $! HT.insert ht k v >> return ht - - - -delete k ht= unsafePerformIO $! HT.delete ht k >> return ht - - -lookup k ht= unsafePerformIO $! HT.lookup ht k - - -toList = unsafePerformIO . HT.toList - - -fromList = unsafePerformIO . HT.fromList -- HT.hashInt - --- | return a unique hash identifier for an object --- the context assures that no StableName used in addrStr is garbage collected, --- so the hashes are constant and the correspondence address - string --- remain one to one as long as the context is not garbage collected. --- Left is returned if it is the first time that @addHash@ is called for that variable -addrHash :: Context -> a -> IO (Either Int Int) -addrHash c x = - case Data.RefSerialize.Serialize.lookup hash c of - Nothing -> addc [Var hash] c >> return (Left hash) - Just (x,y,z,n) -> HT.insert c hash (x,y,z,n+1) >> return (Right hash) - where - addc str c= HT.insert c hash (st,unsafeCoerce x, str,1) - (hash,st) = hasht x - -readContext :: ByteString -> ByteString -> (ByteString, ByteString) -readContext pattern str= - let (s1,s2)= breakOn (myToStrict pattern) str - in (s1, B.drop (fromIntegral $ B.length pattern) s2) - ---readContext pattern str= readContext1 mempty 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 --- . The stable names of during the serializing deserializing process are not deleted --- . This is assured by the pointers in the context, --- so the hash values remain and the comparison of varNames is correct. -varName x= "v"++ (show . hash) x - where hash x= let (ht,_)= hasht x in ht - - - - -numVar :: String -> Maybe Int - -numVar ('v':var)= Just $ read var -numVar _ = Nothing - - - +{-# LANGUAGE OverlappingInstances + ,TypeSynonymInstances + ,FlexibleInstances + ,UndecidableInstances + ,OverloadedStrings + ,NoMonomorphismRestriction + ,BangPatterns + #-} +module Data.RefSerialize.Serialize where +import GHC.Exts +import Unsafe.Coerce +import Data.List(isPrefixOf,insertBy,elem,sortBy) +import Data.Char(isAlpha,isAlphaNum,isSpace,isUpper) + +import System.Mem.StableName +import System.IO.Unsafe +import Control.Monad (MonadPlus(..)) +import Control.Applicative +import Data.ByteString.Lazy.Char8 as B +import Data.ByteString.Lazy.Search +import qualified Data.HashTable.IO as HT +import Data.Ord +import Data.Monoid + +-- All this for myToStrict for compatibility with older versions of bytestring that +-- lack a "toStrict" call +import qualified Data.ByteString as S -- S for strict (hmm...) +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Unsafe as S +import Data.ByteString.Lazy.Internal +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr + + +myToStrict :: ByteString -> S.ByteString +myToStrict Empty = S.empty +myToStrict (Chunk c Empty) = c +myToStrict cs0 = S.unsafeCreate totalLen $ \ptr -> go cs0 ptr + where + totalLen = foldlChunks (\a c -> a + S.length c) 0 cs0 + + go Empty !_ = return () + go (Chunk (S.PS fp off len) cs) !destptr = + withForeignPtr fp $ \p -> do + S.memcpy destptr (p `plusPtr` off) (fromIntegral len) + go cs (destptr `plusPtr` len) + +type MFun= Char -- usafeCoherced to char to store simply the address of the function +type VarName = String +data ShowF= Expr ByteString | Var Int deriving Show +type Context = HT.BasicHashTable Int ( StableName MFun, MFun,[ShowF],Int) + +data Error= Error String +data StatW= StatW (Context, [ShowF], ByteString) + + + +data STW a= STW(StatW-> (StatW , a) ) + +instance Functor STW where + fmap f (STW stwx)= STW $ \s -> + let (s',x) = stwx s + in (s', f x) + +instance Applicative STW where + pure x = STW (\s -> (s, x)) + + STW g <*> STW f = STW (\s -> + + let (s', x)= g s + (s'',y)= f s' + in (s'', x y) + ) + + +-- | monadic serialization +instance Monad STW where + return x = STW (\s -> (s, x)) + STW g >>= f = STW (\s -> + + let (s', x)= g s + STW fun = f x + in fun s' + ) + + + +-- HT to map +empty = HT.new -- (==) HT.hashInt + +assocs = sortBy (comparing fst) . unsafePerformIO . HT.toList + + +insert k v ht= unsafePerformIO $! HT.insert ht k v >> return ht + + + +delete k ht= unsafePerformIO $! HT.delete ht k >> return ht + + +lookup k ht= unsafePerformIO $! HT.lookup ht k + + +toList = unsafePerformIO . HT.toList + + +fromList = unsafePerformIO . HT.fromList -- HT.hashInt + +-- | return a unique hash identifier for an object +-- the context assures that no StableName used in addrStr is garbage collected, +-- so the hashes are constant and the correspondence address - string +-- remain one to one as long as the context is not garbage collected. +-- Left is returned if it is the first time that @addHash@ is called for that variable +addrHash :: Context -> a -> IO (Either Int Int) +addrHash c x = + case Data.RefSerialize.Serialize.lookup hash c of + Nothing -> addc [Var hash] c >> return (Left hash) + Just (x,y,z,n) -> HT.insert c hash (x,y,z,n+1) >> return (Right hash) + where + addc str c= HT.insert c hash (st,unsafeCoerce x, str,1) + (hash,st) = hasht x + +readContext :: ByteString -> ByteString -> (ByteString, ByteString) +readContext pattern str= + let (s1,s2)= breakOn (myToStrict pattern) str + in (s1, B.drop (fromIntegral $ B.length pattern) s2) + +--readContext pattern str= readContext1 mempty 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 +-- . The stable names of during the serializing deserializing process are not deleted +-- . This is assured by the pointers in the context, +-- so the hash values remain and the comparison of varNames is correct. +varName x= "v"++ (show . hash) x + where hash x= let (ht,_)= hasht x in ht + + + + +numVar :: String -> Maybe Int + +numVar ('v':var)= Just $ read var +numVar _ = Nothing + + + diff --git a/RefSerialize.cabal b/RefSerialize.cabal --- a/RefSerialize.cabal +++ b/RefSerialize.cabal @@ -1,35 +1,35 @@ -name: RefSerialize -version: 0.3.1.3 -synopsis: Write to and read from ByteStrings maintaining internal memory references -description: - Read, Show and Binary instances do not check for internal data references to the same address. - As a result, the data is duplicated when serialized. This is a waste of space in the filesystem - and also a waste of serialization time. but the worst consequence is that, when the serialized data is read, - it allocates multiple copies for the same object when referenced multiple times. Because multiple referenced - data is very typical in a pure language such is Haskell, this means that the resulting data loose the beatiful - economy of space and processing time that referential transparency permits. - . - In this release: - . - Compatibility with older versions of bytestring that have no 'toStrict' call - . - deserialization is much, much faster by using the stringsearch package - . - - See "Data.RefSerialize" for details - - - -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: binary,bytestring, base >=4 && <5,containers, hashtables,stringsearch - - -exposed-modules: Data.RefSerialize, Data.RefSerialize.Parser, Data.RefSerialize.Serialize -ghc-options: - +name: RefSerialize +version: 0.3.1.4 +synopsis: Write to and read from ByteStrings maintaining internal memory references +description: + Read, Show and Binary instances do not check for internal data references to the same address. + As a result, the data is duplicated when serialized. This is a waste of space in the filesystem + and also a waste of serialization time. but the worst consequence is that, when the serialized data is read, + it allocates multiple copies for the same object when referenced multiple times. Because multiple referenced + data is very typical in a pure language such is Haskell, this means that the resulting data loose the beatiful + economy of space and processing time that referential transparency permits. + . + In this release: + . + Compatibility with older versions of bytestring that have no 'toStrict' call + . + deserialization is much, much faster by using the stringsearch package + . + + See "Data.RefSerialize" for details + + + +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: binary,bytestring, base >=4 && <5,containers, hashtables,stringsearch + + +exposed-modules: Data.RefSerialize, Data.RefSerialize.Parser, Data.RefSerialize.Serialize +ghc-options: +