ron 0.12 → 0.13
raw patch · 27 files changed
+2175/−1410 lines, 27 filesdep +unliftiodep −integer-gmpdep ~base
Dependencies added: unliftio
Dependencies removed: integer-gmp
Dependency ranges changed: base
Files
- CHANGELOG.md +31/−1
- bench/Main.hs +19/−11
- lib/Attoparsec/Extra.hs +82/−52
- lib/Data/ZigZag.hs +12/−5
- lib/RON/Base64.hs +84/−67
- lib/RON/Binary.hs +2/−2
- lib/RON/Binary/Parse.hs +98/−73
- lib/RON/Binary/Serialize.hs +60/−48
- lib/RON/Binary/Types.hs +14/−15
- lib/RON/Epoch.hs +60/−34
- lib/RON/Error.hs +33/−34
- lib/RON/Event.hs +215/−166
- lib/RON/Event/Simulation.hs +58/−39
- lib/RON/Prelude.hs +226/−99
- lib/RON/Semilattice.hs +11/−12
- lib/RON/Text.hs +17/−6
- lib/RON/Text/Parse.hs +383/−253
- lib/RON/Text/Serialize.hs +251/−109
- lib/RON/Text/Serialize/Experimental.hs +9/−7
- lib/RON/Text/Serialize/UUID.hs +65/−45
- lib/RON/Types.hs +99/−85
- lib/RON/Types/Experimental.hs +34/−0
- lib/RON/UUID.hs +167/−74
- lib/RON/UUID/Experimental.hs +0/−60
- lib/RON/Util.hs +1/−1
- lib/RON/Util/Word.hs +65/−35
- ron.cabal +79/−77
CHANGELOG.md view
@@ -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
bench/Main.hs view
@@ -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 ]
lib/Attoparsec/Extra.hs view
@@ -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 <+>
lib/Data/ZigZag.hs view
@@ -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 #-}
lib/RON/Base64.hs view
@@ -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)
lib/RON/Binary.hs view
@@ -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)
lib/RON/Binary/Parse.hs view
@@ -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
lib/RON/Binary/Serialize.hs view
@@ -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
lib/RON/Binary/Types.hs view
@@ -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
lib/RON/Epoch.hs view
@@ -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)
lib/RON/Error.hs view
@@ -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]}
lib/RON/Event.hs view
@@ -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}
lib/RON/Event/Simulation.hs view
@@ -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
lib/RON/Prelude.hs view
@@ -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 ?:
lib/RON/Semilattice.hs view
@@ -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
lib/RON/Text.hs view
@@ -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,+ )
lib/RON/Text/Parse.hs view
@@ -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
lib/RON/Text/Serialize.hs view
@@ -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 = []}
lib/RON/Text/Serialize/Experimental.hs view
@@ -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
lib/RON/Text/Serialize/UUID.hs view
@@ -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
lib/RON/Types.hs view
@@ -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
+ lib/RON/Types/Experimental.hs view
@@ -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)
lib/RON/UUID.hs view
@@ -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 #-}
− lib/RON/UUID/Experimental.hs
@@ -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 #-}
lib/RON/Util.hs view
@@ -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
lib/RON/Util/Word.hs view
@@ -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
ron.cabal view
@@ -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 <haskell@cblp.su>+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 <haskell@cblp.su>-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