diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,35 @@ ## [Unreleased] +## [0.13] - 2025-06-15 +### Added +- `RON.Text.Parse.parsePayload` +- `instance MonadTrans EpochClockT` +- `instance MonadUnliftIO EpochClockT` +- Lenses for UUID fields +- `UUID.addValue` +- Packing ops with '%' extension + +### Changed +- RON.Epoch: + - Extend `EpochClock` to transformer `EpochClockT` +- Added dependency on `unliftio` + +### Fixed +- RONt: parsing of `-0.1` +- A typo in `mkScopedName` + +### Removed +- `RON.Prelude`: + - `atomicModifyIORef'` + - `catch` + - `evaluate` + - `newIORef` + - `readIORef` + - `throwIO` + - `writeIORef` + because sometimes we need `UnliftIO` counterparts + ## [0.12] - 2021-07-15 ### Added - Support for GHC 8.10. @@ -158,7 +187,8 @@ - RON-Schema - RON-Schema TemplateHaskell code generator -[Unreleased]: https://github.com/ff-notes/ron/compare/ron-0.12...HEAD +[Unreleased]: https://github.com/ff-notes/ron/compare/ron-0.13...HEAD +[0.13]: https://github.com/ff-notes/ron/compare/ron-0.12...ron-0.13 [0.12]: https://github.com/ff-notes/ron/compare/ron-0.11...ron-0.12 [0.11]: https://github.com/ff-notes/ron/compare/ron-0.10...ron-0.11 [0.10]: https://github.com/ff-notes/ron/compare/ron-0.9...ron-0.10 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,20 +1,27 @@ {-# OPTIONS -Wno-orphans #-} - {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} -import RON.Prelude +import RON.Prelude -import Control.DeepSeq (NFData, force) -import Criterion (bench, nf) -import Criterion.Main (defaultConfig, defaultMainWith) -import Criterion.Types (timeLimit) +import Control.DeepSeq (NFData, force) +import Control.Exception (evaluate) +import Criterion (bench, nf) +import Criterion.Main (defaultConfig, defaultMainWith) +import Criterion.Types (timeLimit) -import RON.Text (parseWireFrames, serializeWireFrames) -import RON.Types (Atom, ClosedOp (..), Op (..), UUID, - WireChunk (Closed), WireReducedChunk) -import qualified RON.UUID as UUID +import RON.Text (parseWireFrames, serializeWireFrames) +import RON.Types ( + Atom, + ClosedOp (..), + Op (..), + UUID, + WireChunk (Closed), + WireReducedChunk, + ) +import RON.UUID qualified as UUID deriving instance NFData Atom deriving instance NFData ClosedOp @@ -36,5 +43,6 @@ serialized = [ (n :: Int, serializeWireFrames $ replicate 100 $ frame n) - | i <- [1 .. 10], let n = 100 * i + | i <- [1 .. 10] + , let n = 100 * i ] diff --git a/lib/Attoparsec/Extra.hs b/lib/Attoparsec/Extra.hs --- a/lib/Attoparsec/Extra.hs +++ b/lib/Attoparsec/Extra.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE OverloadedStrings #-} module Attoparsec.Extra ( @@ -6,7 +8,6 @@ endOfInputEx, isSuccessful, label, - parseOnlyL, takeL, definiteDouble, withInputSize, @@ -14,21 +15,21 @@ (<+>), ) where -import RON.Prelude - -import Data.Attoparsec.ByteString.Char8 (anyChar, decimal, isDigit_w8, - signed) -import Data.Attoparsec.ByteString.Lazy as Attoparsec -import qualified Data.Attoparsec.Internal.Types as Internal -import qualified Data.ByteString as BS -import Data.ByteString.Lazy (fromStrict) -import qualified Data.Scientific as Sci -import GHC.Real (toInteger) +import RON.Prelude --- | TODO(2020-06-17, cblp) make parser lazy/incremental --- TODO(2021-04-25, cblp) remove in favor of attoparsec-0.14 lazy version -parseOnlyL :: Parser a -> ByteStringL -> Either String a -parseOnlyL p = eitherResult . parse p +import Data.Attoparsec.ByteString.Char8 ( + anyChar, + decimal, + isDigit_w8, + signed, + ) +import Data.Attoparsec.ByteString.Lazy as Attoparsec +import Data.Attoparsec.Internal.Types qualified as Internal +import Data.ByteString qualified as BS +import Data.ByteString.Lazy (fromStrict) +import Data.Maybe (isJust) +import Data.Scientific qualified as Sci +import GHC.Real (toInteger) -- | 'Attoparsec.take' adapter to 'ByteStringL' takeL :: Int -> Parser ByteStringL @@ -62,7 +63,7 @@ rest <- takeAtMost 11 let cite | BS.length rest < 11 = rest - | otherwise = BS.take 10 rest <> "..." + | otherwise = BS.take 10 rest <> "..." fail $ show pos <> ": extra input: " <> show cite takeAtMost :: Int -> Parser ByteString @@ -74,12 +75,13 @@ pos <- getPos guard (pos >= maxPos) <|> endOfInput -(??) :: Applicative f => Maybe a -> f a -> f a +(??) :: (Applicative f) => Maybe a -> f a -> f a a ?? alt = maybe alt pure a --- | Apply parser and check it is applied successfully. --- Kinda opposite to 'guard'. -isSuccessful :: Alternative f => f a -> f Bool +{- | Apply parser and check it is applied successfully. +Kinda opposite to 'guard'. +-} +isSuccessful :: (Alternative f) => f a -> f Bool isSuccessful p = p $> True <|> pure False char :: Char -> Parser Char @@ -90,45 +92,73 @@ else fail $ "Expected " ++ show c ++ ", got " ++ show c' --- | Parses a definite double, i.e. it is not an integer. For this, the double has either a '.', and 'e'/'E' part or both. +{- | Parses a definite double, i.e. it is not an integer. +For this, the double has either a '.', and 'e'/'E' part or both. +-} {-# INLINE definiteDouble #-} definiteDouble :: Parser Double -definiteDouble = do - let parseIntegerPart = signed decimal - let parseDot = char '.' - let parseFractionalPartWithLength = - BS.foldl' step (0, 0) `fmap` Attoparsec.takeWhile1 isDigit_w8 - where step (a, l) w = (a * 10 + fromIntegral (w - 48), l + 1) - let parseExponent = (char 'e' <|> char 'E') *> signed decimal +definiteDouble = withDot <|> noDot + where + dot = char '.' + minus = char '-' - let withDot = do - i <- optional parseIntegerPart - _ <- parseDot - (f, l) <- parseFractionalPartWithLength - e <- optional parseExponent - pure $ buildDouble (fromMaybe 0 i) f l (fromMaybe 0 e) + integerPart = decimal - let withE = do - i <- optional parseIntegerPart - buildDouble (fromMaybe 0 i) 0 0 <$> parseExponent + fractionalPartWithLength = + BS.foldl' step (0, 0) `fmap` Attoparsec.takeWhile1 isDigit_w8 + where + step (a, l) w = (a * 10 + fromIntegral (w - 48), l + 1) - withDot <|> withE + exponent = (char 'e' <|> char 'E') *> signed decimal -buildDouble :: Integer -> Integer -> Int -> Int -> Double -buildDouble integerPart fractionalPart fractionalPartLength exponentPart = - let addOrSubFractionalPart = if integerPart < 0 then -fractionalPart else fractionalPart - coeff = integerPart * 10 ^ toInteger fractionalPartLength + toInteger addOrSubFractionalPart + withDot = do + m <- isJust <$> optional minus + i <- integerPart + _ <- dot + (f, l) <- fractionalPartWithLength + e <- optional exponent + pure $ buildDouble m i f l (fromMaybe 0 e) + + noDot = do + m <- isJust <$> optional minus + i <- integerPart + buildDouble m i 0 0 <$> exponent + +buildDouble :: Bool -> Integer -> Integer -> Int -> Int -> Double +buildDouble + isNegative + integerPart + fractionalPart + fractionalPartLength + exponentPart = + Sci.toRealFloat $ Sci.scientific coeff exponent + where + addOrSubFractionalPart + | integerPart < 0 = -fractionalPart + | otherwise = fractionalPart + coeff = + (if isNegative then negate else id) $ + integerPart * 10 ^ toInteger fractionalPartLength + + addOrSubFractionalPart exponent = exponentPart - fractionalPartLength - in Sci.toRealFloat $ Sci.scientific coeff exponent (<+>) :: Parser a -> Parser a -> Parser a -(<+>) p1 p2 = Internal.Parser $ \t pos more lose suc -> let - lose1 t' _pos more1 ctx1 msg1 = Internal.runParser p2 t' pos more1 lose2 suc - where - lose2 t2 pos2 more2 ctx2 msg2 = lose t2 pos2 more2 [] $ unwords - [ "Many fails:\n" - , intercalate " > " ctx1, ":", msg1, "|\n" - , intercalate " > " ctx2, ":", msg2 - ] - in Internal.runParser p1 t pos more lose1 suc +(<+>) p1 p2 = + Internal.Parser \t pos more lose suc -> + let lose1 t' _pos more1 ctx1 msg1 = + Internal.runParser p2 t' pos more1 lose2 suc + where + lose2 t2 pos2 more2 ctx2 msg2 = + lose t2 pos2 more2 [] $ + unwords + [ "Many fails:\n" + , intercalate " > " ctx1 + , ":" + , msg1 + , "|\n" + , intercalate " > " ctx2 + , ":" + , msg2 + ] + in Internal.runParser p1 t pos more lose1 suc infixl 3 <+> diff --git a/lib/Data/ZigZag.hs b/lib/Data/ZigZag.hs --- a/lib/Data/ZigZag.hs +++ b/lib/Data/ZigZag.hs @@ -5,21 +5,28 @@ zzDecode64, ) where -import RON.Prelude +import RON.Prelude -import Data.Bits (Bits, FiniteBits, finiteBitSize, shiftL, shiftR, - xor, (.&.)) +import Data.Bits ( + Bits, + FiniteBits, + finiteBitSize, + shiftL, + shiftR, + xor, + (.&.), + ) {-# SPECIALIZE INLINE zzEncode :: Int8 -> Word8 #-} {-# SPECIALIZE INLINE zzEncode :: Int16 -> Word16 #-} {-# SPECIALIZE INLINE zzEncode :: Int32 -> Word32 #-} {-# SPECIALIZE INLINE zzEncode :: Int64 -> Word64 #-} -zzEncode :: (Num b, Integral a, FiniteBits a) => a -> b +zzEncode :: (FiniteBits a, Integral a, Num b) => a -> b zzEncode w = fromIntegral ((w `shiftL` 1) `xor` (w `shiftR` (finiteBitSize w - 1))) {-# INLINE zzDecode #-} -zzDecode :: (Num a, Integral a1, Bits a1) => a1 -> a +zzDecode :: (Bits a1, Integral a1, Num a) => a1 -> a zzDecode w = fromIntegral ((w `shiftR` 1) `xor` negate (w .&. 1)) {-# INLINE zzDecode64 #-} diff --git a/lib/RON/Base64.hs b/lib/RON/Base64.hs --- a/lib/RON/Base64.hs +++ b/lib/RON/Base64.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -22,14 +23,21 @@ isLetter, ) where -import RON.Prelude +import RON.Prelude -import Data.Bits (complement, shiftL, shiftR, (.&.), (.|.)) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL +import Data.Bits (complement, shiftL, shiftR, (.&.), (.|.)) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL -import RON.Util.Word (Word4, Word6 (W6), Word60, leastSignificant4, - leastSignificant6, leastSignificant60, safeCast) +import RON.Util.Word ( + Word4, + Word6 (W6), + Word60, + leastSignificant4, + leastSignificant6, + leastSignificant60, + safeCast, + ) -- | Base64 alphabet alphabet :: ByteString @@ -37,25 +45,25 @@ -- | Check if a character is in the Base64 alphabet. isLetter :: Word8 -> Bool -isLetter c - = c - ord0 <= 9 - || c - ordA <= 25 - || c - orda <= 25 - || c == ord_ - || c == ordõ +isLetter c = + c - ord0 <= 9 + || c - ordA <= 25 + || c - orda <= 25 + || c == ord_ + || c == ordõ -- | Convert a Base64 letter to a number [0-63] decodeLetter :: Word8 -> Maybe Word6 decodeLetter x - | x < ord0 = Nothing + | x < ord0 = Nothing | x <= ord9 = Just . leastSignificant6 $ x - ord0 - | x < ordA = Nothing + | x < ordA = Nothing | x <= ordZ = Just . leastSignificant6 $ x - ordA + posA | x == ord_ = Just $ leastSignificant6 pos_ - | x < orda = Nothing + | x < orda = Nothing | x <= ordz = Just . leastSignificant6 $ x - orda + posa | x == ordõ = Just $ leastSignificant6 posõ - | otherwise = Nothing + | otherwise = Nothing -- ASCII milestone codes ord0, ord9, ordA, ordZ, ord_, orda, ordz, ordõ :: Word8 @@ -78,11 +86,11 @@ -- | Convert a subset [0-F] of Base64 letters to a number [0-15] decodeLetter4 :: Word8 -> Maybe Word4 decodeLetter4 x - | x < ord0 = Nothing + | x < ord0 = Nothing | x <= ord9 = Just . leastSignificant4 $ x - ord0 - | x < ordA = Nothing + | x < ordA = Nothing | x <= ordZ = Just . leastSignificant4 $ x - ordA + posA - | otherwise = Nothing + | otherwise = Nothing -- | Decode a blob from a Base64 string decode :: ByteStringL -> Maybe ByteStringL @@ -90,52 +98,54 @@ fmap (BSL.pack . go . map safeCast) . traverse decodeLetter . BSL.unpack where go = \case - [a, b] -> decode2 a b - [a, b, c] -> decode3 a b c - a:b:c:d:rest -> decode4 a b c d ++ go rest - _ -> [] + [a, b] -> decode2 a b + [a, b, c] -> decode3 a b c + a : b : c : d : rest -> decode4 a b c d ++ go rest + _ -> [] decode2 a b = [(a `shiftL` 2) .|. (b `shiftR` 4)] decode3 a b c = - [ ( a `shiftL` 2) .|. (b `shiftR` 4) + [ (a `shiftL` 2) .|. (b `shiftR` 4) , ((b .&. 0b1111) `shiftL` 4) .|. (c `shiftR` 2) ] decode4 a b c d = - [ ( a `shiftL` 2) .|. (b `shiftR` 4) + [ (a `shiftL` 2) .|. (b `shiftR` 4) , ((b .&. 0b1111) `shiftL` 4) .|. (c `shiftR` 2) - , ((c .&. 0b11) `shiftL` 6) .|. d + , ((c .&. 0b11) `shiftL` 6) .|. d ] -- | Decode a 60-bit number from a Base64 string decode60 :: ByteString -> Maybe Word60 decode60 = - fmap leastSignificant60 . go 10 - <=< traverse (fmap safeCast . decodeLetter) . BS.unpack + BS.unpack + >>> traverse (fmap safeCast . decodeLetter) + >=> (go 10 >>> fmap leastSignificant60) where go :: Int -> [Word8] -> Maybe Word64 go n = \case - [] | n >= 0 -> Just 0 + [] | n >= 0 -> Just 0 [a] | n >= 1 -> Just $ decode4 a 0 0 0 [a, b] | n >= 2 -> Just $ decode4 a b 0 0 [a, b, c] | n >= 3 -> Just $ decode4 a b c 0 - (a:b:c:d:rest) + (a : b : c : d : rest) | n >= 4 -> do lowerPart <- go (n - 4) rest pure $ decode4 a b c d .|. (lowerPart `shiftR` 24) - _ -> Nothing -- extra input + _ -> Nothing -- extra input decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> Word64 decode4 a b c d = - (safeCast a `shiftL` 54) .|. - (safeCast b `shiftL` 48) .|. - (safeCast c `shiftL` 42) .|. - (safeCast d `shiftL` 36) + (safeCast a `shiftL` 54) + .|. (safeCast b `shiftL` 48) + .|. (safeCast c `shiftL` 42) + .|. (safeCast d `shiftL` 36) -- | Decode a 60-bit number from a Base32 string decode60base32 :: ByteString -> Maybe Word60 decode60base32 = - fmap leastSignificant60 . go12 - <=< traverse (fmap safeCast . decodeLetter) . BS.unpack + BS.unpack + >>> traverse (fmap safeCast . decodeLetter) + >=> (go12 >>> fmap leastSignificant60) where go12 :: [Word8] -> Maybe Word64 go12 letters = do @@ -146,12 +156,12 @@ go4 :: [Word8] -> Maybe Word64 go4 letters = case splitAt 4 letters of (letters4, []) -> pure $ decodeBase32 4 letters4 - _ -> Nothing -- extra input + _ -> Nothing -- extra input decodeBase32 :: Int -> [Word8] -> Word64 - decodeBase32 len - = foldl' (\acc b -> (acc `shiftL` 5) .|. safeCast b) 0 - . take len - . (++ repeat 0) + decodeBase32 len = + foldl' (\acc b -> (acc `shiftL` 5) .|. safeCast b) 0 + . take len + . (++ repeat 0) -- | Decode a 64-bit number from a Base64 string decode64 :: ByteString -> Maybe Word64 @@ -173,24 +183,29 @@ encode = BSL.pack . go . BSL.unpack where go = \case - [] -> [] - [a] -> encode1 a - [a, b] -> encode2 a b - a:b:c:rest -> encode3 a b c ++ go rest + [] -> [] + [a] -> encode1 a + [a, b] -> encode2 a b + a : b : c : rest -> encode3 a b c ++ go rest encode1 a = - map (encodeLetter . leastSignificant6) + map + (encodeLetter . leastSignificant6) [a `shiftR` 2, (a .&. 0b11) `shiftL` 4] - encode2 a b = map (encodeLetter . leastSignificant6) - [ a `shiftR` 2 - , ((a .&. 0b11) `shiftL` 4) .|. (b `shiftR` 4) - , (b .&. 0b1111) `shiftL` 2 - ] - encode3 a b c = map (encodeLetter . leastSignificant6) - [ a `shiftR` 2 - , ((a .&. 0b11) `shiftL` 4) .|. (b `shiftR` 4) - , ((b .&. 0b1111) `shiftL` 2) .|. (c `shiftR` 6) - , c .&. 0b111111 - ] + encode2 a b = + map + (encodeLetter . leastSignificant6) + [ a `shiftR` 2 + , ((a .&. 0b11) `shiftL` 4) .|. (b `shiftR` 4) + , (b .&. 0b1111) `shiftL` 2 + ] + encode3 a b c = + map + (encodeLetter . leastSignificant6) + [ a `shiftR` 2 + , ((a .&. 0b11) `shiftL` 4) .|. (b `shiftR` 4) + , ((b .&. 0b1111) `shiftL` 2) .|. (c `shiftR` 6) + , c .&. 0b111111 + ] -- | Convert a number from [0..63] to a single letter encodeLetter :: Word6 -> Word8 @@ -202,10 +217,12 @@ -- | Encode a 60-bit number to a Base64 string encode60 :: Word60 -> ByteString -encode60 w = BS.pack - [ encodeLetter $ leastSignificant6 (safeCast w `shiftR` (6 * i) :: Word64) - | i <- [9, 8 .. 0] - ] +encode60 w = + BS.pack + [ encodeLetter $ + leastSignificant6 (safeCast w `shiftR` (6 * i) :: Word64) + | i <- [9, 8 .. 0] + ] -- | Encode a 60-bit number to a Base64 string, dropping trailing zeroes encode60short :: Word60 -> ByteString @@ -215,8 +232,8 @@ where go _ 0 = [] go i w = - (w `shiftR` (6 * i)) .&. 0b111111 : - go (i - 1) (w .&. complement (0b111111 `shiftL` (6 * i))) + (w `shiftR` (6 * i)) .&. 0b111111 + : go (i - 1) (w .&. complement (0b111111 `shiftL` (6 * i))) -- | Encode a 64-bit number to a Base32 string, dropping trailing zeroes encode64base32short :: Word64 -> ByteString @@ -226,8 +243,8 @@ where go _ 0 = [] go i w = - (w `shiftR` (5 * i)) .&. 0b11111 : - go (i - 1) (w .&. complement (0b11111 `shiftL` (5 * i))) + (w `shiftR` (5 * i)) .&. 0b11111 + : go (i - 1) (w .&. complement (0b11111 `shiftL` (5 * i))) leastSignificant5 w = W6 $ fromIntegral w .&. 0b11111 @@ -235,4 +252,4 @@ encode64 :: Word64 -> ByteString encode64 w = encodeLetter (leastSignificant6 $ w `shiftR` 60) - `BS.cons` encode60 (leastSignificant60 w) + `BS.cons` encode60 (leastSignificant60 w) diff --git a/lib/RON/Binary.hs b/lib/RON/Binary.hs --- a/lib/RON/Binary.hs +++ b/lib/RON/Binary.hs @@ -1,5 +1,5 @@ -- | RON-Binary wire format module RON.Binary (parse, serialize) where -import RON.Binary.Parse (parse) -import RON.Binary.Serialize (serialize) +import RON.Binary.Parse (parse) +import RON.Binary.Serialize (serialize) diff --git a/lib/RON/Binary/Parse.hs b/lib/RON/Binary/Parse.hs --- a/lib/RON/Binary/Parse.hs +++ b/lib/RON/Binary/Parse.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} @@ -13,27 +14,39 @@ parseString, ) where -import RON.Prelude +import RON.Prelude -import Attoparsec.Extra (Parser, anyWord8, endOfInputEx, label, - parseOnlyL, takeL, withInputSize) -import qualified Attoparsec.Extra as Atto -import qualified Data.Binary as Binary -import Data.Binary.Get (getDoublebe, runGet) -import Data.Bits (shiftR, testBit, (.&.)) -import Data.ByteString.Lazy (cons, toStrict) -import qualified Data.ByteString.Lazy as BSL -import Data.Text.Encoding (decodeUtf8) -import Data.ZigZag (zzDecode64) +import Attoparsec.Extra ( + Parser, + anyWord8, + endOfInputEx, + label, + parseOnly, + takeL, + withInputSize, + ) +import Attoparsec.Extra qualified as Atto +import Data.Binary qualified as Binary +import Data.Binary.Get (getDoublebe, runGet) +import Data.Bits (shiftR, testBit, (.&.)) +import Data.ByteString.Lazy (cons, toStrict) +import Data.ByteString.Lazy qualified as BSL +import Data.Text.Encoding (decodeUtf8) +import Data.ZigZag (zzDecode64) -import RON.Binary.Types (Desc (..), Size, descIsOp) -import RON.Types (Atom (AFloat, AInteger, AString, AUuid), - ClosedOp (..), Op (..), - OpTerm (TClosed, THeader, TQuery, TReduced), - Payload, UUID (UUID), - WireChunk (Closed, Query, Value), WireFrame, - WireReducedChunk (..)) -import RON.Util.Word (safeCast) +import RON.Binary.Types (Desc (..), Size, descIsOp) +import RON.Types ( + Atom (AFloat, AInteger, AString, AUuid), + ClosedOp (..), + Op (..), + OpTerm (TClosed, THeader, TQuery, TReduced), + Payload, + UUID (UUID), + WireChunk (Closed, Query, Value), + WireFrame, + WireReducedChunk (..), + ) +import RON.Util.Word (safeCast) -- | 'Parser' for descriptor parseDesc :: Parser (Desc, Size) @@ -43,10 +56,10 @@ let sizeCode = b .&. 0b1111 let desc = toEnum $ fromIntegral typeCode size <- case (sizeCode, desc) of - (0, DAtomString) -> extendedLength + (0, DAtomString) -> extendedLength (0, d) | descIsOp d -> pure 0 - (0, _) -> pure 16 - _ -> pure $ fromIntegral sizeCode + (0, _) -> pure 16 + _ -> pure $ fromIntegral sizeCode pure (desc, size) -- | 'Parser' for extended length field @@ -61,24 +74,26 @@ -- | Parse frame parse :: ByteStringL -> Either String WireFrame -parse = parseOnlyL $ parseFrame <* endOfInputEx +parse = parseOnly $ parseFrame <* endOfInputEx -- | 'Parser' for frame parseFrame :: Parser WireFrame parseFrame = label "WireFrame" $ do - _ <- Atto.string "RON2" <|> do - magic <- takeL 4 - fail $ "unsupported magic sequence " ++ show magic + _ <- + Atto.string "RON2" <|> do + magic <- takeL 4 + fail $ "unsupported magic sequence " ++ show magic parseChunks -- | 'Parser' for chunk sequence parseChunks :: Parser [WireChunk] parseChunks = do size :: Size <- Binary.decode <$> takeL 4 - if | testBit size 31 -> + if + | testBit size 31 -> liftA2 (:) (parseChunk $ leastSignificant31 size) parseChunks | size > 0 -> - (:[]) <$> parseChunk size + (: []) <$> parseChunk size | True -> pure [] @@ -87,33 +102,37 @@ leastSignificant31 x = x .&. 0x7FFFFFFF -- | 'Parser' for a chunk -parseChunk - :: Size -- ^ expected input length - -> Parser WireChunk +parseChunk :: + -- | expected input length + Size -> + Parser WireChunk parseChunk size = label "WireChunk" $ do (consumed0, (term, op)) <- withInputSize parseDescAndClosedOp let parseReducedChunk wrcHeader isQuery = do wrcBody <- parseReducedOps $ fromIntegral size - consumed0 pure $ (if isQuery then Query else Value) WireReducedChunk{..} case term of - THeader -> parseReducedChunk op False - TQuery -> parseReducedChunk op True + THeader -> parseReducedChunk op False + TQuery -> parseReducedChunk op True TReduced -> fail "reduced op without a chunk" - TClosed -> assertSize size consumed0 $> Closed op + TClosed -> assertSize size consumed0 $> Closed op -- | Assert that is such as expected -assertSize :: MonadFail f => Size -> Int -> f () +assertSize :: (MonadFail f) => Size -> Int -> f () assertSize expected consumed = when (consumed /= fromIntegral expected) $ - fail $ - "size mismatch: expected " ++ show expected ++ ", got " ++ show consumed + fail $ + "size mismatch: expected " + ++ show expected + ++ ", got " + ++ show consumed -- | 'Parser' for a sequence of reduced ops parseReducedOps :: Int -> Parser [Op] parseReducedOps = label "[Op]" . go where go = \case - 0 -> pure [] + 0 -> pure [] expected -> do (consumed, (TReduced, op)) <- withInputSize parseDescAndReducedOp case compare consumed expected of @@ -126,36 +145,38 @@ parseDescAndClosedOp = label "d+ClosedOp" $ do (desc, size) <- parseDesc unless (size == 0) $ - fail $ "desc = " ++ show desc ++ ", size = " ++ show size + fail $ + "desc = " ++ show desc ++ ", size = " ++ show size case desc of - DOpClosed -> (TClosed,) <$> parseClosedOp - DOpHeader -> (THeader,) <$> parseClosedOp - DOpQueryHeader -> (TQuery,) <$> parseClosedOp - _ -> fail $ "unimplemented " ++ show desc + DOpClosed -> (TClosed,) <$> parseClosedOp + DOpHeader -> (THeader,) <$> parseClosedOp + DOpQueryHeader -> (TQuery,) <$> parseClosedOp + _ -> fail $ "unimplemented " ++ show desc -- | 'Parser' for reduced op, returning the op's terminator along with the op parseDescAndReducedOp :: Parser (OpTerm, Op) parseDescAndReducedOp = label "d+ClosedOp" $ do (desc, size) <- parseDesc unless (size == 0) $ - fail $ "desc = " ++ show desc ++ ", size = " ++ show size + fail $ + "desc = " ++ show desc ++ ", size = " ++ show size case desc of - DOpReduced -> (TReduced,) <$> parseOpenOp - _ -> fail $ "unimplemented " ++ show desc + DOpReduced -> (TReduced,) <$> parseOpenOp + _ -> fail $ "unimplemented " ++ show desc -- | 'Parser' for closed op without terminator parseClosedOp :: Parser ClosedOp parseClosedOp = label "ClosedOp" $ do reducerId <- parseOpKey DUuidReducer - objectId <- parseOpKey DUuidObject - op <- parseOpenOp + objectId <- parseOpKey DUuidObject + op <- parseOpenOp pure ClosedOp{..} -- | 'Parser' for reduced op without terminator parseOpenOp :: Parser Op parseOpenOp = label "Op" $ do - opId <- parseOpKey DUuidOp - refId <- parseOpKey DUuidRef + opId <- parseOpKey DUuidOp + refId <- parseOpKey DUuidRef payload <- parsePayload pure Op{..} @@ -168,22 +189,23 @@ uuid size case desc of DUuidReducer -> go - DUuidObject -> go - DUuidOp -> go - DUuidRef -> go - _ -> fail $ show desc + DUuidObject -> go + DUuidOp -> go + DUuidRef -> go + _ -> fail $ show desc -- | 'Parser' for UUID -uuid - :: Size -- ^ expected input length - -> Parser UUID +uuid :: + -- | expected input length + Size -> + Parser UUID uuid size = label "UUID" $ case size of 16 -> do x <- Binary.decode <$> takeL 8 y <- Binary.decode <$> takeL 8 pure $ UUID x y - _ -> fail "expected uuid of size 16" + _ -> fail "expected uuid of size 16" -- | 'Parser' for a payload (sequence of atoms) parsePayload :: Parser Payload @@ -194,28 +216,30 @@ atom = label "Atom" $ do (desc, size) <- parseDesc case desc of - DAtomFloat -> AFloat <$> float size + DAtomFloat -> AFloat <$> float size DAtomInteger -> AInteger <$> integer size - DAtomString -> AString <$> string size - DAtomUuid -> AUuid <$> uuid size - _ -> fail "expected Atom" + DAtomString -> AString <$> string size + DAtomUuid -> AUuid <$> uuid size + _ -> fail "expected Atom" -- | Parse an 'Atom' parseAtom :: ByteStringL -> Either String Atom -parseAtom = parseOnlyL $ atom <* endOfInputEx +parseAtom = parseOnly $ atom <* endOfInputEx -- | 'Parser' for a float atom -float - :: Size -- ^ expected input length - -> Parser Double +float :: + -- | expected input length + Size -> + Parser Double float = \case 8 -> runGet getDoublebe <$> takeL 8 _ -> undefined -- | 'Parser' for an integer atom -integer - :: Size -- ^ expected input length - -> Parser Int64 +integer :: + -- | expected input length + Size -> + Parser Int64 integer size = label "Integer" $ do -- big-endian, zigzag-coded, lengths 1..8 unless (size >= 1 && size <= 8) $ fail "integer size must be 1..8" @@ -223,12 +247,13 @@ zzDecode64 . Binary.decode <$> takeL (fromIntegral size) -- | 'Parser' for an string -string - :: Size -- ^ expected input length - -> Parser Text +string :: + -- | expected input length + Size -> + Parser Text string size = decodeUtf8 . toStrict <$> takeL (fromIntegral size) -- | Parse a string atom parseString :: ByteStringL -> Either String Text parseString bs = - parseOnlyL (string (fromIntegral $ BSL.length bs) <* endOfInputEx) bs + parseOnly (string (fromIntegral $ BSL.length bs) <* endOfInputEx) bs diff --git a/lib/RON/Binary/Serialize.hs b/lib/RON/Binary/Serialize.hs --- a/lib/RON/Binary/Serialize.hs +++ b/lib/RON/Binary/Serialize.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -10,22 +11,27 @@ serializeString, ) where -import RON.Prelude +import RON.Prelude -import qualified Data.Binary as Binary -import Data.Binary.Put (putDoublebe, runPut) -import Data.Bits (bit, shiftL, (.|.)) -import Data.ByteString.Lazy (cons, fromStrict) -import qualified Data.ByteString.Lazy as BSL -import Data.Text.Encoding (encodeUtf8) -import Data.ZigZag (zzEncode) +import Data.Binary qualified as Binary +import Data.Binary.Put (putDoublebe, runPut) +import Data.Bits (bit, shiftL, (.|.)) +import Data.ByteString.Lazy (cons, fromStrict) +import Data.ByteString.Lazy qualified as BSL +import Data.Text.Encoding (encodeUtf8) +import Data.ZigZag (zzEncode) -import RON.Binary.Types (Desc (..), Size, descIsOp) -import RON.Types (Atom (AFloat, AInteger, AString, AUuid), - ClosedOp (..), Op (..), UUID (UUID), - WireChunk (Closed, Query, Value), WireFrame, - WireReducedChunk (..)) -import RON.Util.Word (Word4, b0000, leastSignificant4, safeCast) +import RON.Binary.Types (Desc (..), Size, descIsOp) +import RON.Types ( + Atom (AFloat, AInteger, AString, AUuid), + ClosedOp (..), + Op (..), + UUID (UUID), + WireChunk (Closed, Query, Value), + WireFrame, + WireReducedChunk (..), + ) +import RON.Util.Word (Word4, b0000, leastSignificant4, safeCast) -- | Serialize a frame serialize :: WireFrame -> Either String ByteStringL @@ -36,44 +42,47 @@ chunkSize :: Bool -> Int64 -> Either String ByteStringL chunkSize continue x | x < bit 31 = Right $ Binary.encode s' - | otherwise = Left $ "chunk size is too big: " ++ show x + | otherwise = Left $ "chunk size is too big: " ++ show x where s = fromIntegral x :: Size - s' | continue = s .|. bit 31 + s' + | continue = s .|. bit 31 | otherwise = s foldChunks :: [ByteStringL] -> Either String ByteStringL foldChunks = \case - [] -> chunkSize False 0 - [c] -> (<> c) <$> chunkSize False (BSL.length c) - c:cs -> - fold <$> - sequence [chunkSize True (BSL.length c), pure c, foldChunks cs] + [] -> chunkSize False 0 + [c] -> (<> c) <$> chunkSize False (BSL.length c) + c : cs -> + fold + <$> sequence + [chunkSize True (BSL.length c), pure c, foldChunks cs] -- | Serialize a chunk serializeChunk :: WireChunk -> Either String ByteStringL serializeChunk = \case - Closed op -> serializeClosedOp DOpClosed op + Closed op -> serializeClosedOp DOpClosed op Value rchunk -> serializeReducedChunk False rchunk - Query rchunk -> serializeReducedChunk True rchunk + Query rchunk -> serializeReducedChunk True rchunk -- | Serialize a closed op serializeClosedOp :: Desc -> ClosedOp -> Either String ByteStringL serializeClosedOp desc ClosedOp{..} = do - keys <- sequenceA - [ serializeUuidReducer reducerId - , serializeUuidObject objectId - , serializeUuidOpId opId - , serializeUuidRef refId - ] + keys <- + sequenceA + [ serializeUuidReducer reducerId + , serializeUuidObject objectId + , serializeUuidOpId opId + , serializeUuidRef refId + ] payloadValue <- traverse serializeAtom payload serializeWithDesc desc $ fold $ keys ++ payloadValue where Op{opId, refId, payload} = op serializeUuidReducer = serializeWithDesc DUuidReducer . serializeUuid - serializeUuidObject = serializeWithDesc DUuidObject . serializeUuid - serializeUuidOpId = serializeWithDesc DUuidOp . serializeUuid - serializeUuidRef = serializeWithDesc DUuidRef . serializeUuid + serializeUuidObject = serializeWithDesc DUuidObject . serializeUuid + serializeUuidOpId = serializeWithDesc DUuidOp . serializeUuid + serializeUuidRef = serializeWithDesc DUuidRef . serializeUuid -- | Serialize a reduced op serializeReducedOp :: Desc -> UUID -> UUID -> Op -> Either String ByteStringL @@ -89,10 +98,11 @@ encodeDesc = leastSignificant4 . fromEnum -- | Prepend serialized bytes with descriptor -serializeWithDesc - :: Desc - -> ByteStringL -- ^ body - -> Either String ByteStringL +serializeWithDesc :: + Desc -> + -- | body + ByteStringL -> + Either String ByteStringL serializeWithDesc d body = do (lengthDesc, lengthExtended) <- lengthFields let descByte = safeCast (encodeDesc d) `shiftL` 4 .|. safeCast lengthDesc @@ -101,15 +111,15 @@ len = BSL.length body lengthFields = case d of DAtomString - | len == 0 -> Right (b0000, mkLengthExtended) - | len < 16 -> Right (leastSignificant4 len, BSL.empty) + | len == 0 -> Right (b0000, mkLengthExtended) + | len < 16 -> Right (leastSignificant4 len, BSL.empty) | len < bit 31 -> Right (b0000, mkLengthExtended) - | otherwise -> Left "String is too long" + | otherwise -> Left "String is too long" _ - | descIsOp d -> Right (b0000, BSL.empty) - | len < 16 -> Right (leastSignificant4 len, BSL.empty) - | len == 16 -> Right (b0000, BSL.empty) - | otherwise -> Left "impossible" + | descIsOp d -> Right (b0000, BSL.empty) + | len < 16 -> Right (leastSignificant4 len, BSL.empty) + | len == 16 -> Right (b0000, BSL.empty) + | otherwise -> Left "impossible" mkLengthExtended | len < 128 = Binary.encode (fromIntegral len :: Word8) | otherwise = Binary.encode (fromIntegral len .|. bit 31 :: Word32) @@ -117,10 +127,10 @@ -- | Serialize an 'Atom' serializeAtom :: Atom -> Either String ByteStringL serializeAtom = \case - AFloat f -> serializeWithDesc DAtomFloat $ serializeFloat f + AFloat f -> serializeWithDesc DAtomFloat $ serializeFloat f AInteger i -> serializeWithDesc DAtomInteger $ Binary.encode $ zzEncode64 i - AString s -> serializeWithDesc DAtomString $ serializeString s - AUuid u -> serializeWithDesc DAtomUuid $ serializeUuid u + AString s -> serializeWithDesc DAtomString $ serializeString s + AUuid u -> serializeWithDesc DAtomUuid $ serializeUuid u where {-# INLINE zzEncode64 #-} zzEncode64 :: Int64 -> Word64 @@ -134,7 +144,9 @@ serializeReducedChunk :: Bool -> WireReducedChunk -> Either String ByteStringL serializeReducedChunk isQuery WireReducedChunk{..} = do header <- - serializeClosedOp (if isQuery then DOpQueryHeader else DOpHeader) wrcHeader + serializeClosedOp + (if isQuery then DOpQueryHeader else DOpHeader) + wrcHeader body <- foldMapA (serializeReducedOp DOpReduced reducerId objectId) wrcBody pure $ header <> body where @@ -144,5 +156,5 @@ serializeString :: Text -> ByteStringL serializeString = fromStrict . encodeUtf8 -foldMapA :: (Monoid b, Applicative f, Foldable t) => (a -> f b) -> t a -> f b +foldMapA :: (Applicative f, Foldable t, Monoid b) => (a -> f b) -> t a -> f b foldMapA f = fmap fold . traverse f . toList diff --git a/lib/RON/Binary/Types.hs b/lib/RON/Binary/Types.hs --- a/lib/RON/Binary/Types.hs +++ b/lib/RON/Binary/Types.hs @@ -3,40 +3,39 @@ -- | Common types for binary format (parser and serializer) module RON.Binary.Types where -import RON.Prelude +import RON.Prelude type Size = Word32 -- | Data block descriptor data Desc - - = DOpClosed + = -- op descriptors + DOpClosed | DOpReduced | DOpHeader | DOpQueryHeader - - | DUuidReducer + | -- op key descriptors + DUuidReducer | DUuidObject | DUuidOp | DUuidRef - - | DAtomUuidZip + | -- zipped uuid descriptors + DAtomUuidZip | DUuidZipObject | DUuidZipOp | DUuidZipRef - - | DAtomUuid + | -- atom descriptors + DAtomUuid | DAtomInteger | DAtomString | DAtomFloat - deriving (Enum, Eq, Show) -- | Does the descriptor refer to an op descIsOp :: Desc -> Bool descIsOp = \case - DOpClosed -> True - DOpReduced -> True - DOpHeader -> True - DOpQueryHeader -> True - _ -> False + DOpClosed -> True + DOpReduced -> True + DOpHeader -> True + DOpQueryHeader -> True + _ -> False diff --git a/lib/RON/Epoch.hs b/lib/RON/Epoch.hs --- a/lib/RON/Epoch.hs +++ b/lib/RON/Epoch.hs @@ -2,6 +2,7 @@ module RON.Epoch ( EpochClock, + EpochClockT, decode, encode, epochTimeFromUnix, @@ -10,38 +11,62 @@ runEpochClockFromCurrentTime, ) where -import RON.Prelude +import RON.Prelude -import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, - posixSecondsToUTCTime) +import Data.IORef (atomicModifyIORef', newIORef) +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime) +import UnliftIO (MonadUnliftIO) -import RON.Event (Event (..), Replica, ReplicaClock, - TimeVariety (Epoch), advance, getEvents, getPid, - mkTime) -import RON.Util.Word (Word60, leastSignificant60, safeCast) +import RON.Event ( + Event (..), + Replica, + ReplicaClock, + TimeVariety (Epoch), + advance, + getEvents, + getPid, + mkTime, + ) +import RON.Util.Word (Word60, leastSignificant60, safeCast) --- | Real epoch clock. --- Uses kind of global variable to ensure strict monotonicity. -newtype EpochClock a = EpochClock (ReaderT (Replica, IORef Word60) IO a) - deriving (Applicative, Functor, Monad, MonadIO) +{- | Real epoch clock. +Uses kind of global variable to ensure strict monotonicity. +-} +newtype EpochClockT m a = EpochClock (ReaderT (Replica, IORef Word60) m a) + deriving (Applicative, Functor, Monad, MonadIO, MonadTrans, MonadUnliftIO) -instance ReplicaClock EpochClock where +type EpochClock = EpochClockT IO + +instance (MonadIO m) => ReplicaClock (EpochClockT m) where getPid = EpochClock $ reader fst - advance theirTime = EpochClock $ ReaderT $ \(_pid, timeVar) -> - atomicModifyIORef' timeVar $ \ourTime -> (max theirTime ourTime, ()) + advance theirTime = + EpochClock $ + ReaderT $ \(_pid, timeVar) -> + liftIO $ + atomicModifyIORef' timeVar $ + \ourTime -> (max theirTime ourTime, ()) - getEvents n0 = EpochClock $ ReaderT $ \(pid, timeVar) -> do - let n = max n0 1 - realTime <- getCurrentEpochTime - (begin, end) <- atomicModifyIORef' timeVar $ \timeCur -> let - begin = max realTime $ succ timeCur - end = begin + pred n - in (end, (begin, end)) - pure [Event{time = mkTime Epoch t, replica = pid} | t <- [begin .. end]] + getEvents n0 = + EpochClock $ + ReaderT $ \(pid, timeVar) -> do + let n = max n0 1 + realTime <- liftIO getCurrentEpochTime + (begin, end) <- + liftIO $ + atomicModifyIORef' timeVar $ \timeCur -> + let + begin = max realTime $ succ timeCur + end = begin + pred n + in + (end, (begin, end)) + pure + [ Event{time = mkTime Epoch t, replica = pid} + | t <- [begin .. end] + ] --- | Run 'EpochClock' action with explicit time variable. -runEpochClock :: Replica -> IORef Word60 -> EpochClock a -> IO a +-- | Run 'EpochClock'/'EpochClockT' action with explicit time variable. +runEpochClock :: Replica -> IORef Word60 -> EpochClockT m a -> m a runEpochClock replicaId timeVar (EpochClock action) = runReaderT action (replicaId, timeVar) @@ -52,10 +77,11 @@ timeVar <- newIORef wallTime runEpochClock replicaId timeVar clock --- | Get current time in 'Time' format (with 100 ns resolution). --- Monotonicity is not guaranteed. -getCurrentEpochTime :: IO Word60 -getCurrentEpochTime = encode <$> getPOSIXTime +{- | Get current time in 'Time' format (with 100 ns resolution). +Monotonicity is not guaranteed. +-} +getCurrentEpochTime :: (MonadIO m) => m Word60 +getCurrentEpochTime = liftIO $ encode <$> getPOSIXTime -- | Convert unix time in hundreds of milliseconds to RFC 4122 time. epochTimeFromUnix :: Word64 -> Word60 @@ -68,12 +94,12 @@ -- | Decode date and time from UUID epoch timestamp decode :: Word60 -> UTCTime -decode - = posixSecondsToUTCTime - . realToFrac - . (% 10000000) - . subtract epochDiff - . safeCast +decode = + posixSecondsToUTCTime + . realToFrac + . (% 10000000) + . subtract epochDiff + . safeCast encode :: POSIXTime -> Word60 encode = epochTimeFromUnix . round . (* 10000000) diff --git a/lib/RON/Error.hs b/lib/RON/Error.hs --- a/lib/RON/Error.hs +++ b/lib/RON/Error.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -17,23 +18,22 @@ tryIO, ) where -import RON.Prelude +import RON.Prelude -import Control.Exception (SomeException, try) -import Data.String (IsString, fromString) -import qualified Data.Text as Text -import GHC.Stack (callStack, getCallStack, prettySrcLoc) -import qualified Text.Show +import Control.Exception (SomeException, try) +import Data.String (IsString, fromString) +import Data.Text qualified as Text +import GHC.Stack (callStack, getCallStack, prettySrcLoc) +import Text.Show qualified -data Error = Error{description :: Text, reasons :: [Error]} - deriving (Eq) +data Error = Error {description :: Text, reasons :: [Error]} + deriving (Eq) instance Show Error where - show = - unlines . go - where - go Error{description, reasons} = - Text.unpack description : foldMap (map (" " ++) . go) reasons + show = unlines . go + where + go Error{description, reasons} = + Text.unpack description : foldMap (map (" " ++) . go) reasons instance Exception Error @@ -42,38 +42,37 @@ type MonadE = MonadError Error -errorContext :: MonadE m => Text -> m a -> m a +errorContext :: (MonadE m) => Text -> m a -> m a errorContext ctx action = action `catchError` \e -> throwError $ Error ctx [e] -liftMaybe :: MonadE m => Text -> Maybe a -> m a +liftMaybe :: (MonadE m) => Text -> Maybe a -> m a liftMaybe msg = maybe (throwErrorText msg) pure -liftEitherString :: (MonadError e m, IsString e) => Either String a -> m a +liftEitherString :: (IsString e, MonadError e m) => Either String a -> m a liftEitherString = either throwErrorString pure -throwErrorText :: MonadE m => Text -> m a +throwErrorText :: (MonadE m) => Text -> m a throwErrorText msg = throwError $ Error msg [] -throwErrorString :: (MonadError e m, IsString e) => String -> m a +throwErrorString :: (IsString e, MonadError e m) => String -> m a throwErrorString = throwError . fromString -correct :: MonadError e m => a -> m a -> m a +correct :: (MonadError e m) => a -> m a -> m a correct def action = action - `catchError` \_e -> - -- TODO(2019-08-06, cblp) $logWarnSH e - pure def + `catchError` \_e -> + -- TODO(2019-08-06, cblp) $logWarnSH e + pure def -tryIO :: (MonadE m, MonadIO m, HasCallStack) => IO a -> m a +tryIO :: (HasCallStack, MonadE m, MonadIO m) => IO a -> m a tryIO action = do - e <- liftIO $ try action - case e of - Right a -> pure a - Left exc -> do - let - description = - case getCallStack callStack of - [] -> "tryIO" - (f, loc) : _ -> Text.pack $ f ++ ", called at " ++ prettySrcLoc loc - throwError - Error{description, reasons = [fromString (show (exc :: SomeException))]} + e <- liftIO $ try action + case e of + Right a -> pure a + Left (exc :: SomeException) -> do + let description = + case getCallStack callStack of + [] -> "tryIO" + (f, loc) : _ -> + Text.pack $ f ++ ", called at " ++ prettySrcLoc loc + throwError Error{description, reasons = [fromString $ show exc]} diff --git a/lib/RON/Event.hs b/lib/RON/Event.hs --- a/lib/RON/Event.hs +++ b/lib/RON/Event.hs @@ -2,64 +2,89 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} module RON.Event ( - CalendarTime (..), - Event (..), - Time (..), - TimeVariety (.., Calendar, Logical, Epoch, Unknown), - OriginVariety - (.., TrieForked, CryptoForked, RecordForked, ApplicationSpecific), - ReplicaClock (..), - Replica (..), - advanceToUuid, - decodeCalendar, - decodeEvent, - decodeReplica, - encodeCalendar, - encodeEvent, - getEvent, - getEventUuid, - getEventUuids, - mkCalendarDate, - mkCalendarDateTime, - mkCalendarDateTimeNano, - mkCalendarEvent, - mkReplica, - mkTime, - timeValue, - timeVariety, + CalendarTime (..), + Event (..), + Time (..), + TimeVariety (.., Calendar, Logical, Epoch, Unknown), + OriginVariety ( + .., + TrieForked, + CryptoForked, + RecordForked, + ApplicationSpecific + ), + ReplicaClock (..), + Replica (..), + advanceToUuid, + decodeCalendar, + decodeEvent, + decodeReplica, + encodeCalendar, + encodeEvent, + getEvent, + getEventUuid, + getEventUuids, + isEventUuid, + mkCalendarDate, + mkCalendarDateTime, + mkCalendarDateTimeNano, + mkCalendarEvent, + mkReplica, + mkTime, + timeValue, + timeVariety, + unsafeDecodeEvent, ) where -import RON.Prelude +import RON.Prelude -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) -import qualified Data.ByteString.Char8 as BSC -import Data.Time (fromGregorianValid, makeTimeOfDayValid) -import qualified Text.Show +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.ByteString.Char8 qualified as BSC +import Data.Time (fromGregorianValid, makeTimeOfDayValid) +import Text.Show qualified -import RON.Base64 (encode60short) -import RON.Util.Word (pattern B00, pattern B01, pattern B10, - pattern B11, Word12, Word2, Word24, Word6, - Word60, leastSignificant12, leastSignificant2, - leastSignificant24, leastSignificant6, ls12, - ls24, ls6, ls60, safeCast) -import RON.UUID (UUID (..), UuidFields (..)) -import qualified RON.UUID as UUID +import RON.Base64 (encode60short) +import RON.UUID (UUID (..), UuidFields (..)) +import RON.UUID qualified as UUID +import RON.Util.Word ( + Word12, + Word2, + Word24, + Word6, + Word60, + leastSignificant12, + leastSignificant2, + leastSignificant24, + leastSignificant6, + ls12, + ls24, + ls6, + ls60, + safeCast, + pattern B00, + pattern B01, + pattern B10, + pattern B11, + ) --- | Calendar format. See https://github.com/gritzko/ron/issues/19. --- Year range is 2010—2350. --- Precision is 100 ns. +{- | Calendar format. See https://github.com/gritzko/ron/issues/19. +Year range is 2010—2350. +Precision is 100 ns. +-} data CalendarTime = CalendarTime - { months :: Word12 - , days :: Word6 - , hours :: Word6 - , minutes :: Word6 - , seconds :: Word6 + { months :: Word12 + , days :: Word6 + , hours :: Word6 + , minutes :: Word6 + , seconds :: Word6 , nanosecHundreds :: Word24 } deriving (Eq, Ord, Show) @@ -72,8 +97,9 @@ pattern Logical :: TimeVariety pattern Logical = TimeVariety B01 --- | RFC 4122 epoch, hundreds of nanoseconds since 1582. --- Year range is 1582—5235. +{- | RFC 4122 epoch, hundreds of nanoseconds since 1582. +Year range is 1582—5235. +-} pattern Epoch :: TimeVariety pattern Epoch = TimeVariety B10 @@ -83,19 +109,19 @@ {-# COMPLETE Calendar, Logical, Epoch, Unknown #-} instance Show TimeVariety where - show = \case - Calendar -> "Calendar" - Logical -> "Logical" - Epoch -> "Epoch" - Unknown -> "Unknown" + show = \case + Calendar {--} -> "Calendar" + Logical {- -} -> "Logical" + Epoch {- -} -> "Epoch" + Unknown {- -} -> "Unknown" -- | Clock type is encoded in 2 higher bits of variety, value in uuidValue newtype Time = Time Word64 - deriving (Eq, Ord) + deriving (Eq, Ord) instance Show Time where - show t = - show (timeVariety t) ++ '/' : BSC.unpack (encode60short $ timeValue t) + show t = + show (timeVariety t) ++ '/' : BSC.unpack (encode60short $ timeValue t) timeVariety :: Time -> TimeVariety timeVariety (Time w64) = TimeVariety $ leastSignificant2 $ w64 `shiftR` 62 @@ -105,7 +131,7 @@ -- | Replica id assignment style newtype OriginVariety = OriginVariety Word2 - deriving newtype (Hashable) + deriving newtype (Eq, Hashable) pattern TrieForked :: OriginVariety pattern TrieForked = OriginVariety B00 @@ -122,165 +148,187 @@ {-# COMPLETE TrieForked, CryptoForked, RecordForked, ApplicationSpecific #-} instance Show OriginVariety where - show = \case - TrieForked -> "Trie" - CryptoForked -> "Crypto" - RecordForked -> "Record" - ApplicationSpecific -> "App" + show = \case + TrieForked -> "Trie" + CryptoForked -> "Crypto" + RecordForked -> "Record" + ApplicationSpecific -> "App" --- | Replica identifier. --- Implementation: naming (62-61) and origin (60-0 bits) fields from UUID +{- | Replica identifier. +Implementation: naming (62-61) and origin (60-0 bits) fields from UUID +-} newtype Replica = Replica Word64 - deriving newtype (Eq, Hashable, Ord) + deriving newtype (Eq, Hashable, Ord) instance Show Replica where - show (Replica w64) = - show (OriginVariety $ leastSignificant2 $ w64 `shiftR` 60) - ++ '/' : BSC.unpack (encode60short $ ls60 w64) + show (Replica w64) = + show (OriginVariety $ leastSignificant2 $ w64 `shiftR` 60) + ++ '/' + : BSC.unpack (encode60short $ ls60 w64) --- | Generic Lamport time event. --- Cannot be 'Ord' because we can't compare different types of clocks. --- If you want comparable events, use specific 'EpochEvent'. +{- | Generic Lamport time event. +Cannot be 'Ord' because we can't compare different types of clocks. +If you want comparable events, use specific 'EpochEvent'. +-} data Event = Event - { time :: !Time - , replica :: !Replica - } - deriving (Eq, Generic, Show) - -class Monad m => ReplicaClock m where + { time :: !Time + , replica :: !Replica + } + deriving (Eq, Generic, Show) +class (Monad m) => ReplicaClock m where -- | Get current replica id getPid :: m Replica - -- | Get sequential timestamps. - -- - -- Laws: - -- - -- 1. @ - --t <- getEvents n - --(t !! i) == head t + i - -- @ - -- - -- 2. @ - --t1 <- 'getEvent' - --t2 <- 'getEvent' - --t2 >= t1 + 1 - -- @ - -- - -- 3. @getEvents 0 == getEvents 1@ - getEvents - :: Word60 -- ^ number of needed timestamps - -> m [Event] + {- | Get sequential timestamps. + Laws: + + 1. @ + t <- getEvents n + (t !! i) == head t + i + @ + + 2. @ + t1 <- 'getEvent' + t2 <- 'getEvent' + t2 >= t1 + 1 + @ + + 3. @getEvents 0 == getEvents 1@ + -} + getEvents :: + -- | number of needed timestamps + Word60 -> + m [Event] + -- | Make local time not less than this advance :: Word60 -> m () -instance ReplicaClock m => ReplicaClock (ExceptT e m) where - getPid = lift getPid +instance (ReplicaClock m) => ReplicaClock (ExceptT e m) where + getPid = lift getPid getEvents = lift . getEvents - advance = lift . advance + advance = lift . advance -instance ReplicaClock m => ReplicaClock (ReaderT r m) where - getPid = lift getPid +instance (ReplicaClock m) => ReplicaClock (ReaderT r m) where + getPid = lift getPid getEvents = lift . getEvents - advance = lift . advance + advance = lift . advance -instance ReplicaClock m => ReplicaClock (StateT s m) where - getPid = lift getPid +instance (ReplicaClock m) => ReplicaClock (StateT s m) where + getPid = lift getPid getEvents = lift . getEvents - advance = lift . advance + advance = lift . advance instance (Monoid s, ReplicaClock m) => ReplicaClock (WriterT s m) where - getPid = lift getPid + getPid = lift getPid getEvents = lift . getEvents - advance = lift . advance + advance = lift . advance --- | 'advance' variant for any UUID -advanceToUuid :: ReplicaClock clock => UUID -> clock () -advanceToUuid uuid = - when (uuidVariant == B00 && uuidVersion == B10) $ advance uuidValue +isEventUuid :: UUID -> Bool +isEventUuid uuid = + uuidVariant == B00 && (uuidVersion == B10 || uuidVersion == B11) where - UuidFields{uuidValue, uuidVariant, uuidVersion} = UUID.split uuid + UuidFields{uuidVariant, uuidVersion} = UUID.split uuid +-- | 'advance' variant for any UUID, but works only for event UUIDs +advanceToUuid :: (ReplicaClock clock) => UUID -> clock () +advanceToUuid uuid = when (isEventUuid uuid) $ advance uuidValue + where + UuidFields{uuidValue} = UUID.split uuid + -- | Get a single event getEvent :: (HasCallStack, ReplicaClock m) => m Event -getEvent = getEvents (ls60 1) >>= \case - e:_ -> pure e - [] -> error "getEvents returned no events" +getEvent = + getEvents 1 >>= \case + e : _ -> pure e + [] -> error "getEvents returned no events" -- | Get a single event as UUID -getEventUuid :: ReplicaClock m => m UUID +getEventUuid :: (ReplicaClock m) => m UUID getEventUuid = encodeEvent <$> getEvent -- | Get event sequence as UUIDs -getEventUuids :: ReplicaClock m => Word60 -> m [UUID] +getEventUuids :: (ReplicaClock m) => Word60 -> m [UUID] getEventUuids = fmap (map encodeEvent) . getEvents encodeCalendar :: CalendarTime -> Word60 -encodeCalendar CalendarTime{..} = ls60 $ - (safeCast months `shiftL` 48) .|. - (safeCast days `shiftL` 42) .|. - (safeCast hours `shiftL` 36) .|. - (safeCast minutes `shiftL` 30) .|. - (safeCast seconds `shiftL` 24) .|. - safeCast nanosecHundreds +encodeCalendar CalendarTime{..} = + ls60 $ + (safeCast months `shiftL` 48) + .|. (safeCast days `shiftL` 42) + .|. (safeCast hours `shiftL` 36) + .|. (safeCast minutes `shiftL` 30) + .|. (safeCast seconds `shiftL` 24) + .|. safeCast nanosecHundreds decodeCalendar :: Word60 -> CalendarTime -decodeCalendar w = CalendarTime - { months = leastSignificant12 $ v `shiftR` 48 - , days = leastSignificant6 $ v `shiftR` 42 - , hours = leastSignificant6 $ v `shiftR` 36 - , minutes = leastSignificant6 $ v `shiftR` 30 - , seconds = leastSignificant6 $ v `shiftR` 24 - , nanosecHundreds = leastSignificant24 v - } +decodeCalendar w = + CalendarTime + { months = leastSignificant12 $ v `shiftR` 48 + , days = leastSignificant6 $ v `shiftR` 42 + , hours = leastSignificant6 $ v `shiftR` 36 + , minutes = leastSignificant6 $ v `shiftR` 30 + , seconds = leastSignificant6 $ v `shiftR` 24 + , nanosecHundreds = leastSignificant24 v + } where v = safeCast w :: Word64 decodeTime :: Word64 -> Time -decodeTime value = Time $ value .&. 0xCFFFFFFFFFFFFFFF +decodeTime value = Time $ value .&. 0x_CFFF_FFFF_FFFF_FFFF encodeEvent :: Event -> UUID encodeEvent Event{time, replica} = - UUID (varietyAndValue .|. originVariety) (eventVersion .|. origin) + UUID (varietyAndValue .|. originVariety) (eventVersion .|. origin) where Time varietyAndValue = time (originVariety, origin) = encodeReplicaId replica - eventVersion = 0x2000000000000000 + eventVersion = 0x_2000_0000_0000_0000 -decodeEvent :: UUID -> Event -decodeEvent u@(UUID x _) = Event{replica = decodeReplica u, time = decodeTime x} +-- | Assume UUID is event +decodeEvent :: UUID -> Maybe Event +decodeEvent u = guard (isEventUuid u) $> unsafeDecodeEvent u +unsafeDecodeEvent :: UUID -> Event +unsafeDecodeEvent u@(UUID x _) = + Event{replica = decodeReplica u, time = decodeTime x} + decodeReplica :: UUID -> Replica decodeReplica (UUID x y) = - Replica $ (x .&. 0x3000000000000000) .|. (y .&. 0x0FFFFFFFFFFFFFFF) + Replica $ (x .&. 0x_3000_0000_0000_0000) .|. (y .&. 0x_0FFF_FFFF_FFFF_FFFF) encodeReplicaId :: Replica -> (Word64, Word64) encodeReplicaId (Replica r) = - ( r .&. 0x3000000000000000 - , r .&. 0x0FFFFFFFFFFFFFFF - ) + ( r .&. 0x_3000_0000_0000_0000 + , r .&. 0x_0FFF_FFFF_FFFF_FFFF + ) -- | Make a calendar timestamp from a date -mkCalendarDate - :: (Word16, Word16, Word8) -- ^ date as (year, month [1..12], day [1..]) - -> Maybe CalendarTime +mkCalendarDate :: + -- | date as (year, month [1..12], day [1..]) + (Word16, Word16, Word8) -> + Maybe CalendarTime mkCalendarDate ymd = mkCalendarDateTime ymd (0, 0, 0) -- | Make a calendar timestamp from a date and a day time -mkCalendarDateTime - :: (Word16, Word16, Word8) -- ^ date as (year, month [1..12], day [1..]) - -> (Word8, Word8, Word8) -- ^ day time as (hours, minutes, seconds) - -> Maybe CalendarTime +mkCalendarDateTime :: + -- | date as (year, month [1..12], day [1..]) + (Word16, Word16, Word8) -> + -- | day time as (hours, minutes, seconds) + (Word8, Word8, Word8) -> + Maybe CalendarTime mkCalendarDateTime ymd hms = mkCalendarDateTimeNano ymd hms 0 -- | Make a calendar timestamp from a date, a day time, and a second fraction -mkCalendarDateTimeNano - :: (Word16, Word16, Word8) -- ^ date as (year, month [1..12], day [1..]) - -> (Word8, Word8, Word8) -- ^ day time as (hours, minutes, seconds) - -> Word32 -- ^ fraction of a second in hundreds of - -- nanosecond - -> Maybe CalendarTime +mkCalendarDateTimeNano :: + -- | date as (year, month [1..12], day [1..]) + (Word16, Word16, Word8) -> + -- | day time as (hours, minutes, seconds) + (Word8, Word8, Word8) -> + -- | fraction of a second in hundreds of nanosecond + Word32 -> + Maybe CalendarTime mkCalendarDateTimeNano (y, m, d) (hh, mm, ss) hns = do guard $ y >= 2010 let months = (y - 2010) * 12 + m - 1 @@ -288,25 +336,26 @@ _ <- fromGregorianValid (fromIntegral y) (fromIntegral m) (fromIntegral d) _ <- makeTimeOfDayValid (fromIntegral hh) (fromIntegral mm) (fromIntegral ss) - guard $ hns < 10000000 - pure CalendarTime - { months = ls12 months - , days = ls6 $ d - 1 - , hours = ls6 hh - , minutes = ls6 mm - , seconds = ls6 ss - , nanosecHundreds = ls24 hns - } + guard $ hns < 10_000_000 + pure + CalendarTime + { months = ls12 months + , days = ls6 $ d - 1 + , hours = ls6 hh + , minutes = ls6 mm + , seconds = ls6 ss + , nanosecHundreds = ls24 hns + } -- | Make a replica id from 'OriginVariety' and arbitrary number mkReplica :: OriginVariety -> Word60 -> Replica mkReplica (OriginVariety variety) origin = - Replica $ (safeCast variety `shiftL` 60) .|. safeCast origin + Replica $ (safeCast variety `shiftL` 60) .|. safeCast origin mkTime :: TimeVariety -> Word60 -> Time mkTime (TimeVariety variety) value = - Time $ (safeCast variety `shiftL` 62) .|. safeCast value + Time $ (safeCast variety `shiftL` 62) .|. safeCast value mkCalendarEvent :: CalendarTime -> Replica -> Event mkCalendarEvent time replica = - Event{time = mkTime Calendar $ encodeCalendar time, replica} + Event{time = mkTime Calendar $ encodeCalendar time, replica} diff --git a/lib/RON/Event/Simulation.hs b/lib/RON/Event/Simulation.hs --- a/lib/RON/Event/Simulation.hs +++ b/lib/RON/Event/Simulation.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} --- | Lamport clock network simulation. --- 'ReplicaSim' provides 'Replica' and 'Clock' instances, --- replicas may interchange data while they are connected in a 'NetworkSim'. +{- | Lamport clock network simulation. +'ReplicaSim' provides 'Replica' and 'Clock' instances, +replicas may interchange data while they are connected in a 'NetworkSim'. +-} module RON.Event.Simulation ( NetworkSimT, ReplicaSimT, @@ -12,18 +15,27 @@ runReplicaSimT, ) where -import RON.Prelude +import RON.Prelude -import Control.Monad.State.Strict (state) -import qualified Data.HashMap.Strict as HM +import Control.Monad.State.Strict (state) +import Data.Bits (xor) +import Data.HashMap.Strict qualified as HM -import RON.Event (Event (..), Replica (Replica), ReplicaClock, - TimeVariety (Logical), advance, getEvents, getPid, - mkTime) -import RON.Util.Word (Word60, ls60) +import RON.Event ( + Event (..), + Replica (Replica), + ReplicaClock, + TimeVariety (Logical), + advance, + getEvents, + getPid, + mkTime, + ) +import RON.Util.Word (Word60, ls60, safeCast) --- | Lamport clock simulation. Key is 'Replica'. --- Non-present value is equivalent to (0, initial). +{- | Lamport clock simulation. Key is 'Replica'. +Non-present value is equivalent to (0, initial). +-} newtype NetworkSimT m a = NetworkSim (StateT (HashMap Replica Word60) m a) deriving (Applicative, Functor, Monad, MonadError e) @@ -37,20 +49,26 @@ instance MonadTrans ReplicaSimT where lift = ReplicaSim . lift . lift -instance Monad m => ReplicaClock (ReplicaSimT m) where +-- Hash backported from older version of `hashable` +oldHash :: Word60 -> Word64 -> Word64 +oldHash x y = defaultSalt `combine` safeCast x `combine` 1 `combine` y + where + defaultSalt = 0xdc36d1615b7400a4 + combine a b = (a * 16777619) `xor` b + +instance (Monad m) => ReplicaClock (ReplicaSimT m) where getPid = ReplicaSim ask getEvents n' = ReplicaSim $ do replica <- ask (t0, t1) <- - lift $ NetworkSim $ state $ \replicaStates -> let - t0orig = HM.lookupDefault (ls60 0) replica replicaStates - Replica r = replica - randomLeap = - ls60 . fromIntegral $ hash (t0orig, n, r) `mod` 0x10000 - t0 = t0orig + randomLeap - t1 = t0 + n - in ((t0, t1), HM.insert replica t1 replicaStates) + lift $ NetworkSim $ state \replicaStates -> + let t0orig = HM.lookupDefault (ls60 0) replica replicaStates + Replica r = replica + randomLeap = ls60 $ oldHash t0orig r `mod` 0x10000 + t0 = t0orig + randomLeap + t1 = t0 + n + in ((t0, t1), HM.insert replica t1 replicaStates) pure [Event{time = mkTime Logical t, replica} | t <- [succ t0 .. t1]] where n = max n' (ls60 1) @@ -60,28 +78,29 @@ lift . NetworkSim . modify' $ HM.alter (Just . advancePS) rid where advancePS = \case - Nothing -> time + Nothing -> time Just current -> max time current -instance MonadFail m => MonadFail (ReplicaSimT m) where +instance (MonadFail m) => MonadFail (ReplicaSimT m) where fail = lift . fail --- | Execute network simulation --- --- Usage: --- --- @ --- 'runExceptT' . runNetworkSimT $ do --- 'runReplicaSimT' r1 $ do --- actions... --- 'runReplicaSimT' r2 $ do --- actions... --- 'runReplicaSimT' r1 $ ... --- @ --- --- Each 'runNetworkSimT' starts its own networks. --- One shouldn't use in one network events generated in another. -runNetworkSimT :: Monad m => NetworkSimT m a -> m a +{- | Execute network simulation + +Usage: + +@ +'runExceptT' . runNetworkSimT $ do + 'runReplicaSimT' r1 $ do + actions... + 'runReplicaSimT' r2 $ do + actions... + 'runReplicaSimT' r1 $ ... +@ + +Each 'runNetworkSimT' starts its own networks. +One shouldn't use in one network events generated in another. +-} +runNetworkSimT :: (Monad m) => NetworkSimT m a -> m a runNetworkSimT (NetworkSim action) = evalStateT action mempty runReplicaSimT :: Replica -> ReplicaSimT m a -> NetworkSimT m a diff --git a/lib/RON/Prelude.hs b/lib/RON/Prelude.hs --- a/lib/RON/Prelude.hs +++ b/lib/RON/Prelude.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} module RON.Prelude ( @@ -7,6 +9,7 @@ foldr1, headMay, lastDef, + lastMay, maximumDef, maximumMay, maximumMayOn, @@ -25,94 +28,207 @@ ) where -- TODO import RON.Prelude.Writer as X -import Control.Monad.Writer.Strict as X (WriterT, runWriterT, tell) +import Control.Monad.Writer.Strict as X (WriterT, runWriterT, tell) -- base -import Control.Applicative as X (Alternative, Applicative, liftA2, - many, optional, pure, some, (*>), - (<*), (<*>), (<|>)) -import Control.Exception as X (Exception, catch, evaluate, throwIO) -import Control.Monad as X (Monad, filterM, guard, unless, void, when, - (<=<), (=<<), (>=>), (>>), (>>=)) -import Control.Monad.Except as X (ExceptT (ExceptT), MonadError, - catchError, liftEither, runExceptT, - throwError) -import Control.Monad.Fail as X (MonadFail, fail) -import Control.Monad.IO.Class as X (MonadIO, liftIO) -import Control.Monad.Reader as X (MonadReader, ReaderT (ReaderT), ask, - asks, reader, runReaderT) -import Control.Monad.State.Strict as X (MonadState, State, StateT, - evalState, evalStateT, - execStateT, get, gets, - modify', put, runState, - runStateT) -import Control.Monad.Trans as X (MonadTrans, lift) -import Data.Bifunctor as X (bimap) -import Data.Bool as X (Bool (False, True), not, otherwise, (&&), (||)) -import Data.ByteString as X (ByteString) -import Data.Char as X (Char, chr, ord, toLower, toUpper) -import Data.Coerce as X (Coercible, coerce) -import Data.Data as X (Data) -import Data.Either as X (Either (Left, Right), either) -import Data.Eq as X (Eq, (/=), (==)) -import Data.Foldable as X (Foldable, all, and, any, asum, elem, fold, - foldMap, foldl', foldr, for_, length, null, - or, toList, traverse_) -import Data.Function as X (const, flip, id, on, ($), (&), (.)) -import Data.Functor as X (Functor, fmap, ($>), (<$), (<$>), (<&>)) -import Data.Functor.Identity as X (Identity) -import Data.Hashable as X (Hashable, hash) -import Data.HashMap.Strict as X (HashMap) -import Data.Int as X (Int, Int16, Int32, Int64, Int8) -import Data.IORef as X (IORef, atomicModifyIORef', newIORef, - readIORef, writeIORef) -import Data.List as X (drop, filter, genericLength, intercalate, - isPrefixOf, isSuffixOf, lookup, map, partition, - repeat, replicate, sort, sortBy, sortOn, span, - splitAt, take, takeWhile, unlines, unwords, - zip, zipWith, (++)) -import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty) -import Data.Map.Strict as X (Map) -import Data.Maybe as X (Maybe (Just, Nothing), catMaybes, fromMaybe, - listToMaybe, mapMaybe, maybe, maybeToList) -import Data.Monoid as X (Last (Last), Monoid, mempty) -import Data.Ord as X (Down (Down), Ord, Ordering (EQ, GT, LT), - compare, comparing, max, min, (<), (<=), (>), - (>=)) -import Data.Proxy as X (Proxy (Proxy)) -import Data.Ratio as X ((%)) -import Data.Semigroup as X (Semigroup, sconcat, (<>)) -import Data.Sequence as X (Seq) -import Data.Set as X (Set) -import Data.String as X (String) -import Data.Text as X (Text) -import Data.Time as X (UTCTime) -import Data.Traversable as X (for, sequence, sequenceA, traverse) -import Data.Tuple as X (fst, snd, uncurry) -import Data.Typeable as X (Typeable) -import Data.Vector as X (Vector) -import Data.Word as X (Word, Word16, Word32, Word64, Word8) -import GHC.Enum as X (Bounded, Enum, fromEnum, maxBound, minBound, - pred, succ, toEnum) -import GHC.Err as X (error, undefined) -import GHC.Exts as X (Double) -import GHC.Generics as X (Generic) -import GHC.Integer as X (Integer) -import GHC.Num as X (Num, negate, subtract, (*), (+), (-)) -import GHC.Real as X (Integral, fromIntegral, mod, realToFrac, round, - (/), (^), (^^)) -import GHC.Stack as X (HasCallStack) -import System.IO as X (FilePath, IO) -import Text.Read as X (readMaybe) -import Text.Show as X (Show) +import Control.Applicative as X ( + Alternative, + Applicative, + liftA2, + many, + optional, + pure, + some, + (*>), + (<*), + (<*>), + (<|>), + ) +import Control.Arrow as X ((>>>)) +import Control.Exception as X (Exception) +import Control.Monad as X ( + Monad, + filterM, + guard, + unless, + void, + when, + (<=<), + (=<<), + (>=>), + (>>), + (>>=), + ) +import Control.Monad.Except as X ( + ExceptT (ExceptT), + MonadError, + catchError, + liftEither, + runExceptT, + throwError, + ) +import Control.Monad.Fail as X (MonadFail, fail) +import Control.Monad.IO.Class as X (MonadIO, liftIO) +import Control.Monad.Reader as X ( + MonadReader, + ReaderT (ReaderT), + ask, + asks, + reader, + runReaderT, + ) +import Control.Monad.State.Strict as X ( + MonadState, + State, + StateT, + evalState, + evalStateT, + execStateT, + get, + gets, + modify', + put, + runState, + runStateT, + ) +import Control.Monad.Trans as X (MonadTrans, lift) +import Data.Bifunctor as X (bimap) +import Data.Bool as X (Bool (False, True), not, otherwise, (&&), (||)) +import Data.ByteString as X (ByteString) +import Data.Char as X (Char, chr, ord, toLower, toUpper) +import Data.Coerce as X (Coercible, coerce) +import Data.Data as X (Data) +import Data.Either as X (Either (Left, Right), either) +import Data.Eq as X (Eq, (/=), (==)) +import Data.Foldable as X ( + Foldable, + all, + and, + any, + asum, + elem, + fold, + foldMap, + foldl', + foldr, + for_, + length, + notElem, + null, + or, + toList, + traverse_, + ) +import Data.Function as X (const, flip, id, on, ($), (&), (.)) +import Data.Functor as X (Functor, fmap, ($>), (<$), (<$>), (<&>)) +import Data.Functor.Identity as X (Identity) +import Data.HashMap.Strict as X (HashMap) +import Data.Hashable as X (Hashable, hash) +import Data.IORef as X (IORef) +import Data.Int as X (Int, Int16, Int32, Int64, Int8) +import Data.List as X ( + drop, + filter, + genericLength, + intercalate, + isPrefixOf, + isSuffixOf, + lookup, + map, + partition, + repeat, + replicate, + reverse, + sort, + sortBy, + sortOn, + span, + splitAt, + take, + takeWhile, + unlines, + unwords, + zip, + zip3, + zipWith, + (++), + ) +import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty) +import Data.Map.Strict as X (Map) +import Data.Maybe as X ( + Maybe (Just, Nothing), + catMaybes, + fromMaybe, + listToMaybe, + mapMaybe, + maybe, + maybeToList, + ) +import Data.Monoid as X (Last (Last), Monoid, mempty) +import Data.Ord as X ( + Down (Down), + Ord, + Ordering (EQ, GT, LT), + compare, + comparing, + max, + min, + (<), + (<=), + (>), + (>=), + ) +import Data.Proxy as X (Proxy (Proxy)) +import Data.Ratio as X ((%)) +import Data.Semigroup as X (Semigroup, sconcat, (<>)) +import Data.Sequence as X (Seq) +import Data.Set as X (Set) +import Data.String as X (String) +import Data.Text as X (Text) +import Data.Time as X (UTCTime) +import Data.Traversable as X (for, sequence, sequenceA, traverse) +import Data.Tuple as X (fst, snd, uncurry) +import Data.Type.Equality as X (type (~)) +import Data.Typeable as X (Typeable) +import Data.Vector as X (Vector) +import Data.Word as X (Word, Word16, Word32, Word64, Word8) +import GHC.Enum as X ( + Bounded, + Enum, + fromEnum, + maxBound, + minBound, + pred, + succ, + toEnum, + ) +import GHC.Err as X (error, undefined) +import GHC.Exts as X (Double) +import GHC.Generics as X (Generic) +import GHC.Integer as X (Integer) +import GHC.Num as X (Num, negate, subtract, (*), (+), (-)) +import GHC.Real as X ( + Integral, + fromIntegral, + mod, + realToFrac, + round, + (/), + (^), + (^^), + ) +import GHC.Stack as X (HasCallStack) +import System.IO as X (FilePath, IO) +import Text.Read as X (readMaybe) +import Text.Show as X (Show) -------------------------------------------------------------------------------- -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Foldable -import Data.List (last, maximum, maximumBy, minimum, minimumBy) -import Data.String (IsString, fromString) -import qualified Text.Show +import Data.ByteString.Lazy qualified as BSL +import Data.Foldable qualified +import Data.List (last, maximum, maximumBy, minimum, minimumBy) +import Data.String (IsString, fromString) +import Text.Show qualified type ByteStringL = BSL.ByteString @@ -124,9 +240,19 @@ headMay :: [a] -> Maybe a headMay = \case - [] -> Nothing - a:_ -> Just a + [] -> Nothing + a : _ -> Just a +lastMay :: [a] -> Maybe a +lastMay = \case + [] -> Nothing + x : xs -> Just $ lastMayImpl x xs + +lastMayImpl :: a -> [a] -> a +lastMayImpl x = \case + [] -> x + y : ys -> lastMayImpl y ys + lastDef :: a -> [a] -> a lastDef def = list' def last @@ -135,52 +261,53 @@ [] -> onEmpty xs -> onNonEmpty xs -maximumDef :: Ord a => a -> [a] -> a +maximumDef :: (Ord a) => a -> [a] -> a maximumDef def = list' def maximum -maximumMay :: Ord a => [a] -> Maybe a +maximumMay :: (Ord a) => [a] -> Maybe a maximumMay = list' Nothing (Just . maximum) -maximumMayOn :: Ord b => (a -> b) -> [a] -> Maybe a +maximumMayOn :: (Ord b) => (a -> b) -> [a] -> Maybe a maximumMayOn key = list' Nothing (Just . maximumBy (comparing key)) -maxOn :: Ord b => (a -> b) -> a -> a -> a +maxOn :: (Ord b) => (a -> b) -> a -> a -> a maxOn f x y = if f x < f y then y else x -minimumDef :: Ord a => a -> [a] -> a +minimumDef :: (Ord a) => a -> [a] -> a minimumDef def = list' def minimum -minimumMay :: Ord a => [a] -> Maybe a +minimumMay :: (Ord a) => [a] -> Maybe a minimumMay = list' Nothing (Just . minimum) -minimumMayOn :: Ord b => (a -> b) -> [a] -> Maybe a +minimumMayOn :: (Ord b) => (a -> b) -> [a] -> Maybe a minimumMayOn key = list' Nothing (Just . minimumBy (comparing key)) -minOn :: Ord b => (a -> b) -> a -> a -> a +minOn :: (Ord b) => (a -> b) -> a -> a -> a minOn f x y = if f x < f y then x else y note :: e -> Maybe a -> Either e a note e = maybe (Left e) Right -replicateM2 :: Applicative m => m a -> m (a, a) +replicateM2 :: (Applicative m) => m a -> m (a, a) replicateM2 ma = (,) <$> ma <*> ma -replicateM3 :: Applicative m => m a -> m (a, a, a) +replicateM3 :: (Applicative m) => m a -> m (a, a, a) replicateM3 ma = (,,) <$> ma <*> ma <*> ma -show :: (Show a, IsString s) => a -> s +show :: (IsString s, Show a) => a -> s show = fromString . Text.Show.show -whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () +whenJust :: (Applicative m) => Maybe a -> (a -> m ()) -> m () whenJust m f = maybe (pure ()) f m (!!) :: [a] -> Int -> Maybe a xs !! i - | i < 0 = Nothing + | i < 0 = Nothing | otherwise = headMay $ drop i xs -- | An infix form of 'fromMaybe' with arguments flipped. (?:) :: Maybe a -> a -> a maybeA ?: b = fromMaybe b maybeA -{-# INLINABLE (?:) #-} +{-# INLINEABLE (?:) #-} + infixr 0 ?: diff --git a/lib/RON/Semilattice.hs b/lib/RON/Semilattice.hs --- a/lib/RON/Semilattice.hs +++ b/lib/RON/Semilattice.hs @@ -6,10 +6,10 @@ BoundedSemilattice, ) where -import Prelude +import Prelude -import Data.Semigroup (Max) -import Data.Set (Set) +import Data.Semigroup (Max) +import Data.Set (Set) {- | A semilattice. @@ -33,11 +33,10 @@ @x '≼' y == (x '<>' y == y)@ @x '<>' y == minimum \z -> x '≼' z && y '≼' z@ -} -class Semigroup a => Semilattice a where - +class (Semigroup a) => Semilattice a where -- | Semilattice relation. (≼) :: a -> a -> Bool - default (≼) :: Eq a => a -> a -> Bool + default (≼) :: (Eq a) => a -> a -> Bool a ≼ b = a <> b == b {- | @@ -50,11 +49,11 @@ -- instances for base types -instance Ord a => Semilattice (Max a) +instance (Ord a) => Semilattice (Max a) -instance Ord a => Semilattice (Set a) +instance (Ord a) => Semilattice (Set a) -instance Semilattice a => Semilattice (Maybe a) where - Nothing ≼ _ = True - _ ≼ Nothing = False - Just a ≼ Just b = a ≼ b +instance (Semilattice a) => Semilattice (Maybe a) where + Nothing ≼ _ = True + _ ≼ Nothing = False + Just a ≼ Just b = a ≼ b diff --git a/lib/RON/Text.hs b/lib/RON/Text.hs --- a/lib/RON/Text.hs +++ b/lib/RON/Text.hs @@ -15,9 +15,20 @@ uuidToText, ) where -import RON.Text.Parse (parseObject, parseStateChunk, parseStateFrame, - parseWireFrame, parseWireFrames, - uuidFromString, uuidFromText) -import RON.Text.Serialize (serializeObject, serializeStateFrame, - serializeWireFrame, serializeWireFrames, - uuidToString, uuidToText) +import RON.Text.Parse ( + parseObject, + parseStateChunk, + parseStateFrame, + parseWireFrame, + parseWireFrames, + uuidFromString, + uuidFromText, + ) +import RON.Text.Serialize ( + serializeObject, + serializeStateFrame, + serializeWireFrame, + serializeWireFrames, + uuidToString, + uuidToText, + ) diff --git a/lib/RON/Text/Parse.hs b/lib/RON/Text/Parse.hs --- a/lib/RON/Text/Parse.hs +++ b/lib/RON/Text/Parse.hs @@ -1,7 +1,10 @@ {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -12,6 +15,7 @@ parseOp, parseOpenFrame, parseOpenOp, + parsePayload, parseStateChunk, parseStateFrame, parseString, @@ -24,39 +28,74 @@ uuidFromText, ) where -import RON.Prelude hiding (takeWhile) +import RON.Prelude hiding (takeWhile) -import Attoparsec.Extra (Parser, char, definiteDouble, endOfInputEx, - isSuccessful, label, manyTill, parseOnlyL, - satisfy, (<+>), (??)) -import qualified Data.Aeson as Json -import Data.Attoparsec.ByteString (takeWhile1) -import Data.Attoparsec.ByteString.Char8 (anyChar, decimal, double, - signed, skipSpace, takeWhile) -import Data.Bits (complement, shiftL, shiftR, (.&.), (.|.)) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, isNothing) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text +import Attoparsec.Extra ( + Parser, + char, + definiteDouble, + endOfInputEx, + isSuccessful, + label, + manyTill, + parseOnly, + satisfy, + (<+>), + (??), + ) +import Data.Aeson qualified as Json +import Data.Attoparsec.ByteString (takeWhile1) +import Data.Attoparsec.ByteString.Char8 ( + anyChar, + decimal, + double, + signed, + skipSpace, + takeWhile, + ) +import Data.Bits (complement, shiftL, shiftR, (.&.), (.|.)) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BSC +import Data.ByteString.Lazy qualified as BSL +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust, isNothing) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text -import qualified RON.Base64 as Base64 -import RON.Types (Atom (AFloat, AInteger, AString, AUuid), - ClosedOp (..), ObjectFrame (ObjectFrame), Op (..), - OpTerm (TClosed, THeader, TQuery, TReduced), - Payload, StateFrame, UUID (UUID), - WireChunk (Closed, Query, Value), WireFrame, - WireReducedChunk (..), WireStateChunk (..)) -import RON.Util.Word (Word2, Word4, Word60, b00, b0000, b01, b10, b11, - ls60, safeCast) -import RON.UUID (UuidFields (..)) -import qualified RON.UUID as UUID +import RON.Base64 qualified as Base64 +import RON.Types ( + Atom (AFloat, AInteger, AString, AUuid), + ClosedOp (..), + ObjectFrame (ObjectFrame), + Op (..), + OpTerm (TClosed, THeader, TQuery, TReduced), + Packer (PackChain, PackFixed, PackIncrement), + Payload, + StateFrame, + UUID (UUID), + WireChunk (Closed, Query, Value), + WireFrame, + WireReducedChunk (..), + WireStateChunk (..), + ) +import RON.UUID (UuidFields (..), addValue, succValue) +import RON.UUID qualified as UUID +import RON.Util.Word ( + Word2, + Word4, + Word60, + b00, + b0000, + b01, + b10, + b11, + ls60, + safeCast, + ) -- | Parse a common frame parseWireFrame :: ByteStringL -> Either String WireFrame -parseWireFrame = parseOnlyL frame +parseWireFrame = parseOnly frame chunksTill :: Parser () -> Parser [WireChunk] chunksTill end = label "[WireChunk]" $ go closedOpZero @@ -75,62 +114,59 @@ pChunk prev = label "WireChunk" $ wireReducedChunk prev <+> chunkClosed prev chunkClosed :: ClosedOp -> Parser (WireChunk, ClosedOp) -chunkClosed prev = label "WireChunk-closed" $ do - skipSpace - (_, x) <- closedOp prev - skipSpace - void $ char ';' - pure (Closed x, x) +chunkClosed prev = + label "WireChunk-closed" do + skipSpace + (_, x) <- closedOp prev + skipSpace + void $ char ';' + pure (Closed x, x) -- | Returns a chunk and the last op (converted to closed) in it wireReducedChunk :: ClosedOp -> Parser (WireChunk, ClosedOp) -wireReducedChunk prev = label "WireChunk-reduced" $ do - (wrcHeader, isQuery) <- header prev - let reducedOps y = do - skipSpace - (isNotEmpty, x) <- reducedOp (objectId wrcHeader) y - t <- optional term - unless (t == Just TReduced || isNothing t) $ - fail "reduced op may end with `,` only" - unless (isNotEmpty || t == Just TReduced) $ fail "Empty reduced op" - xs <- reducedOps x <|> stop - pure $ x : xs - wrcBody <- reducedOps (op wrcHeader) <|> stop - let lastOp = lastDef (op wrcHeader) wrcBody - wrap op = ClosedOp - {reducerId = reducerId wrcHeader, objectId = objectId wrcHeader, op} - pure ((if isQuery then Query else Value) WireReducedChunk{..}, wrap lastOp) +wireReducedChunk prev = + label "WireChunk-reduced" do + (wrcHeader, isQuery) <- header prev + wrcBody <- reducedOps wrcHeader.objectId wrcHeader.op <|> stop + let lastOp = lastDef wrcHeader.op wrcBody + lastClosedOp = wrcHeader{op = lastOp} + pure + ( (if isQuery then Query else Value) WireReducedChunk{..} + , lastClosedOp + ) where stop = pure [] parseStateChunk :: ByteStringL -> Either String WireStateChunk -parseStateChunk = parseOnlyL $ do - (Value value, _) <- wireReducedChunk closedOpZero - let - WireReducedChunk{wrcHeader, wrcBody} = value - ClosedOp{reducerId} = wrcHeader - pure WireStateChunk{stateType = reducerId, stateBody = wrcBody} +parseStateChunk = + parseOnly do + (Value value, _) <- wireReducedChunk closedOpZero + let WireReducedChunk{wrcHeader, wrcBody} = value + ClosedOp{reducerId} = wrcHeader + pure WireStateChunk{stateType = reducerId, stateBody = wrcBody} frame :: Parser WireFrame frame = label "WireFrame" $ chunksTill (endOfFrame <|> endOfInputEx) -- | Parse a sequence of common frames parseWireFrames :: ByteStringL -> Either String [WireFrame] -parseWireFrames = parseOnlyL $ manyTill frameInStream endOfInputEx +parseWireFrames = parseOnly $ manyTill frameInStream endOfInputEx frameInStream :: Parser WireFrame frameInStream = label "WireFrame-stream" $ chunksTill endOfFrame -- | Parse a single context-free op parseOp :: ByteStringL -> Either String ClosedOp -parseOp = parseOnlyL $ do - (_, x) <- closedOp closedOpZero <* skipSpace <* endOfInputEx - pure x +parseOp = + parseOnly do + (_, x) <- closedOp closedOpZero <* skipSpace <* endOfInputEx + pure x -- | Parse a single context-free UUID parseUuid :: ByteStringL -> Either String UUID -parseUuid = parseOnlyL $ - uuid UUID.zero UUID.zero PrevOpSameKey <* skipSpace <* endOfInputEx +parseUuid = + parseOnly $ + uuid UUID.zero UUID.zero PrevOpSameKey <* skipSpace <* endOfInputEx uuidFromText :: Text -> Either String UUID uuidFromText = parseUuid . BSL.fromStrict . Text.encodeUtf8 @@ -139,218 +175,305 @@ uuidFromString = uuidFromText . Text.pack -- | Parse a UUID in key position -parseUuidKey - :: UUID -- ^ same key in the previous op (default is 'UUID.zero') - -> UUID -- ^ previous key of the same op (default is 'UUID.zero') - -> ByteStringL - -> Either String UUID +parseUuidKey :: + -- | same key in the previous op (default is 'UUID.zero') + UUID -> + -- | previous key of the same op (default is 'UUID.zero') + UUID -> + ByteStringL -> + Either String UUID parseUuidKey prevKey prev = - parseOnlyL $ uuid prevKey prev PrevOpSameKey <* skipSpace <* endOfInputEx + parseOnly $ uuid prevKey prev PrevOpSameKey <* skipSpace <* endOfInputEx -- | Parse a UUID in value (atom) position -parseUuidAtom - :: UUID -- ^ previous - -> ByteStringL - -> Either String UUID -parseUuidAtom prev = parseOnlyL $ uuidAtom prev <* skipSpace <* endOfInputEx +parseUuidAtom :: + -- | previous + UUID -> + ByteStringL -> + Either String UUID +parseUuidAtom prev = parseOnly $ uuidAtom prev <* skipSpace <* endOfInputEx endOfFrame :: Parser () endOfFrame = label "end of frame" $ void $ skipSpace *> char '.' closedOp :: ClosedOp -> Parser (Bool, ClosedOp) -closedOp prev = label "ClosedOp-cont" $ do - (hasTyp, reducerId) <- key "reducer" '*' (reducerId prev) UUID.zero - (hasObj, objectId) <- key "object" '#' (objectId prev) reducerId - (hasEvt, opId) <- key "opId" '@' (opId prev') objectId - (hasRef, refId) <- key "ref" ':' (refId prev') opId - payload <- pPayload objectId - let op = Op{..} - pure - ( hasTyp || hasObj || hasEvt || hasRef || not (null payload) - , ClosedOp{..} - ) +closedOp prev = + label "ClosedOp-cont" do + (hasTyp, reducerId) <- key "reducer" '*' prev.reducerId UUID.zero + (hasObj, objectId) <- key "object" '#' prev.objectId reducerId + (hasEvt, opId) <- key "opId" '@' prev.op.opId objectId + (hasRef, refId) <- key "ref" ':' prev.op.refId opId + payload <- pPayload objectId + let op = Op{..} + pure + ( hasTyp || hasObj || hasEvt || hasRef || not (null payload) + , ClosedOp{..} + ) + +reducedOps :: UUID -> Op -> Parser [Op] +reducedOps objectId y = do + skipSpace + (isNotEmpty, packerM, x) <- reducedOpOrPack objectId y + t <- optional term + unless (t == Just TReduced || isNothing t) $ + fail "reduced op may end with `,` only" + unless (isNotEmpty || t == Just TReduced) $ fail "Empty reduced op" + let (ops, lastOp) = maybe ([x], x) (unpackOps x) packerM + cont <- reducedOps objectId lastOp <|> pure [] + pure $ ops ++ cont + +unpackOps :: Op -> Packer -> ([Op], Op) +unpackOps first packer = + case first.payload of + [AString s] -> + ( unpackLetters first.opId first.refId $ Text.unpack s + , lastOp $ fromIntegral $ Text.length s + ) + [AInteger i] -> + (unpackEmpties first.opId first.refId i, lastOp $ fromIntegral i) + _ -> undefined where - prev' = op prev + nextRef opId refId = + case packer of + PackChain -> opId + PackFixed -> refId + PackIncrement -> succValue refId -reducedOp :: UUID -> Op -> Parser (Bool, Op) -reducedOp opObject prev = label "Op-reduced-cont" $ do - (hasEvt, opId) <- key "event" '@' (opId prev) opObject - (hasRef, refId) <- key "ref" ':' (refId prev) opId - payload <- pPayload opObject - let op = Op{opId, refId, payload} - pure (hasEvt || hasRef || not (null payload), op) + lastRef size = + case packer of + PackChain -> first.opId `addValue` (size - 2) + PackFixed -> first.refId + PackIncrement -> first.refId `addValue` (size - 1) + lastOp size = + Op + { opId = first.opId `addValue` (size - 1) + , refId = lastRef size + , payload = ["CANNOT HAPPEN! TODO OpHead"] + } + + unpackLetters opId refId = \case + [] -> [] + c : cs -> + Op{opId, refId, payload = [AString $ Text.singleton c]} + : unpackLetters (succValue opId) (nextRef opId refId) cs + + unpackEmpties opId refId size + | size > 0 = + Op{opId, refId, payload = []} + : unpackEmpties (succValue opId) (nextRef opId refId) (size - 1) + | otherwise = [] + +reducedOpOrPack :: UUID -> Op -> Parser (Bool, Maybe Packer, Op) +reducedOpOrPack opObject prev = + label "Op-reduced-cont" do + (hasEvt, opId) <- key "event" '@' prev.opId opObject + (hasRef, refId) <- key "ref" ':' prev.refId opId + packerM <- optional pPacker + payload <- pPayload opObject + let op = Op{opId, refId, payload} + pure (hasEvt || hasRef || not (null payload), packerM, op) + openOp :: UUID -> Parser Op openOp prev = - label "Op-open-cont" $ do - opId <- openKey "event" '@' <|> pure (UUID.succValue prev) - refId <- openKey "ref" ':' <|> pure prev - payload <- pPayload opId - t <- term - guard $ t == TReduced || t == TClosed - pure Op{opId, refId, payload} + label "Op-open-cont" do + opId <- openKey "event" '@' <|> pure (UUID.succValue prev) + refId <- openKey "ref" ':' <|> pure prev + payload <- pPayload opId + t <- term + guard $ t == TReduced || t == TClosed + pure Op{opId, refId, payload} key :: String -> Char -> UUID -> UUID -> Parser (Bool, UUID) key name keyChar prevOpSameKey sameOpPrevUuid = - label name $ do - skipSpace - isKeyPresent <- isSuccessful $ char keyChar - if isKeyPresent then do - u <- uuid prevOpSameKey sameOpPrevUuid PrevOpSameKey - pure (True, u) - else - -- no key => use previous key - pure (False, prevOpSameKey) + label name do + skipSpace + isKeyPresent <- isSuccessful $ char keyChar + if isKeyPresent then do + u <- uuid prevOpSameKey sameOpPrevUuid PrevOpSameKey + pure (True, u) + else + -- no key => use previous key + pure (False, prevOpSameKey) openKey :: String -> Char -> Parser UUID openKey name keyChar = - label name $ do - skipSpace - _ <- char keyChar - uuid UUID.zero UUID.zero PrevOpSameKey + label name do + skipSpace + _ <- char keyChar + uuid UUID.zero UUID.zero PrevOpSameKey uuid :: UUID -> UUID -> UuidZipBase -> Parser UUID -uuid prevOpSameKey sameOpPrevUuid defaultZipBase = label "UUID" $ - uuid22 <+> uuid11 <+> uuidZip prevOpSameKey sameOpPrevUuid defaultZipBase +uuid prevOpSameKey sameOpPrevUuid defaultZipBase = + label "UUID" $ + uuid22 + <+> uuid11 + <+> uuidZip prevOpSameKey sameOpPrevUuid defaultZipBase uuid11 :: Parser UUID -uuid11 = label "UUID-RON-11-letter-value" $ do - rawX <- base64word 11 - guard $ BS.length rawX == 11 - x <- Base64.decode64 rawX ?? fail "Base64.decode64" - rawUuidVersion <- optional pUuidVersion - y <- case rawUuidVersion of - Nothing -> pure 0 - _ -> do - rawOrigin <- optional $ base64word $ maybe 11 (const 10) rawUuidVersion - origin <- case rawOrigin of - Nothing -> pure $ ls60 0 - Just origin -> Base64.decode60 origin ?? fail "Base64.decode60" - pure $ UUID.buildY b00 (fromMaybe b00 rawUuidVersion) origin - pure $ UUID x y +uuid11 = + label "UUID-RON-11-letter-value" do + rawX <- base64word 11 + guard $ BS.length rawX == 11 + x <- Base64.decode64 rawX ?? fail "Base64.decode64" + rawUuidVersionM <- optional pUuidVersion + y <- + case rawUuidVersionM of + Nothing -> pure 0 + Just rawUuidVersion -> do + rawOrigin <- optional $ base64word 10 + origin <- case rawOrigin of + Nothing -> pure $ ls60 0 + Just origin -> + Base64.decode60 origin ?? fail "Base64.decode60" + pure $ UUID.buildY b00 rawUuidVersion origin + pure $ UUID x y data UuidZipBase = PrevOpSameKey | SameOpPrevUuid uuidZip' :: Parser UUID -uuidZip' = label "UUID-zip'" $ do - rawVariety <- optional pVariety - rawValue <- base64word60 10 - rawUuidVersion <- optional pUuidVersion - rawOrigin <- case rawUuidVersion of - Just _ -> optional $ base64word60 10 - Nothing -> pure Nothing +uuidZip' = + label "UUID-zip'" do + rawVariety <- optional pVariety + rawValue <- base64word60 10 + rawUuidVersion <- optional pUuidVersion + rawOrigin <- case rawUuidVersion of + Just _ -> optional $ base64word60 10 + Nothing -> pure Nothing - pure $ UUID.build UuidFields - { uuidVariety = fromMaybe b0000 rawVariety - , uuidValue = rawValue - , uuidVariant = b00 - , uuidVersion = fromMaybe b00 rawUuidVersion - , uuidOrigin = fromMaybe (ls60 0) rawOrigin - } + pure $ + UUID.build + UuidFields + { uuidVariety = fromMaybe b0000 rawVariety + , uuidValue = rawValue + , uuidVariant = b00 + , uuidVersion = fromMaybe b00 rawUuidVersion + , uuidOrigin = fromMaybe (ls60 0) rawOrigin + } {-# DEPRECATED uuidZip "Deprecated since RON 2.1 ." #-} uuidZip :: UUID -> UUID -> UuidZipBase -> Parser UUID -uuidZip prevOpSameKey sameOpPrevUuid defaultZipBase = label "UUID-zip" $ do - changeZipBase <- isSuccessful $ char '`' - rawVariety <- optional pVariety - rawReuseValue <- optional pReuse - rawValue <- optional $ base64word60 $ 10 - fromMaybe 0 rawReuseValue - rawUuidVersion <- optional pUuidVersion - rawReuseOrigin <- optional pReuse - rawOrigin <- optional $ base64word60 $ 10 - fromMaybe 0 rawReuseOrigin +uuidZip prevOpSameKey sameOpPrevUuid defaultZipBase = + label "UUID-zip" do + changeZipBase <- isSuccessful $ char '`' + rawVariety <- optional pVariety + rawReuseValue <- optional pReuse + rawValue <- optional $ base64word60 $ 10 - (rawReuseValue ?: 0) + rawUuidVersion <- optional pUuidVersion + rawReuseOrigin <- optional pReuse + rawOrigin <- optional $ base64word60 $ 10 - (rawReuseOrigin ?: 0) - let prev = UUID.split $ whichPrev changeZipBase - let isSimple - = uuidVariant prev /= b00 - || ( not changeZipBase - && isNothing rawReuseValue && isJust rawValue - && isNothing rawReuseOrigin - && (isNothing rawUuidVersion || isJust rawOrigin) - ) + let prev = UUID.split $ whichPrev changeZipBase + let isSimple = + prev.uuidVariant /= b00 + || ( not changeZipBase + && isNothing rawReuseValue + && isJust rawValue + && isNothing rawReuseOrigin + && (isNothing rawUuidVersion || isJust rawOrigin) + ) - if isSimple then - pure $ UUID.build UuidFields - { uuidVariety = fromMaybe b0000 rawVariety - , uuidValue = fromMaybe (ls60 0) rawValue - , uuidVariant = b00 - , uuidVersion = fromMaybe b00 rawUuidVersion - , uuidOrigin = fromMaybe (ls60 0) rawOrigin - } - else do - uuidVariety <- pure $ fromMaybe (uuidVariety prev) rawVariety - uuidValue <- pure $ reuse rawReuseValue rawValue (uuidValue prev) - let uuidVariant = b00 - uuidVersion <- pure $ fromMaybe (uuidVersion prev) rawUuidVersion - uuidOrigin <- - pure $ reuse rawReuseOrigin rawOrigin (uuidOrigin prev) - pure $ UUID.build UuidFields{..} + let fields + | isSimple = + UuidFields + { uuidVariety = rawVariety ?: b0000 + , uuidValue = rawValue ?: 0 + , uuidVariant = b00 + , uuidVersion = rawUuidVersion ?: b00 + , uuidOrigin = rawOrigin ?: 0 + } + | otherwise = + UuidFields + { uuidVariety = rawVariety ?: prev.uuidVariety + , uuidValue = + reuse rawReuseValue rawValue prev.uuidValue + , uuidVariant = b00 + , uuidVersion = rawUuidVersion ?: prev.uuidVersion + , uuidOrigin = + reuse rawReuseOrigin rawOrigin prev.uuidOrigin + } + pure $ UUID.build fields where - whichPrev changeZipBase | changeZipBase = sameOpPrevUuid | otherwise = case defaultZipBase of - PrevOpSameKey -> prevOpSameKey + PrevOpSameKey -> prevOpSameKey SameOpPrevUuid -> sameOpPrevUuid - reuse :: Maybe Int -> Maybe Word60 -> Word60 -> Word60 - reuse Nothing Nothing prev = prev - reuse Nothing (Just new) _ = new - reuse (Just prefixLen) Nothing prev = - ls60 $ safeCast prev .&. complement 0 `shiftL` (60 - 6 * prefixLen) - reuse (Just prefixLen) (Just new) prev = ls60 $ prefix .|. postfix - where - prefix = safeCast prev .&. complement 0 `shiftL` (60 - 6 * prefixLen) - postfix = safeCast new `shiftR` (6 * prefixLen) - +reuse :: Maybe Int -> Maybe Word60 -> Word60 -> Word60 +reuse Nothing Nothing prev = prev +reuse Nothing (Just new) _ = new +reuse (Just prefixLen) Nothing prev = + ls60 $ safeCast prev .&. complement 0 `shiftL` (60 - 6 * prefixLen) +reuse (Just prefixLen) (Just new) prev = ls60 $ prefix .|. postfix + where + prefix = safeCast prev .&. complement 0 `shiftL` (60 - 6 * prefixLen) + postfix = safeCast new `shiftR` (6 * prefixLen) pReuse :: Parser Int -pReuse = anyChar >>= \case - '(' -> pure 4 - '[' -> pure 5 - '{' -> pure 6 - '}' -> pure 7 - ']' -> pure 8 - ')' -> pure 9 - _ -> fail "not a reuse symbol" +pReuse = + anyChar >>= \case + '(' -> pure 4 + '[' -> pure 5 + '{' -> pure 6 + '}' -> pure 7 + ']' -> pure 8 + ')' -> pure 9 + _ -> fail "not a reuse symbol" uuid22 :: Parser UUID -uuid22 = label "UUID-Base64-double-word" $ do - xy <- base64word 22 - guard $ BS.length xy == 22 - maybe (fail "Base64 decoding error") pure $ - UUID - <$> Base64.decode64 (BS.take 11 xy) - <*> Base64.decode64 (BS.drop 11 xy) +uuid22 = + label "UUID-Base64-double-word" do + xy <- base64word 22 + guard $ BS.length xy == 22 + maybe (fail "Base64 decoding error") pure $ + UUID + <$> Base64.decode64 (BS.take 11 xy) + <*> Base64.decode64 (BS.drop 11 xy) base64word :: Int -> Parser ByteString -base64word maxSize = label "Base64 word" $ do - word <- takeWhile1 Base64.isLetter - guard $ BS.length word <= maxSize - pure word +base64word maxSize = + label "Base64 word" do + word <- takeWhile1 Base64.isLetter + guard $ BS.length word <= maxSize + pure word base64word60 :: Int -> Parser Word60 -base64word60 maxSize = label "Base64 word60" $ do - word <- base64word maxSize - Base64.decode60 word ?? fail "decode60" +base64word60 maxSize = + label "Base64 word60" do + word <- base64word maxSize + Base64.decode60 word ?? fail "decode60" isUpperHexDigit :: Word8 -> Bool isUpperHexDigit c = - (fromIntegral (c - fromIntegral (ord '0')) :: Word) <= 9 || - (fromIntegral (c - fromIntegral (ord 'A')) :: Word) <= 5 + (fromIntegral (c - fromIntegral (ord '0')) :: Word) <= 9 + || (fromIntegral (c - fromIntegral (ord 'A')) :: Word) <= 5 pVariety :: Parser Word4 -pVariety = label "variety" $ do - letter <- satisfy isUpperHexDigit <* "/" - Base64.decodeLetter4 letter ?? fail "Base64.decodeLetter4" +pVariety = + label "variety" do + letter <- satisfy isUpperHexDigit <* "/" + Base64.decodeLetter4 letter ?? fail "Base64.decodeLetter4" pUuidVersion :: Parser Word2 -pUuidVersion = label "UUID-version" $ +pUuidVersion = + label "UUID-version" $ + anyChar >>= \case + '$' -> pure b00 + '%' -> pure b01 + '+' -> pure b10 + '-' -> pure b11 + _ -> fail "not a UUID-version" + +pPacker :: Parser Packer +pPacker = do + skipSpace + _ <- char '%' anyChar >>= \case - '$' -> pure b00 - '%' -> pure b01 - '+' -> pure b10 - '-' -> pure b11 - _ -> fail "not a UUID-version" + 'c' -> pure PackChain + 'f' -> pure PackFixed + 'i' -> pure PackIncrement + _ -> fail "bad packer" pPayload :: UUID -> Parser Payload pPayload = label "payload" . go @@ -359,29 +482,32 @@ ma <- optional $ atom prevUuid case ma of Nothing -> pure [] - Just a -> (a :) <$> go newUuid + Just a -> (a :) <$> go newUuid where newUuid = case a of AUuid u -> u - _ -> prevUuid + _ -> prevUuid +parsePayload :: ByteStringL -> Either String Payload +parsePayload = parseOnly $ pPayload UUID.zero <* endOfInputEx + atom :: UUID -> Parser Atom atom prevUuid = skipSpace *> atom' where atom' = - char '^' *> skipSpace *> (AFloat <$> double ) <+> - char '=' *> skipSpace *> (AInteger <$> integer) <+> - char '>' *> skipSpace *> (AUuid <$> uuid' ) <+> - (AString <$> string ) <+> - atomUnprefixed + (char '^' *> skipSpace *> (AFloat <$> double)) + <+> (char '=' *> skipSpace *> (AInteger <$> integer)) + <+> (char '>' *> skipSpace *> (AUuid <$> uuid')) + <+> (AString <$> string) + <+> atomUnprefixed integer = signed decimal - uuid' = uuidAtom prevUuid + uuid' = uuidAtom prevUuid atomUnprefixed :: Parser Atom atomUnprefixed = - (AFloat <$> definiteDouble) <+> - (AInteger <$> integer ) <+> - (AUuid <$> uuidUnzipped ) + (AFloat <$> definiteDouble) + <+> (AInteger <$> integer) + <+> (AUuid <$> uuidUnzipped) where integer = signed decimal uuidUnzipped = uuid22 <+> uuid11 <+> uuidZip' @@ -391,27 +517,28 @@ -- | Parse an atom parseAtom :: ByteStringL -> Either String Atom -parseAtom = parseOnlyL $ atom UUID.zero <* endOfInputEx +parseAtom = parseOnly $ atom UUID.zero <* endOfInputEx string :: Parser Text string = do bs <- char '\'' *> content case Json.decodeStrict $ '"' `BSC.cons` (bs `BSC.snoc` '"') of - Just s -> pure s + Just s -> pure s Nothing -> fail "bad string" where content = do - chunk <- takeWhile $ \c -> c /= '\'' && c /= '\\' + chunk <- takeWhile \c -> c /= '\'' && c /= '\\' anyChar >>= \case '\'' -> pure chunk - '\\' -> anyChar >>= \case - '\'' -> (chunk <>) . BSC.cons '\'' <$> content - c -> (chunk <>) . BSC.cons '\\' . BSC.cons c <$> content + '\\' -> + anyChar >>= \case + '\'' -> (chunk <>) . BSC.cons '\'' <$> content + c -> (chunk <>) . BSC.cons '\\' . BSC.cons c <$> content _ -> fail "cannot happen" -- | Parse a string atom parseString :: ByteStringL -> Either String Text -parseString = parseOnlyL $ string <* endOfInputEx +parseString = parseOnly $ string <* endOfInputEx -- | Return 'ClosedOp' and 'chunkIsQuery' header :: ClosedOp -> Parser (ClosedOp, Bool) @@ -420,8 +547,8 @@ t <- term case t of THeader -> pure (x, False) - TQuery -> pure (x, True) - _ -> fail "not a header" + TQuery -> pure (x, True) + _ -> fail "not a header" term :: Parser OpTerm term = do @@ -431,10 +558,11 @@ '?' -> pure TQuery ',' -> pure TReduced ';' -> pure TClosed - _ -> fail "not a term" + _ -> fail "not a term" --- | Parse a state frame --- TODO deprecate multi-object states +{- | Parse a state frame +TODO deprecate multi-object states +-} parseStateFrame :: ByteStringL -> Either String StateFrame parseStateFrame = parseWireFrame >=> findObjects @@ -442,10 +570,12 @@ parseObject :: UUID -> ByteStringL -> Either String (ObjectFrame a) parseObject oid bytes = ObjectFrame oid <$> parseStateFrame bytes --- | Extract object states from a common frame --- TODO deprecate multi-object states +{- | Extract object states from a common frame +TODO deprecate multi-object states +-} findObjects :: WireFrame -> Either String StateFrame -findObjects = fmap Map.fromList . traverse loadBody where +findObjects = fmap Map.fromList . traverse loadBody + where loadBody = \case Value WireReducedChunk{wrcHeader, wrcBody} -> do let ClosedOp{reducerId, objectId} = wrcHeader @@ -457,22 +587,22 @@ closedOpZero :: ClosedOp closedOpZero = - ClosedOp{reducerId = UUID.zero, objectId = UUID.zero, op = opZero} + ClosedOp{reducerId = UUID.zero, objectId = UUID.zero, op = opZero} opZero :: Op opZero = Op{opId = UUID.zero, refId = UUID.zero, payload = []} parseOpenFrame :: ByteStringL -> Either String [Op] parseOpenFrame = - parseOnlyL $ go UUID.zero <* skipSpace <* endOfInputEx + parseOnly $ go UUID.zero <* skipSpace <* endOfInputEx where go :: UUID -> Parser [Op] go prev = - do - op@Op{opId} <- openOp prev - (op :) <$> go opId - <|> - pure [] + ( do + op@Op{opId} <- openOp prev + (op :) <$> go opId + ) + <|> pure [] parseOpenOp :: ByteStringL -> Either String Op -parseOpenOp = parseOnlyL $ openOp UUID.zero <* skipSpace <* endOfInputEx +parseOpenOp = parseOnly $ openOp UUID.zero <* skipSpace <* endOfInputEx diff --git a/lib/RON/Text/Serialize.hs b/lib/RON/Text/Serialize.hs --- a/lib/RON/Text/Serialize.hs +++ b/lib/RON/Text/Serialize.hs @@ -1,6 +1,9 @@ {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -19,31 +22,44 @@ serializeWireFrames, uuidToString, uuidToText, - ) where +) where -import RON.Prelude hiding (elem) +import RON.Prelude hiding (elem) -import Control.Monad.State.Strict (state) -import qualified Data.Aeson as Json -import Data.ByteString.Lazy.Char8 (cons, elem, snoc) -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.Map.Strict as Map +import Control.Monad.State.Strict (state) +import Data.Aeson qualified as Json +import Data.ByteString.Lazy.Char8 (cons, elem, snoc) +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text -import RON.Text.Serialize.UUID (serializeUuid, serializeUuidAtom, - serializeUuidKey, uuidToString, - uuidToText) -import RON.Types (Atom (AFloat, AInteger, AString, AUuid), - ClosedOp (..), ObjectFrame (..), Op (..), Payload, - StateFrame, WireChunk (Closed, Query, Value), - WireFrame, WireReducedChunk (..), - WireStateChunk (..)) -import RON.UUID (UUID, zero) -import qualified RON.UUID as UUID +import RON.Text.Serialize.UUID ( + serializeUuid, + serializeUuidAtom, + serializeUuidKey, + uuidToString, + uuidToText, + ) +import RON.Types ( + Atom (AFloat, AInteger, AString, AUuid), + ClosedOp (ClosedOp), + ObjectFrame (ObjectFrame), + Op (Op), + Packer (PackChain, PackFixed, PackIncrement), + Payload, + StateFrame, + WireChunk (Closed, Query, Value), + WireFrame, + WireReducedChunk (WireReducedChunk), + WireStateChunk (WireStateChunk), + ) +import RON.Types qualified +import RON.UUID (UUID, addValue, succValue, zero) -- | Serialize a common frame serializeWireFrame :: WireFrame -> ByteStringL serializeWireFrame = - (`snoc` '.') . fold . (`evalState` opZero) . traverse serializeChunk + (`snoc` '.') . fold . (`evalState` closedOpZero) . traverse serializeChunk -- | Serialize a sequence of common frames serializeWireFrames :: [WireFrame] -> ByteStringL @@ -52,91 +68,213 @@ -- | Serialize a common chunk serializeChunk :: WireChunk -> State ClosedOp ByteStringL serializeChunk = \case - Closed op -> (<> " ;\n") <$> serializeClosedOpZip op - Value chunk -> serializeReducedChunk False chunk - Query chunk -> serializeReducedChunk True chunk + Closed op -> (<> " ;\n") <$> serializeClosedOpZip op + Value chunk -> serializeReducedChunk False chunk + Query chunk -> serializeReducedChunk True chunk -- | Serialize a reduced chunk serializeReducedChunk :: Bool -> WireReducedChunk -> State ClosedOp ByteStringL -serializeReducedChunk isQuery WireReducedChunk {wrcHeader, wrcBody} = - BSL.unlines <$> liftA2 (:) serializeHeader serializeBody +serializeReducedChunk isQuery WireReducedChunk{wrcHeader, wrcBody} = + BSL.unlines <$> liftA2 (:) serializeHeader serializeBody where serializeHeader = do - h <- serializeClosedOpZip wrcHeader - pure $ BSL.intercalate "\t" [h, if isQuery then "?" else "!"] - serializeBody = state $ \ClosedOp {op = opBefore, ..} -> - let (body, opAfter) = - (`runState` opBefore) - $ for wrcBody - $ fmap ("\t" <>) - . serializeReducedOpZip objectId - in (body, ClosedOp {op = opAfter, ..}) + h <- serializeClosedOpZip wrcHeader + pure $ BSL.intercalate "\t" [h, if isQuery then "?" else "!"] + serializeBody = state \ClosedOp{op = opBefore, ..} -> + let (body, opAfter) = + (`runState` opBefore) $ + for (packOps wrcBody) $ + fmap ("\t" <>) . serializeReducedOpPack objectId + in (body, ClosedOp{op = opAfter, ..}) +data Pack p = Pack + { firstOpId, firstRefId, lastOpId, lastRefId :: UUID + , packedPayload :: p + } + +packOps :: [Op] -> [(Maybe Packer, Op)] +packOps = goWithoutPack + where + goWithoutPack :: [Op] -> [(Maybe Packer, Op)] + goWithoutPack = \case + [] -> [] + a@Op{payload = [AString ac]} : b@Op{payload = [AString bc]} : cont + | Text.length ac == 1 + , Text.length bc == 1 + , b.opId == succValue a.opId + , Just packer <- guessPacker a.opId a.refId b.refId -> + goWithText + packer + Pack + { firstOpId = a.opId + , firstRefId = a.refId + , lastOpId = b.opId + , lastRefId = b.refId + , packedPayload = ac <> bc + } + cont + a@Op{payload = []} : b@Op{payload = []} : cont + | b.opId == succValue a.opId + , b.refId == succValue a.refId -> + goWithIncrement_ + Pack + { firstOpId = a.opId + , firstRefId = a.refId + , lastOpId = b.opId + , lastRefId = b.refId + , packedPayload = 2 + } + cont + op : cont -> (Nothing, op) : goWithoutPack cont + + nextRef opId refId = \case + PackChain -> opId + PackFixed -> refId + PackIncrement -> succValue refId + + guessPacker lastOpId lastRefId refId + | refId == lastOpId = Just PackChain + | refId == lastRefId = Just PackFixed + | refId == succValue lastRefId = Just PackIncrement + | otherwise = Nothing + + goWithText :: Packer -> Pack Text -> [Op] -> [(Maybe Packer, Op)] + goWithText packer pack@Pack{lastOpId, lastRefId, packedPayload} = \case + Op{opId, refId, payload = [AString c]} : cont + | Text.length c == 1 + , opId == succValue lastOpId + , refId == nextRef lastOpId lastRefId packer -> + goWithText + packer + pack + { packedPayload = packedPayload <> c + , lastOpId = opId + , lastRefId = refId + } + cont + cont -> + wrap (fromIntegral . Text.length) AString packer pack + : goWithoutPack cont + + goWithIncrement_ :: Pack Int64 -> [Op] -> [(Maybe Packer, Op)] + goWithIncrement_ pack@Pack{lastOpId, lastRefId, packedPayload} = \case + Op{opId, refId, payload = []} : cont + | opId == succValue lastOpId + , refId == succValue lastRefId -> + goWithIncrement_ + pack + { packedPayload = succ packedPayload + , lastOpId = opId + , lastRefId = refId + } + cont + cont -> wrap id AInteger PackIncrement pack : goWithoutPack cont + + wrap :: + (a -> Int64) -> (a -> Atom) -> Packer -> Pack a -> (Maybe Packer, Op) + wrap getSize mkAtom packer Pack{firstOpId, firstRefId, packedPayload} = + ( guard (getSize packedPayload > 1) $> packer + , Op + { opId = firstOpId + , refId = firstRefId + , payload = [mkAtom packedPayload] + } + ) + -- | Serialize a context-free raw op serializeRawOp :: ClosedOp -> ByteStringL -serializeRawOp op = evalState (serializeClosedOpZip op) opZero +serializeRawOp op = evalState (serializeClosedOpZip op) closedOpZero -- | Serialize a raw op with compression in stream context serializeClosedOpZip :: ClosedOp -> State ClosedOp ByteStringL -serializeClosedOpZip this = state $ \prev -> - let prev' = op prev - typ = serializeUuidKey (reducerId prev) zero (reducerId this) - obj = serializeUuidKey (objectId prev) (reducerId this) (objectId this) - evt = serializeUuidKey (opId prev') (objectId this) (opId this') - ref = serializeUuidKey (refId prev') (opId this') (refId this') - payloadAtoms = serializePayloadZip (objectId this) (payload this') - in ( BSL.intercalate "\t" - $ key '*' typ - ++ key '#' obj - ++ key '@' evt - ++ key ':' ref - ++ [payloadAtoms | not $ BSL.null payloadAtoms], - this +serializeClosedOpZip this = state \prev -> + let typ = serializeUuidKey prev.reducerId zero this.reducerId + obj = serializeUuidKey prev.objectId this.reducerId this.objectId + evt = serializeUuidKey prev.op.opId this.objectId this.op.opId + ref = serializeUuidKey prev.op.refId this.op.opId this.op.refId + payloadAtoms = serializePayloadZip this.objectId this.op.payload + in ( BSL.intercalate "\t" $ + key '*' typ + ++ key '#' obj + ++ key '@' evt + ++ key ':' ref + ++ [payloadAtoms | not $ BSL.null payloadAtoms] + , this ) where - this' = op this key c u = [c `cons` u | not $ BSL.null u] -- | Serialize a reduced op with compression in stream context -serializeReducedOpZip - :: UUID -- ^ enclosing object - -> Op - -> State Op ByteStringL -serializeReducedOpZip opObject this = state $ \prev -> - let evt = serializeUuidKey (opId prev) opObject (opId this) - ref = serializeUuidKey (refId prev) (opId this) (refId this) - payloadAtoms = serializePayloadZip opObject (payload this) - keys - | BSL.null evt && BSL.null ref = ["@"] - | otherwise = key '@' evt ++ key ':' ref - op = keys ++ [payloadAtoms | not $ BSL.null payloadAtoms] - in (BSL.intercalate "\t" op, this) +serializeReducedOpPack :: + -- | enclosing object + UUID -> + (Maybe Packer, Op) -> + State Op ByteStringL +serializeReducedOpPack object (packerM, this) = + state \prev -> + let evt = serializeUuidKey prev.opId object this.opId + ref = serializeUuidKey prev.refId this.opId this.refId + payload = + serializePacker packerM + <> serializePayloadZip object this.payload + keys + | BSL.null evt && BSL.null ref = ["@"] + | otherwise = key '@' evt ++ key ':' ref + op = keys ++ [payload | not $ BSL.null payload] + in (BSL.intercalate "\t" op, lastOp) where key c u = [c `cons` u | not $ BSL.null u] + packSize = + case this.payload of + [AString s] -> fromIntegral $ Text.length s + [AInteger i] -> fromIntegral i + _ -> undefined + lastOp = + case packerM of + Nothing -> this + Just packer -> + Op + { opId = this.opId `addValue` (packSize - 1) + , refId = + case packer of + PackChain -> this.opId `addValue` (packSize - 2) + PackFixed -> this.refId + PackIncrement -> + this.refId `addValue` (packSize - 1) + , payload = [] + } +serializePacker :: Maybe Packer -> ByteStringL +serializePacker = \case + Nothing -> "" + Just PackChain -> "%c " + Just PackFixed -> "%f " + Just PackIncrement -> "%i " + serializeOp :: Op -> ByteStringL serializeOp Op{opId, refId, payload} = - BSL.intercalate "\t" - [ '@' `cons` serializeUuid opId - , ':' `cons` serializeUuid refId - , serializePayloadZip opId payload - ] + BSL.intercalate + "\t" + [ '@' `cons` serializeUuid opId + , ':' `cons` serializeUuid refId + , serializePayloadZip opId payload + ] serializeOpenOp :: - -- | Previous op id - UUID -> - -- | Current op - Op -> - ByteStringL + -- | Previous op id + UUID -> + -- | Current op + Op -> + ByteStringL serializeOpenOp prevId Op{opId, refId, payload} = - BSL.intercalate "\t" $ idS : refS : payloadS + BSL.intercalate "\t" $ idS : refS : payloadS where idS - | opId /= UUID.succValue prevId = '@' `cons` serializeUuid opId - | otherwise = "" + | opId /= succValue prevId = '@' `cons` serializeUuid opId + | otherwise = "" refS - | refId /= prevId = ':' `cons` serializeUuid refId - | otherwise = "" + | refId /= prevId = ':' `cons` serializeUuid refId + | otherwise = "" payloadS = [serializePayloadZip opId payload | not $ null payload] -- | Serialize a context-free atom @@ -146,74 +284,78 @@ -- | Serialize an atom with compression for UUID in stream context serializeAtomZip :: Atom -> State UUID ByteStringL serializeAtomZip = \case - AFloat f -> pure $ serializeFloatAtom f - AInteger i -> pure $ serializeIntegerAtom i - AString s -> pure $ serializeString s - AUuid u -> serializeUuidAtom' u + AFloat f -> pure $ serializeFloatAtom f + AInteger i -> pure $ serializeIntegerAtom i + AString s -> pure $ serializeString s + AUuid u -> serializeUuidAtom' u --- | Serialize a float atom. --- If unambiguous, i.e. contains a '.' or an 'e'/'E', the prefix '^' is skipped. +{- | Serialize a float atom. +If unambiguous, i.e. contains a '.' or an 'e'/'E', the prefix '^' is skipped. +-} serializeFloatAtom :: Double -> ByteStringL serializeFloatAtom float - | isDistinguishableFromUuid = bs - | otherwise = '^' `cons` bs + | isDistinguishableFromUuid = bs + | otherwise = '^' `cons` bs where isDistinguishableFromUuid = '.' `elem` bs || 'e' `elem` bs || 'E' `elem` bs bs = BSL.pack $ show float --- | Serialize an integer atom. --- Since integers are always unambiguous, the prefix '=' is always skipped. +{- | Serialize an integer atom. +Since integers are always unambiguous, the prefix '=' is always skipped. +-} serializeIntegerAtom :: Int64 -> ByteStringL serializeIntegerAtom = BSL.pack . show -- | Serialize a string atom serializeString :: Text -> ByteStringL serializeString = - wrapSingleQuotes . escapeApostrophe . stripDoubleQuotes . Json.encode + wrapSingleQuotes . escapeApostrophe . stripDoubleQuotes . Json.encode where wrapSingleQuotes = (`snoc` '\'') . cons '\'' stripDoubleQuotes = BSL.init . BSL.tail escapeApostrophe s - | BSL.null s2 = s1 - | otherwise = s1 <> "\\'" <> escapeApostrophe (BSL.tail s2) + | BSL.null s2 = s1 + | otherwise = s1 <> "\\'" <> escapeApostrophe (BSL.tail s2) where (s1, s2) = BSL.break (== '\'') s serializeUuidAtom' :: UUID -> State UUID ByteStringL serializeUuidAtom' u = - -- TODO(2019-08-19, cblp): Check if uuid can be unambiguously serialized and - -- if so, skip the prefix. - state $ \prev -> (cons '>' $ serializeUuidAtom prev u, u) + -- TODO(2019-08-19, cblp): Check if uuid can be unambiguously serialized and + -- if so, skip the prefix. + state \prev -> (cons '>' $ serializeUuidAtom prev u, u) -- | Serialize a payload in stream context -serializePayloadZip - :: UUID -- ^ previous UUID (default is 'zero') - -> Payload - -> ByteStringL +serializePayloadZip :: + -- | previous UUID (default is 'zero') + UUID -> + Payload -> + ByteStringL serializePayloadZip prev = - BSL.unwords . (`evalState` prev) . traverse serializeAtomZip + BSL.unwords . (`evalState` prev) . traverse serializeAtomZip -- | Serialize an abstract payload serializePayload :: Payload -> ByteStringL -serializePayload = serializePayloadZip UUID.zero +serializePayload = serializePayloadZip zero -- | Serialize a state frame serializeStateFrame :: StateFrame -> ByteStringL serializeStateFrame = serializeWireFrame . map wrapChunk . Map.assocs where - wrapChunk (objectId, WireStateChunk {stateType, stateBody}) = - Value WireReducedChunk - { wrcHeader = opZero {reducerId = stateType, objectId}, - wrcBody = stateBody - } + wrapChunk (objectId, WireStateChunk{stateType, stateBody}) = + Value + WireReducedChunk + { wrcHeader = + ClosedOp{reducerId = stateType, objectId, op = opZero} + , wrcBody = stateBody + } -- | Serialize an object. Return object id that must be stored separately. serializeObject :: ObjectFrame a -> (UUID, ByteStringL) serializeObject (ObjectFrame oid frame) = (oid, serializeStateFrame frame) -opZero :: ClosedOp -opZero = ClosedOp - { reducerId = zero - , objectId = zero - , op = Op{opId = zero, refId = zero, payload = []} - } +closedOpZero :: ClosedOp +closedOpZero = ClosedOp{reducerId = zero, objectId = zero, op = opZero} + +opZero :: Op +opZero = Op{opId = zero, refId = zero, payload = []} diff --git a/lib/RON/Text/Serialize/Experimental.hs b/lib/RON/Text/Serialize/Experimental.hs --- a/lib/RON/Text/Serialize/Experimental.hs +++ b/lib/RON/Text/Serialize/Experimental.hs @@ -1,17 +1,19 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} module RON.Text.Serialize.Experimental (serializeOpenFrame) where -import RON.Prelude +import RON.Prelude -import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.ByteString.Lazy.Char8 qualified as BSLC -import RON.Text.Serialize (serializeOpenOp) -import RON.Types (Op (opId), OpenFrame) -import qualified RON.UUID as UUID +import RON.Text.Serialize (serializeOpenOp) +import RON.Types (Op (opId), OpenFrame) +import RON.UUID qualified as UUID serializeOpenFrame :: OpenFrame -> ByteStringL serializeOpenFrame ops = - BSLC.intercalate ",\n" opsSerialized <> ";\n" + BSLC.intercalate ",\n" opsSerialized <> ";\n" where - opsSerialized = zipWith serializeOpenOp (UUID.zero : map opId ops) ops + opsSerialized = zipWith serializeOpenOp (UUID.zero : map (.opId) ops) ops diff --git a/lib/RON/Text/Serialize/UUID.hs b/lib/RON/Text/Serialize/UUID.hs --- a/lib/RON/Text/Serialize/UUID.hs +++ b/lib/RON/Text/Serialize/UUID.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -13,28 +15,36 @@ uuidToText, ) where -import RON.Prelude +import RON.Prelude -import Data.Bits (countLeadingZeros, shiftL, xor) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy.Char8 as BSLC -import Data.Foldable (minimumBy) -import qualified Data.Text as Text +import Data.Bits (countLeadingZeros, shiftL, xor) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BSC +import Data.ByteString.Lazy qualified as BSL +import Data.ByteString.Lazy.Char8 qualified as BSLC +import Data.Foldable (minimumBy) +import Data.Text qualified as Text -import qualified RON.Base64 as Base64 -import RON.Util.Word (pattern B00, pattern B0000, pattern B01, - pattern B10, pattern B11, Word2, Word60, ls60, - safeCast) -import RON.UUID (UUID (..), UuidFields (..), split, zero) +import RON.Base64 qualified as Base64 +import RON.UUID (UUID (..), UuidFields (..), split, zero) +import RON.Util.Word ( + Word2, + Word60, + ls60, + safeCast, + pattern B00, + pattern B0000, + pattern B01, + pattern B10, + pattern B11, + ) -- | Serialize UUID without context (used for test) serializeUuid :: UUID -> ByteStringL serializeUuid this = BSL.fromStrict $ case uuidVariant of B00 -> unzipped thisFields - _ -> serializeUuidGeneric this + _ -> serializeUuidGeneric this where thisFields@UuidFields{..} = split this @@ -45,31 +55,41 @@ uuidToText = Text.pack . uuidToString -- | Serialize UUID in op key context -serializeUuidKey - :: UUID -- ^ same key in the previous op (default is 'zero') - -> UUID -- ^ previous key of the same op (default is 'zero') - -> UUID -- ^ this - -> ByteStringL +serializeUuidKey :: + -- | same key in the previous op (default is 'zero') + UUID -> + -- | previous key of the same op (default is 'zero') + UUID -> + -- | this + UUID -> + ByteStringL serializeUuidKey prevKey prev this = - BSL.fromStrict $ case uuidVariant thisFields of - B00 -> minimumByLength $ + BSL.fromStrict $ case thisFields.uuidVariant of + B00 -> + minimumByLength $ unzipped thisFields - : zipIfDefaultVariant prevKey this - ++ ["`" <> z | prev /= zero, z <- zipIfDefaultVariant prev this] + : zipIfDefaultVariant prevKey this + ++ [ "`" <> z + | prev /= zero + , z <- zipIfDefaultVariant prev this + ] _ -> serializeUuidGeneric this where thisFields = split this -- | Serialize UUID in op value (atom) context -serializeUuidAtom - :: UUID -- ^ previous - -> UUID -- ^ this - -> ByteStringL +serializeUuidAtom :: + -- | previous + UUID -> + -- | this + UUID -> + ByteStringL serializeUuidAtom prev this = - BSL.fromStrict $ case uuidVariant thisFields of - B00 -> minimumByLength $ + BSL.fromStrict $ case thisFields.uuidVariant of + B00 -> + minimumByLength $ unzipped thisFields - : (guard (prev /= zero) *> zipIfDefaultVariant prev this) + : (guard (prev /= zero) *> zipIfDefaultVariant prev this) _ -> serializeUuidGeneric this where thisFields = split this @@ -77,7 +97,7 @@ zipIfDefaultVariant :: UUID -> UUID -> [ByteString] zipIfDefaultVariant prev this = [ z - | uuidVariant (split prev) == B00 + | (split prev).uuidVariant == B00 , Just z <- [zipUuid (split prev) (split this)] ] @@ -86,33 +106,33 @@ where variety = case uuidVariety of B0000 -> "" - _ -> BS.singleton (Base64.encodeLetter4 uuidVariety) <> "/" + _ -> BS.singleton (Base64.encodeLetter4 uuidVariety) <> "/" x' = variety <> Base64.encode60short uuidValue y' = case (uuidVersion, uuidOrigin) of (B00, safeCast -> 0 :: Word64) -> "" _ -> serializeVersion uuidVersion - `BSC.cons` Base64.encode60short uuidOrigin + `BSC.cons` Base64.encode60short uuidOrigin zipUuid :: UuidFields -> UuidFields -> Maybe ByteString zipUuid prev this - | prev == this = Just "" + | prev == this = Just "" | canReuseValue = valueZip - | otherwise = Nothing + | otherwise = Nothing where - canReuseValue = prev{uuidValue = uuidValue this} == this - valueZip = zipPrefix (uuidValue prev) (uuidValue this) + canReuseValue = prev{uuidValue = this.uuidValue} == this + valueZip = zipPrefix prev.uuidValue this.uuidValue zipPrefix :: Word60 -> Word60 -> Maybe ByteString zipPrefix prev this | commonBits >= 6 * 10 = pure "" - | commonBits >= 6 * 9 = ok ')' 9 - | commonBits >= 6 * 8 = ok ']' 8 - | commonBits >= 6 * 7 = ok '}' 7 - | commonBits >= 6 * 6 = ok '{' 6 - | commonBits >= 6 * 5 = ok '[' 5 - | commonBits >= 6 * 4 = ok '(' 4 - | otherwise = Nothing + | commonBits >= 6 * 9 = ok ')' 9 + | commonBits >= 6 * 8 = ok ']' 8 + | commonBits >= 6 * 7 = ok '}' 7 + | commonBits >= 6 * 6 = ok '{' 6 + | commonBits >= 6 * 5 = ok '[' 5 + | commonBits >= 6 * 4 = ok '(' 4 + | otherwise = Nothing where ok c n = pure $ BSC.cons c $ encode60short' $ safeCast this `shiftL` (6 * n) commonBits = @@ -132,5 +152,5 @@ serializeUuidGeneric (UUID x y) = Base64.encode64 x <> Base64.encode64 y -- | XXX Partial for lists! -minimumByLength :: Foldable f => f ByteString -> ByteString +minimumByLength :: (Foldable f) => f ByteString -> ByteString minimumByLength = minimumBy $ comparing BS.length diff --git a/lib/RON/Types.hs b/lib/RON/Types.hs --- a/lib/RON/Types.hs +++ b/lib/RON/Types.hs @@ -4,21 +4,24 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | RON model types -module RON.Types - ( Atom (..), +module RON.Types ( + Atom (..), ClosedOp (..), ObjectRef (..), ObjectFrame (..), Op (..), OpenFrame, OpTerm (..), + Packer (..), Payload, StateChunk (..), StateFrame, @@ -38,127 +41,130 @@ pattern DeleteP, pattern RegularP, pattern UndeleteP, - ) +) where -import RON.Prelude +import RON.Prelude -import Data.String (IsString, fromString) -import Data.Typeable (typeRep) -import Text.Show (showParen, showString, showsPrec) -import qualified Text.Show +import Data.String (IsString, fromString) +import Data.Typeable (typeRep) +import Text.Show (showParen, showString, showsPrec) +import Text.Show qualified -import RON.Util.Word (pattern B00, pattern B10, pattern B11, Word2) -import RON.UUID (UUID (UUID), uuidVersion) -import qualified RON.UUID as UUID +import RON.UUID (UUID (UUID)) +import RON.UUID qualified as UUID +import RON.Util.Word (Word2, pattern B00, pattern B10, pattern B11) -- | Atom — a payload element data Atom = AFloat Double | AInteger Int64 | AString Text | AUuid UUID - deriving (Data, Eq, Generic, Hashable, Show) + deriving (Data, Eq, Generic, Hashable, Show) instance IsString Atom where - fromString = AString . fromString + fromString = AString . fromString -- | Closed op -data ClosedOp = ClosedOp { - -- | type - reducerId :: UUID, - -- | object id - objectId :: UUID, - -- | other keys and payload, that are common with reduced op - op :: Op - } - deriving (Data, Eq, Generic) +data ClosedOp = ClosedOp + { reducerId :: UUID + -- ^ type + , objectId :: UUID + -- ^ object id + , op :: Op + -- ^ other keys and payload, that are common with reduced op + } + deriving (Data, Eq, Generic) type Payload = [Atom] -- | Open op (operation) data Op = Op - { opId :: UUID + { opId :: UUID -- ^ event id (usually timestamp) - , refId :: UUID + , refId :: UUID -- ^ reference to other op; actual semantics depends on the type - , payload :: Payload - } - deriving (Data, Eq, Generic, Hashable, Show) + , payload :: Payload + } + deriving (Data, Eq, Generic, Hashable, Show) instance Show ClosedOp where - show ClosedOp {reducerId, objectId, op = Op {opId, refId, payload}} = - unwords - [ "ClosedOp", - insert '*' $ show reducerId, - insert '#' $ show objectId, - insert '@' $ show opId, - insert ':' $ show refId, - show payload - ] - where - insert k = \case - [] -> [k] - c : cs -> c : k : cs + show ClosedOp{reducerId, objectId, op = Op{opId, refId, payload}} = + unwords + [ "ClosedOp" + , insert '*' $ show reducerId + , insert '#' $ show objectId + , insert '@' $ show opId + , insert ':' $ show refId + , show payload + ] + where + insert k = \case + [] -> [k] + c : cs -> c : k : cs -- | Common reduced chunk data WireReducedChunk = WireReducedChunk - { wrcHeader :: ClosedOp - , wrcBody :: [Op] - } - deriving (Data, Eq, Generic, Show) + { wrcHeader :: ClosedOp + , wrcBody :: [Op] + } + deriving (Data, Eq, Generic, Show) -- | Common chunk data WireChunk - = Closed ClosedOp - | Value WireReducedChunk - | Query WireReducedChunk - deriving (Data, Eq, Generic, Show) + = Closed ClosedOp + | Value WireReducedChunk + | Query WireReducedChunk + deriving (Data, Eq, Generic, Show) -- | Common frame type WireFrame = [WireChunk] -- | Op terminator data OpTerm = TClosed | TReduced | THeader | TQuery - deriving (Eq, Show) + deriving (Eq, Show) -- | Reduced chunk representing an object state (i. e. high-level value) data WireStateChunk = WireStateChunk - { stateType :: UUID - , stateBody :: [Op] - } - deriving (Eq, Show) + { stateType :: UUID + , stateBody :: [Op] + } + deriving (Eq, Show) -- | Type-tagged version of 'WireStateChunk' newtype StateChunk a = StateChunk [Op] --- | Frame containing only state chunks. --- Must contain one main object and any number of other objects that are part of --- the main one. +{- | Frame containing only state chunks. +Must contain one main object and any number of other objects that are part of +the main one. +-} type StateFrame = Map UUID WireStateChunk --- | Reference to an object --- TODO hide data constructor in Internal module +{- | Reference to an object +TODO hide data constructor in Internal module +TODO deprecate in favor of 'Ref'? +-} newtype ObjectRef a = ObjectRef UUID - deriving newtype (Eq, Hashable) - deriving stock (Generic) + deriving stock (Generic) + deriving newtype (Eq, Hashable, Ord) -instance Typeable a => Show (ObjectRef a) where - showsPrec a (ObjectRef b) = - showParen (a >= 11) $ - showString "ObjectRef @" - . showsPrec 11 (typeRep $ Proxy @a) - . showString " " - . showsPrec 11 b +instance (Typeable a) => Show (ObjectRef a) where + showsPrec a (ObjectRef b) = + showParen (a >= 11) $ + showString "ObjectRef @" + . showsPrec 11 (typeRep $ Proxy @a) + . showString " " + . showsPrec 11 b -- | Object reference accompanied with a frame data ObjectFrame a = ObjectFrame {uuid :: UUID, frame :: StateFrame} - deriving (Eq, Show) + deriving (Eq, Show) data OpPattern - = Regular - | Delete - | Undelete - | Create - | Ack - | Annotation - | AnnotationDerived + = Regular + | Delete + | Undelete + | Create + | Ack + | Annotation + | AnnotationDerived pattern AnnotationP :: (Word2, Word2) pattern AnnotationP = (B00, B10) @@ -182,18 +188,26 @@ pattern UndeleteP = (B11, B11) opPattern :: Op -> Maybe OpPattern -opPattern Op {opId, refId} = - case mapBoth (uuidVersion . UUID.split) (opId, refId) of - AnnotationP -> Just Annotation - AnnotationDerivedP -> Just AnnotationDerived - CreateP -> Just Create - RegularP -> Just Regular - AckP -> Just Ack - DeleteP -> Just Delete - UndeleteP -> Just Undelete - _ -> Nothing +opPattern Op{opId, refId} = + case mapBoth ((.uuidVersion) . UUID.split) (opId, refId) of + AnnotationP -> Just Annotation + AnnotationDerivedP -> Just AnnotationDerived + CreateP -> Just Create + RegularP -> Just Regular + AckP -> Just Ack + DeleteP -> Just Delete + UndeleteP -> Just Undelete + _ -> Nothing mapBoth :: (a -> b) -> (a, a) -> (b, b) mapBoth f (x, y) = (f x, f y) type OpenFrame = [Op] + +data Packer + = -- | op = prev.op + 1, ref = prev.op + PackChain + | -- | op = prev.op + 1, ref = prev.ref + PackFixed + | -- | op = prev.op + 1, ref = prev.ref + 1 + PackIncrement diff --git a/lib/RON/Types/Experimental.hs b/lib/RON/Types/Experimental.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Types/Experimental.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module RON.Types.Experimental (Patch (..), Ref (..)) where + +import RON.Prelude + +import Data.Typeable (typeRep) +import Text.Show (showParen, showString, showsPrec) + +import RON.Types (Atom, Op, UUID) + +{- | References to a RON object or a subobject +TODO hide data constructor in Internal module +-} +data Ref a = Ref {object :: UUID, path :: [Atom]} + +instance (Typeable a) => Show (Ref a) where + showsPrec a Ref{object, path} = + showParen (a >= 11) $ + showString "Ref @" + . showsPrec 11 (typeRep $ Proxy @a) + . showString " " + . showsPrec 11 object + . showString " " + . showsPrec 11 path + +data Patch = Patch + { object :: UUID + , log :: NonEmpty Op + } + deriving (Show) diff --git a/lib/RON/UUID.hs b/lib/RON/UUID.hs --- a/lib/RON/UUID.hs +++ b/lib/RON/UUID.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} @@ -16,35 +19,55 @@ buildY, split, succValue, + addValue, zero, pattern Zero, + + -- * Fields as lenses + variety, + value, + variant, + version, + origin, + -- * Name getName, liftName, mkName, mkScopedName, + -- * Base32 encoding, suitable for file names decodeBase32, encodeBase32, ) where -import RON.Prelude +import RON.Prelude -import Data.Bits (shiftL, shiftR, (.|.)) -import qualified Data.ByteString.Char8 as BSC -import Language.Haskell.TH.Syntax (Exp, Q, liftData) -import qualified Text.Show +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.ByteString.Char8 qualified as BSC +import Language.Haskell.TH.Syntax (Exp, Q, liftData) +import Text.Show qualified -import qualified RON.Base64 as Base64 -import RON.Util.Word (pattern B00, pattern B0000, pattern B01, - pattern B10, pattern B11, Word2, Word4, Word60, - leastSignificant2, leastSignificant4, - leastSignificant60, safeCast) +import RON.Base64 qualified as Base64 +import RON.Util.Word ( + Word2, + Word4, + Word60, + leastSignificant2, + leastSignificant4, + leastSignificant60, + safeCast, + pattern B00, + pattern B0000, + pattern B01, + pattern B10, + pattern B11, + ) --- | Universally unique identifier of anything -data UUID = UUID - {-# UNPACK #-} !Word64 - {-# UNPACK #-} !Word64 +{- | Universally unique identifier of anything, +as documented in https://github.com/gritzko/ron/blob/master/uuid.md +-} +data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 deriving (Data, Eq, Generic, Hashable, Ord) -- | RON-Text-encoding @@ -58,17 +81,17 @@ UuidFields{..} = split this serialized = case uuidVariant of B00 -> unzipped - _ -> generic + _ -> generic unzipped = x' <> y' - variety = case uuidVariety of + variety' = case uuidVariety of B0000 -> "" - _ -> chr (fromIntegral $ Base64.encodeLetter4 uuidVariety) : "/" - x' = variety <> BSC.unpack (Base64.encode60short uuidValue) + _ -> chr (fromIntegral $ Base64.encodeLetter4 uuidVariety) : "/" + x' = variety' <> BSC.unpack (Base64.encode60short uuidValue) y' = case (uuidVersion, uuidOrigin) of (B00, safeCast -> 0 :: Word64) -> "" - _ -> version : BSC.unpack (Base64.encode60short uuidOrigin) + _ -> version' : BSC.unpack (Base64.encode60short uuidOrigin) generic = BSC.unpack $ Base64.encode64 x <> Base64.encode64 y - version = case uuidVersion of + version' = case uuidVersion of B00 -> '$' B01 -> '%' B10 -> '+' @@ -77,28 +100,30 @@ -- | UUID split in parts data UuidFields = UuidFields { uuidVariety :: !Word4 - , uuidValue :: !Word60 + , uuidValue :: !Word60 , uuidVariant :: !Word2 , uuidVersion :: !Word2 - , uuidOrigin :: !Word60 + , uuidOrigin :: !Word60 } deriving (Eq, Show) -- | Split UUID into parts split :: UUID -> UuidFields -split (UUID x y) = UuidFields - { uuidVariety = leastSignificant4 $ x `shiftR` 60 - , uuidValue = leastSignificant60 x - , uuidVariant = leastSignificant2 $ y `shiftR` 62 - , uuidVersion = leastSignificant2 $ y `shiftR` 60 - , uuidOrigin = leastSignificant60 y - } +split (UUID x y) = + UuidFields + { uuidVariety = leastSignificant4 $ x `shiftR` 60 + , uuidValue = leastSignificant60 x + , uuidVariant = leastSignificant2 $ y `shiftR` 62 + , uuidVersion = leastSignificant2 $ y `shiftR` 60 + , uuidOrigin = leastSignificant60 y + } -- | Build UUID from parts build :: UuidFields -> UUID -build UuidFields{..} = UUID - (buildX uuidVariety uuidValue) - (buildY uuidVariant uuidVersion uuidOrigin) +build UuidFields{..} = + UUID + (buildX uuidVariety uuidValue) + (buildY uuidVariant uuidVersion uuidOrigin) -- | Build former 64 bits of UUID from parts buildX :: Word4 -> Word60 -> Word64 @@ -107,62 +132,76 @@ -- | Build latter 64 bits of UUID from parts buildY :: Word2 -> Word2 -> Word60 -> Word64 -buildY uuidVariant uuidVersion uuidOrigin - = (safeCast uuidVariant `shiftL` 62) - .|. (safeCast uuidVersion `shiftL` 60) - .|. safeCast uuidOrigin +buildY uuidVariant uuidVersion uuidOrigin = + (safeCast uuidVariant `shiftL` 62) + .|. (safeCast uuidVersion `shiftL` 60) + .|. safeCast uuidOrigin -- | Make an unscoped (unqualified) name -mkName - :: MonadFail m - => ByteString -- ^ name, max 10 Base64 letters - -> m UUID +mkName :: + (MonadFail m) => + -- | name, max 10 Base64 letters + ByteString -> + m UUID mkName nam = mkScopedName nam "" -- | Contruct a UUID name in compile-time liftName :: ByteString -> Q Exp liftName = mkName >=> liftData + -- TODO(2019-01-11, cblp) typed splice -- | Make a scoped (qualified) name -mkScopedName - :: MonadFail m - => ByteString -- ^ scope, max 10 Base64 letters - -> ByteString -- ^ local name, max 10 Base64 letters - -> m UUID +mkScopedName :: + (MonadFail m) => + -- | scope, max 10 Base64 letters + ByteString -> + -- | local name, max 10 Base64 letters + ByteString -> + m UUID mkScopedName scope nam = do scope' <- expectBase64x60 "UUID scope" scope $ Base64.decode60 scope - nam' <- expectBase64x60 "UUID name" nam $ Base64.decode60 nam - pure $ build UuidFields - { uuidVariety = B0000 - , uuidValue = scope' - , uuidVariant = B00 - , uuidVersion = B00 - , uuidOrigin = nam' - } + nam' <- expectBase64x60 "UUID name" nam $ Base64.decode60 nam + pure $ + build + UuidFields + { uuidVariety = B0000 + , uuidValue = scope' + , uuidVariant = B00 + , uuidVersion = B00 + , uuidOrigin = nam' + } where expectBase64x60 field input = maybe - (fail - $ field - <> ": expected a Base64-encoded 60-character string, got " - <> show input) + ( fail $ + field + <> ": expected a Base64-encoded 10-character string, got " + <> show input + ) pure -- | Convert UUID to a name -getName - :: UUID - -> Maybe (ByteString, ByteString) - -- ^ @(scope, name)@ for a scoped name; @(name, "")@ for a global name -getName uuid = case split uuid of - UuidFields{uuidVariety = B0000, uuidVariant = B00, uuidVersion = B00, ..} -> - Just (x, y) - where - x = Base64.encode60short uuidValue - y = case safeCast uuidOrigin :: Word64 of - 0 -> "" - _ -> Base64.encode60short uuidOrigin - _ -> Nothing +getName :: + UUID -> + -- | @(scope, name)@ for a scoped name; @(name, "")@ for a global name + Maybe (ByteString, ByteString) +getName uuid = + case split uuid of + UuidFields + { uuidVariety = B0000 + , uuidVariant = B00 + , uuidVersion = B00 + , uuidValue + , uuidOrigin + } -> + Just (x, y) + where + x = Base64.encode60short uuidValue + y = case safeCast uuidOrigin :: Word64 of + 0 -> "" + _ -> Base64.encode60short uuidOrigin + _ -> Nothing -- | UUID with all zero fields zero :: UUID @@ -174,15 +213,25 @@ -- | Increment field 'uuidValue' of a UUID succValue :: UUID -> UUID -succValue = build . go . split where - go u@UuidFields{uuidValue} = u - {uuidValue = if uuidValue < maxBound then succ uuidValue else uuidValue} +succValue = build . go . split + where + go u@UuidFields{uuidValue} = + u + { uuidValue = + if uuidValue < maxBound then succ uuidValue else uuidValue + } +-- | Increase field 'uuidValue' of a UUID +addValue :: UUID -> Word60 -> UUID +addValue uu v = build u{uuidValue = uuidValue + v} + where + u@UuidFields{uuidValue} = split uu + -- | Encode a UUID to a Base32 string encodeBase32 :: UUID -> FilePath encodeBase32 (UUID x y) = BSC.unpack $ - Base64.encode64base32short x <> "-" <> Base64.encode64base32short y + Base64.encode64base32short x <> "-" <> Base64.encode64base32short y -- | Decode a UUID from a Base32 string decodeBase32 :: FilePath -> Maybe UUID @@ -192,3 +241,47 @@ UUID <$> Base64.decode64base32 (BSC.pack x) <*> Base64.decode64base32 (BSC.pack y) + +variety :: Lens' UUID Word4 +variety = + lens + (\(UUID x _) -> leastSignificant4 $ x `shiftR` 60) + ( \(UUID x y) v -> + UUID (x .&. 0x0FFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 60)) y + ) + +value :: Lens' UUID Word60 +value = + lens + (\(UUID x _) -> leastSignificant60 x) + (\(UUID x y) v -> UUID (x .&. 0xF000000000000000 .|. safeCast v) y) + +variant :: Lens' UUID Word2 +variant = + lens + (\(UUID _ y) -> leastSignificant2 $ y `shiftR` 62) + ( \(UUID x y) v -> + UUID x (y .&. 0x3FFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 62)) + ) + +version :: Lens' UUID Word2 +version = + lens + (\(UUID _ y) -> leastSignificant2 $ y `shiftR` 60) + ( \(UUID x y) v -> + UUID x (y .&. 0xCFFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 60)) + ) + +origin :: Lens' UUID Word60 +origin = + lens + (\(UUID _ y) -> leastSignificant60 y) + (\(UUID x y) v -> UUID x (y .&. 0xF000000000000000 .|. safeCast v)) + +type Lens s t a b = forall f. (Functor f) => (a -> f b) -> s -> f t + +type Lens' s a = Lens s s a a + +lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b +lens sa sbt afb s = sbt s <$> afb (sa s) +{-# INLINE lens #-} diff --git a/lib/RON/UUID/Experimental.hs b/lib/RON/UUID/Experimental.hs deleted file mode 100644 --- a/lib/RON/UUID/Experimental.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module RON.UUID.Experimental (variety, value, variant, version, origin) where - -import RON.Prelude - -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) - -import RON.UUID (UUID (..)) -import RON.Util.Word (Word2, Word4, Word60, leastSignificant2, - leastSignificant4, leastSignificant60, safeCast) - --- data UuidFields = UuidFields --- { uuidVariety :: !Word4 --- , uuidValue :: !Word60 --- , uuidVariant :: !Word2 --- , uuidVersion :: !Word2 --- , uuidOrigin :: !Word60 --- } - -variety :: Lens' UUID Word4 -variety = - lens - (\(UUID x _) -> leastSignificant4 $ x `shiftR` 60) - (\(UUID x y) v -> - UUID (x .&. 0x0FFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 60)) y) - -value :: Lens' UUID Word60 -value = - lens - (\(UUID x _) -> leastSignificant60 x) - (\(UUID x y) v -> UUID (x .&. 0xF000000000000000 .|. safeCast v) y) - -variant :: Lens' UUID Word2 -variant = - lens - (\(UUID _ y) -> leastSignificant2 $ y `shiftR` 62) - (\(UUID x y) v -> - UUID x (y .&. 0x3FFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 62))) - -version :: Lens' UUID Word2 -version = - lens - (\(UUID _ y) -> leastSignificant2 $ y `shiftR` 60) - (\(UUID x y) v -> - UUID x (y .&. 0xCFFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 60))) - -origin :: Lens' UUID Word60 -origin = - lens - (\(UUID _ y) -> leastSignificant60 y) - (\(UUID x y) v -> UUID x (y .&. 0xF000000000000000 .|. safeCast v)) - -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t - -type Lens' s a = Lens s s a a - -lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b -lens sa sbt afb s = sbt s <$> afb (sa s) -{-# INLINE lens #-} diff --git a/lib/RON/Util.hs b/lib/RON/Util.hs --- a/lib/RON/Util.hs +++ b/lib/RON/Util.hs @@ -5,4 +5,4 @@ Instance (Instance), ) where -data Instance c = forall a . c a => Instance a +data Instance c = forall a. (c a) => Instance a diff --git a/lib/RON/Util/Word.hs b/lib/RON/Util/Word.hs --- a/lib/RON/Util/Word.hs +++ b/lib/RON/Util/Word.hs @@ -7,50 +7,80 @@ module RON.Util.Word ( -- * Word2 Word2, - b00, b01, b10, b11, - pattern B00, pattern B01, pattern B10, pattern B11, + b00, + b01, + b10, + b11, + pattern B00, + pattern B01, + pattern B10, + pattern B11, leastSignificant2, + -- * Word4 Word4, - b0000, b0001, b0010, b0011, b0100, b0101, b0110, b0111, - b1000, b1001, b1010, b1011, b1100, b1101, b1110, b1111, + b0000, + b0001, + b0010, + b0011, + b0100, + b0101, + b0110, + b0111, + b1000, + b1001, + b1010, + b1011, + b1100, + b1101, + b1110, + b1111, pattern B0000, leastSignificant4, + -- * Word6 Word6 (..), leastSignificant6, ls6, + -- * Word8 Word8, + -- * Word12 Word12, leastSignificant12, ls12, + -- * Word16 Word16, + -- * Word24 Word24, leastSignificant24, ls24, + -- * Word32 Word32, + -- * Word60 Word60, leastSignificant60, ls60, toWord60, + -- * Word64 Word64, + -- * SafeCast SafeCast (..), ) where -import RON.Prelude +import RON.Prelude -import Data.Bits ((.&.)) -import Data.Fixed (Fixed, HasResolution) -import Data.Hashable (hashUsing, hashWithSalt) -import GHC.Num (abs, fromInteger, signum) +import Data.Bits ((.&.)) +import Data.Fixed (Fixed, HasResolution) +import Data.Hashable (hashUsing, hashWithSalt) +import GHC.Num (abs, fromInteger, signum) newtype Word2 = W2 Word8 deriving (Eq, Hashable, Ord, Show) @@ -72,7 +102,7 @@ {-# COMPLETE B00, B01, B10, B11 #-} -- | 'Word2' smart constructor dropping upper bits -leastSignificant2 :: Integral integral => integral -> Word2 +leastSignificant2 :: (Integral integral) => integral -> Word2 leastSignificant2 = W2 . (0b11 .&.) . fromIntegral newtype Word4 = W4 Word8 @@ -101,14 +131,14 @@ pattern B0000 = W4 0b0000 -- | 'Word4' smart constructor dropping upper bits -leastSignificant4 :: Integral integral => integral -> Word4 +leastSignificant4 :: (Integral integral) => integral -> Word4 leastSignificant4 = W4 . (0xF .&.) . fromIntegral newtype Word6 = W6 Word8 deriving (Eq, Ord, Show) -- | 'Word6' smart constructor dropping upper bits -leastSignificant6 :: Integral integral => integral -> Word6 +leastSignificant6 :: (Integral integral) => integral -> Word6 leastSignificant6 = W6 . (0x3F .&.) . fromIntegral -- | 'leastSignificant6' specialized for 'Word8' @@ -119,7 +149,7 @@ deriving (Eq, Ord, Show) -- | 'Word12' smart constructor dropping upper bits -leastSignificant12 :: Integral integral => integral -> Word12 +leastSignificant12 :: (Integral integral) => integral -> Word12 leastSignificant12 = W12 . (0xFFF .&.) . fromIntegral -- | 'leastSignificant12' specialized for 'Word16' @@ -130,7 +160,7 @@ deriving (Eq, Ord, Show) -- | 'Word24' smart constructor dropping upper bits -leastSignificant24 :: Integral integral => integral -> Word24 +leastSignificant24 :: (Integral integral) => integral -> Word24 leastSignificant24 = W24 . (0xFFFFFF .&.) . fromIntegral -- | 'leastSignificant24' specialized for 'Word32' @@ -156,7 +186,7 @@ hashWithSalt = hashUsing @Word64 coerce -- | 'Word60' smart constructor dropping upper bits -leastSignificant60 :: Integral integral => integral -> Word60 +leastSignificant60 :: (Integral integral) => integral -> Word60 leastSignificant60 = W60 . (0xFFFFFFFFFFFFFFF .&.) . fromIntegral -- | 'leastSignificant60' specialized for 'Word64' @@ -167,31 +197,31 @@ toWord60 :: Word64 -> Maybe Word60 toWord60 w | w < 0x1000000000000000 = Just $ W60 w - | otherwise = Nothing + | otherwise = Nothing class SafeCast v w where safeCast :: v -> w -instance SafeCast Word2 Int where safeCast = fromIntegral @Word8 . coerce -instance SafeCast Word2 Word4 where safeCast = coerce -instance SafeCast Word2 Word8 where safeCast = coerce -instance SafeCast Word2 Word64 where safeCast = fromIntegral @Word8 . coerce -instance SafeCast Word4 Int where safeCast = fromIntegral @Word8 . coerce -instance SafeCast Word4 Word64 where safeCast = fromIntegral @Word8 . coerce -instance SafeCast Word4 Word8 where safeCast = coerce -instance SafeCast Word6 Int where safeCast = fromIntegral @Word8 . coerce -instance SafeCast Word6 Word8 where safeCast = coerce -instance SafeCast Word6 Word60 where safeCast = coerce @Word64 - . fromIntegral @Word8 . coerce -instance SafeCast Word6 Word64 where safeCast = fromIntegral @Word8 . coerce -instance SafeCast Word8 Word32 where safeCast = fromIntegral -instance SafeCast Word8 Word64 where safeCast = fromIntegral -instance SafeCast Word12 Word64 where safeCast = fromIntegral @Word16 . coerce -instance SafeCast Word24 Word64 where safeCast = fromIntegral @Word32 . coerce -instance SafeCast Word24 Word32 where safeCast = coerce -instance SafeCast Word60 Word64 where safeCast = coerce +instance SafeCast Word2 Int where safeCast = fromIntegral @Word8 . coerce +instance SafeCast Word2 Word4 where safeCast = coerce +instance SafeCast Word2 Word8 where safeCast = coerce +instance SafeCast Word2 Word64 where safeCast = fromIntegral @Word8 . coerce +instance SafeCast Word4 Int where safeCast = fromIntegral @Word8 . coerce +instance SafeCast Word4 Word64 where safeCast = fromIntegral @Word8 . coerce +instance SafeCast Word4 Word8 where safeCast = coerce +instance SafeCast Word6 Int where safeCast = fromIntegral @Word8 . coerce +instance SafeCast Word6 Word8 where safeCast = coerce +instance SafeCast Word6 Word60 where + safeCast = coerce @Word64 . fromIntegral @Word8 . coerce +instance SafeCast Word6 Word64 where safeCast = fromIntegral @Word8 . coerce +instance SafeCast Word8 Word32 where safeCast = fromIntegral +instance SafeCast Word8 Word64 where safeCast = fromIntegral +instance SafeCast Word12 Word64 where safeCast = fromIntegral @Word16 . coerce +instance SafeCast Word24 Word64 where safeCast = fromIntegral @Word32 . coerce +instance SafeCast Word24 Word32 where safeCast = coerce +instance SafeCast Word60 Word64 where safeCast = coerce instance SafeCast Word64 Integer where safeCast = fromIntegral -- Fixed are Integers inside, so have arbitrary magnitude -instance HasResolution e => SafeCast Word64 (Fixed e) where +instance (HasResolution e) => SafeCast Word64 (Fixed e) where safeCast = fromIntegral diff --git a/ron.cabal b/ron.cabal --- a/ron.cabal +++ b/ron.cabal @@ -1,86 +1,88 @@ -cabal-version: 2.2 +cabal-version: 2.2 +name: ron +version: 0.13 +bug-reports: https://github.com/ff-notes/ron/issues +category: Distributed Systems, Protocol, Database +copyright: 2018-2021, 2025 Yuriy Syrovetskiy +homepage: https://github.com/ff-notes/ron +license: BSD-3-Clause +license-file: LICENSE +maintainer: Yuriy Syrovetskiy +synopsis: RON +description: + Replicated Object Notation (RON), data types (RDT), and RON-Schema + . + Examples: https://github.com/ff-notes/ron/tree/master/examples -name: ron -version: 0.12 +build-type: Simple +extra-source-files: CHANGELOG.md -bug-reports: https://github.com/ff-notes/ron/issues -category: Distributed Systems, Protocol, Database -copyright: 2018-2021 Yuriy Syrovetskiy -homepage: https://github.com/ff-notes/ron -license: BSD-3-Clause -license-file: LICENSE -maintainer: Yuriy Syrovetskiy -synopsis: RON +common language + build-depends: base >=4.10 && <4.21 + default-extensions: + NoFieldSelectors + NoImplicitPrelude + StrictData -description: - Replicated Object Notation (RON), data types (RDT), and RON-Schema - . - Examples: https://github.com/ff-notes/ron/tree/master/examples + default-language: GHC2021 -build-type: Simple +library + import: language + build-depends: + , aeson + , attoparsec + , binary + , bytestring + , containers + , hashable + , mtl + , scientific + , template-haskell + , text + , time + , unliftio + , unordered-containers + , vector -extra-source-files: - CHANGELOG.md + exposed-modules: + RON.Base64 + RON.Binary + RON.Binary.Parse + RON.Binary.Serialize + RON.Binary.Types + RON.Epoch + RON.Error + RON.Event + RON.Event.Simulation + RON.Prelude + RON.Semilattice + RON.Text + RON.Text.Parse + RON.Text.Serialize + RON.Text.Serialize.Experimental + RON.Text.Serialize.UUID + RON.Types + RON.Types.Experimental + RON.Util + RON.Util.Word + RON.UUID -common language - build-depends: base >= 4.10 && < 4.15, integer-gmp - default-extensions: NoImplicitPrelude StrictData - default-language: Haskell2010 + other-modules: + Attoparsec.Extra + Data.ZigZag -library - import: language - build-depends: - aeson, - attoparsec, - binary, - bytestring, - containers, - hashable, - mtl, - scientific, - template-haskell, - text, - time, - -- transformers >= 0.5.6.0, - -- ^ TODO Writer.CPS - unordered-containers, - vector, - exposed-modules: - RON.Base64 - RON.Binary - RON.Binary.Parse - RON.Binary.Serialize - RON.Binary.Types - RON.Epoch - RON.Error - RON.Event - RON.Event.Simulation - RON.Prelude - RON.Semilattice - RON.Text - RON.Text.Parse - RON.Text.Serialize - RON.Text.Serialize.Experimental - RON.Text.Serialize.UUID - RON.Types - RON.Util - RON.Util.Word - RON.UUID - RON.UUID.Experimental - other-modules: - Attoparsec.Extra - Data.ZigZag - -- TODO RON.Prelude.Writer - hs-source-dirs: lib + hs-source-dirs: lib benchmark bench - import: language - build-depends: - -- global - criterion, - deepseq, - -- package - ron - main-is: Main.hs - hs-source-dirs: bench - type: exitcode-stdio-1.0 + import: language + + -- global + build-depends: + , criterion + , deepseq + + -- package + build-depends: ron + main-is: Main.hs + hs-source-dirs: bench + type: exitcode-stdio-1.0