ron 0.6 → 0.7
raw patch · 22 files changed
+517/−225 lines, 22 filesdep +scientific
Dependencies added: scientific
Files
- CHANGELOG.md +125/−0
- bench/Main.hs +3/−0
- lib/Attoparsec/Extra.hs +37/−1
- lib/Data/ZigZag.hs +2/−0
- lib/RON/Base64.hs +2/−0
- lib/RON/Binary/Parse.hs +2/−0
- lib/RON/Binary/Serialize.hs +2/−0
- lib/RON/Binary/Types.hs +2/−0
- lib/RON/Epoch.hs +2/−0
- lib/RON/Error.hs +2/−0
- lib/RON/Event.hs +23/−4
- lib/RON/Event/Simulation.hs +6/−0
- lib/RON/Prelude.hs +156/−0
- lib/RON/Semilattice.hs +47/−0
- lib/RON/Text/Parse.hs +39/−15
- lib/RON/Text/Serialize.hs +31/−7
- lib/RON/Text/Serialize/UUID.hs +2/−0
- lib/RON/Types.hs +21/−7
- lib/RON/UUID.hs +2/−0
- lib/RON/Util/Word.hs +2/−0
- prelude/Prelude.hs +0/−164
- ron.cabal +9/−27
+ CHANGELOG.md view
@@ -0,0 +1,125 @@+# Changelog+All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0)+and this project adheres to+[Compatible Versioning](https://github.com/staltz/comver).++## [Unreleased]++## [0.7] - 2019-07-26+### Added+- Instance `ReplicaClock WriterT`.+- Instance `MonadFail ReplicaSimT`.+- Module `RON.Semilattice`:+ - Class `Semilattice`.+ - Class alias `BoundedSemilattice`.++### Changed+- Now `ObjectState` keeps a typed reference to an object with state frame+ attached,+ and `Object` is just a typed UUID --+ a typed reference to an object in a state frame passed in MonadState context.++### Removed+- `ObjectPart` as not used in RON-RDT 2.1.+- Support of space inside text UUID, as removed in RON 2.1.++## [0.6] - 2019-03-01+### Added+- `RON.Error`:+ - `liftEither`+ - `liftEitherString`++## [0.5] - 2019-02-04+### Added+- `RON.UUID.liftName` function to create name UUIDs in compile time.+- `RON.Util.ByteStringL` type.+- `RON.Error` module with unified pretty errors.+- Organize `Replicated`, `ReplicatedAsPayload`, and `ReplicatedAsObject` in+ class hierarchy.+- Add `ORSet.removeValue` and `removeRef` implementation.+- Op "patterns" and patterns.++### Removed+- Type alias `ObjectId` since objects are identified by UUID.++### Changed+- Extracted `ron-storage` package.+- Extracted `ron-schema` package.+- Extracted `ron-rdt` package.+- Switched from `Either String a` to `MonadError String m => m a` in failable+ procedures.+- `ORSet.addRef` now adds item's frame, too.+- `ORSet.addNewRef` now returns the reference to the freshly created object.+- Change `StateFrame` key to UUID since objects are identified by UUID.+- Renamed `RawOp` to `ClosedOp` according to the fresh spec.++### Fixed+- Error handling in Boole decoder.++## [0.4] - 2019-01-09+### Added+- Schema `enum` declaration.+- `docIdFromUuid`.+- `OnDocumentChanged` is called each time when any document is changed.++### Changed+- Made GHC 8.6 default.++### Removed+- Schema embedded DSL helpers: `atomInteger`, `atomString`, `boole`, `char`,+ `field`, `option`, `orSet`, `rgaString`, `structLww`, `versionVector`.++### Fixed+- `RGA.edit` bug with re-adding deleted items (#39).++## [0.3] - 2018-12-05+### Added+- Encode/decode EpochTime.+- EDN-based schema DSL.++### Removed+- `RON.Storage.createVersion` from public API.+- `NFData` instances.++## [0.2] - 2018-11-20+### Added+- Schema boole type.+- RON.Storage and submodules are moved from ff project.+- RON.Schema is now re-exported via RON.Schema.TH.++### Changed+- Renamed UUID field "schema" to "version", according to changes in the+ specification.+- RGA: sequential UUIDs on initialization.+- Optimized `Base64.isLetter`.+- Extend `UUID.mkName` to accept any monad.+- Renamed `MonadStorage` methods `list...` -> `get...`+- Renamed `RON.Storage.saveDocument` -> `createDocument`++### Removed+- `RON.Storage.uuidToFileName` as it has no sense as an abstraction+- `RON.Storage.IO.runStorageT` with `StorageT`++## [0.1] - 2018-11-08+### Added+- Package `ron`+ - RON-text format+ - RON-binary format+ - RON-RDT:+ - LWW+ - RGA+ - OR-Set+ - VersionVector+ - RON-Schema+ - RON-Schema TemplateHaskell code generator++[Unreleased]: https://github.com/ff-notes/ron/compare/v0.7...HEAD+[0.7]: https://github.com/ff-notes/ron/compare/v0.6...v0.7+[0.6]: https://github.com/ff-notes/ron/compare/v0.5...v0.6+[0.5]: https://github.com/ff-notes/ron/compare/v0.4...v0.5+[0.4]: https://github.com/ff-notes/ron/compare/v0.3...v0.4+[0.3]: https://github.com/ff-notes/ron/compare/v0.2...v0.3+[0.2]: https://github.com/ff-notes/ron/compare/v0.1...v0.2+[0.1]: https://github.com/ff-notes/ron/tree/v0.1
bench/Main.hs view
@@ -4,6 +4,9 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} +import RON.Prelude++import Control.DeepSeq (NFData, force) import Criterion (bench, nf) import Criterion.Main (defaultConfig, defaultMainWith) import Criterion.Types (timeLimit)
lib/Attoparsec/Extra.hs view
@@ -8,16 +8,21 @@ , label , parseOnlyL , takeL+ , definiteDouble , withInputSize , (??) , (<+>) ) where -import Data.Attoparsec.ByteString.Char8 (anyChar)+import RON.Prelude++import Data.Attoparsec.ByteString.Char8 (anyChar, decimal, isDigit_w8, signed) import qualified Data.Attoparsec.Internal.Types as Internal import Data.Attoparsec.Lazy as Attoparsec import qualified Data.ByteString as BS import Data.ByteString.Lazy (fromStrict, toStrict)+import qualified Data.Scientific as Sci+import GHC.Real (toInteger) import RON.Util (ByteStringL) @@ -83,6 +88,37 @@ pure c 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.+{-# 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++ let withDot = do+ i <- optional parseIntegerPart+ _ <- parseDot+ (f, l) <- parseFractionalPartWithLength+ e <- optional parseExponent+ pure $ buildDouble (fromMaybe 0 i) f l (fromMaybe 0 e)++ let withE = do+ i <- optional parseIntegerPart+ buildDouble (fromMaybe 0 i) 0 0 <$> parseExponent++ withDot <|> withE++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+ 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
lib/Data/ZigZag.hs view
@@ -5,6 +5,8 @@ , zzDecode64 ) where +import RON.Prelude+ import Data.Bits (Bits, FiniteBits, finiteBitSize, shiftL, shiftR, xor, (.&.))
lib/RON/Base64.hs view
@@ -22,6 +22,8 @@ , isLetter ) where +import RON.Prelude+ import Data.Bits (complement, shiftL, shiftR, (.&.), (.|.)) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL
lib/RON/Binary/Parse.hs view
@@ -13,6 +13,8 @@ parseString, ) where +import RON.Prelude+ import Attoparsec.Extra (Parser, anyWord8, endOfInputEx, label, parseOnlyL, takeL, withInputSize) import qualified Attoparsec.Extra as Atto
lib/RON/Binary/Serialize.hs view
@@ -11,6 +11,8 @@ serializeString, ) where +import RON.Prelude+ import qualified Data.Binary as Binary import Data.Binary.Put (putDoublebe, runPut) import Data.Bits (bit, shiftL, (.|.))
lib/RON/Binary/Types.hs view
@@ -3,6 +3,8 @@ -- | Common types for binary format (parser and serializer) module RON.Binary.Types where +import RON.Prelude+ type Size = Word32 -- | Data block descriptor
lib/RON/Epoch.hs view
@@ -10,6 +10,8 @@ runEpochClockFromCurrentTime, ) where +import RON.Prelude+ import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
lib/RON/Error.hs view
@@ -13,6 +13,8 @@ throwErrorText, ) where +import RON.Prelude+ import Data.String (IsString, fromString) data Error
lib/RON/Event.hs view
@@ -31,8 +31,11 @@ , toEpochEvent ) where +import RON.Prelude+ import Data.Bits (shiftL, shiftR, (.|.)) import Data.Hashable (hashUsing, hashWithSalt)+import Data.Time (fromGregorianValid, makeTimeOfDayValid) import RON.Util.Word (pattern B00, pattern B01, pattern B10, pattern B11, Word12, Word16, Word2, Word24,@@ -158,11 +161,21 @@ getEvents = lift . getEvents advance = lift . advance +instance ReplicaClock m => ReplicaClock (ReaderT r m) where+ getPid = lift getPid+ getEvents = lift . getEvents+ advance = lift . advance+ instance ReplicaClock m => ReplicaClock (StateT s m) where getPid = lift getPid getEvents = lift . getEvents advance = lift . advance +instance (ReplicaClock m, Monoid s) => ReplicaClock (WriterT s m) where+ getPid = lift getPid+ getEvents = lift . getEvents+ advance = lift . advance+ -- | 'advance' variant for any UUID advanceToUuid :: ReplicaClock clock => UUID -> clock () advanceToUuid = advance . uuidValue . UUID.split@@ -270,15 +283,21 @@ -> Word32 -- ^ fraction of a second in hundreds of -- nanosecond -> Maybe CalendarTime-mkCalendarDateTimeNano (y, m, d) (hh, mm, ss) ns =- -- TODO(2018-08-19, cblp, #24) validate bounds+mkCalendarDateTimeNano (y, m, d) (hh, mm, ss) hns = do+ guard $ y >= 2010+ let months = (y - 2010) * 12 + m - 1+ guard $ months < 4096+ _ <- fromGregorianValid (fromIntegral y) (fromIntegral m) (fromIntegral d)+ _ <-+ makeTimeOfDayValid (fromIntegral hh) (fromIntegral mm) (fromIntegral ss)+ guard $ hns < 10000000 pure CalendarTime- { months = ls12 $ (y - 2010) * 12 + m - 1+ { months = ls12 months , days = ls6 $ d - 1 , hours = ls6 hh , minutes = ls6 mm , seconds = ls6 ss- , nanosecHundreds = ls24 ns+ , nanosecHundreds = ls24 hns } -- | Make an 'ApplicationSpecific' replica id from arbitrary number
lib/RON/Event/Simulation.hs view
@@ -15,6 +15,9 @@ , runReplicaSimT ) where +import RON.Prelude++import Control.Monad.State.Strict (state) import qualified Data.HashMap.Strict as HM import RON.Event (EpochEvent (EpochEvent), ReplicaClock,@@ -65,6 +68,9 @@ advancePS = \case Nothing -> time Just current -> max time current++instance MonadFail m => MonadFail (ReplicaSimT m) where+ fail = lift . fail -- | Execute network simulation --
+ lib/RON/Prelude.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE LambdaCase #-}++module RON.Prelude (+ module X,+ fmapL,+ foldr1,+ headMay,+ lastDef,+ maximumDef,+ maxOn,+ minOn,+ note,+ replicateM2,+ replicateM3,+ show,+ whenJust,+ (!!),+ (?:),+) where++-- 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, 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,+ 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 Control.Monad.Writer.Strict as X (MonadWriter, WriterT,+ runWriterT, tell)+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, and, asum, fold, foldMap, foldl',+ foldr, for_, length, minimumBy, 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, 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.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.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.Show as X (Show)++--------------------------------------------------------------------------------++import qualified Data.Foldable+import Data.List (last, maximum)+import Data.String (IsString, fromString)+import qualified Text.Show++fmapL :: (a -> b) -> Either a c -> Either b c+fmapL f = either (Left . f) Right++foldr1 :: (a -> a -> a) -> NonEmpty a -> a+foldr1 = Data.Foldable.foldr1++headMay :: [a] -> Maybe a+headMay = \case+ [] -> Nothing+ a:_ -> Just a++lastDef :: a -> [a] -> a+lastDef def = list' def last++list' :: b -> ([a] -> b) -> [a] -> b+list' onEmpty onNonEmpty = \case+ [] -> onEmpty+ xs -> onNonEmpty xs++maximumDef :: Ord a => a -> [a] -> a+maximumDef def = list' def maximum++maxOn :: Ord b => (a -> b) -> a -> a -> a+maxOn f x y = if f x < f y then y else x++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 ma = (,) <$> ma <*> ma++replicateM3 :: Applicative m => m a -> m (a, a, a)+replicateM3 ma = (,,) <$> ma <*> ma <*> ma++show :: (Show a, IsString s) => a -> s+show = fromString . Text.Show.show++whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()+whenJust m f = maybe (pure ()) f m++(!!) :: [a] -> Int -> Maybe a+xs !! i+ | 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 (?:) #-}+infixr 0 ?:
+ lib/RON/Semilattice.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE ConstraintKinds #-}++module RON.Semilattice (+ Semilattice,+ BoundedSemilattice,+) where++import Data.Maybe (Maybe)+import Data.Monoid (Monoid)+import Data.Ord (Ord)+import Data.Semigroup (Max, Semigroup)+import Data.Set (Set)++{- |+A semilattice.++It may be a join-semilattice, or meet-semilattice, it doesn't matter.++If it matters for you, use package @lattices@.++In addition to 'Semigroup', Semilattice defines these laws:++[commutativity]++ @x '<>' y == y '<>' x@++[idempotency]++ @x '<>' x == x@+-}+class Semigroup a => Semilattice a++{- |+A bounded semilattice.++Bounded semilattice laws are already defined by 'Monoid' and 'Semilattice',+so we don't define an explicit class here.+-}+type BoundedSemilattice a = (Monoid a, Semilattice a)++-- instances for base types++instance Ord a => Semilattice (Max a)++instance Ord a => Semilattice (Set a)++instance Semilattice a => Semilattice (Maybe a)
lib/RON/Text/Parse.hs view
@@ -20,11 +20,11 @@ , parseWireFrames ) where -import Prelude hiding (takeWhile)+import RON.Prelude hiding (takeWhile) import Attoparsec.Extra (Parser, char, endOfInputEx, isSuccessful,- label, manyTill, parseOnlyL, satisfy, (<+>),- (??))+ label, manyTill, parseOnlyL, satisfy,+ definiteDouble, (<+>), (??)) import qualified Data.Aeson as Json import Data.Attoparsec.ByteString (takeWhile1) import Data.Attoparsec.ByteString.Char8 (anyChar, decimal, double,@@ -37,7 +37,7 @@ import qualified RON.Base64 as Base64 import RON.Types (Atom (AFloat, AInteger, AString, AUuid),- ClosedOp (..), Object (Object), Op (..),+ ClosedOp (..), ObjectState (ObjectState), Op (..), OpTerm (TClosed, THeader, TQuery, TReduced), StateChunk (..), StateFrame, UUID (UUID), WireChunk (Closed, Query, Value), WireFrame,@@ -180,15 +180,11 @@ rawX <- base64word 11 guard $ BS.length rawX == 11 x <- Base64.decode64 rawX ?? fail "Base64.decode64"- skipSpace rawUuidVersion <- optional pUuidVersion- rawOrigin <- optional $ base64word $ maybe 11 (const 10) rawUuidVersion- y <- case (rawUuidVersion, BS.length <$> rawOrigin) of- (Nothing, Just 11) ->- case rawOrigin of- Nothing -> pure 0- Just origin -> Base64.decode64 origin ?? fail "Base64.decode64"+ 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"@@ -197,13 +193,30 @@ 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++ 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- skipSpace rawUuidVersion <- optional pUuidVersion rawReuseOrigin <- optional pReuse rawOrigin <- optional $ base64word60 $ 10 - fromMaybe 0 rawReuseOrigin@@ -251,6 +264,7 @@ prefix = safeCast prev .&. complement 0 `shiftL` (60 - 6 * prefixLen) postfix = safeCast new `shiftR` (6 * prefixLen) + pReuse :: Parser Int pReuse = anyChar >>= \case '(' -> pure 4@@ -320,10 +334,20 @@ char '^' *> skipSpace *> (AFloat <$> double ) <+> char '=' *> skipSpace *> (AInteger <$> integer) <+> char '>' *> skipSpace *> (AUuid <$> uuid' ) <+>- AString <$> string+ (AString <$> string ) <+>+ atomUnprefixed integer = signed decimal uuid' = uuidAtom prevUuid +atomUnprefixed :: Parser Atom+atomUnprefixed =+ (AFloat <$> definiteDouble) <+>+ (AInteger <$> integer ) <+>+ (AUuid <$> uuidUnzipped )+ where+ integer = signed decimal+ uuidUnzipped = uuid22 <+> uuid11 <+> uuidZip'+ uuidAtom :: UUID -> Parser UUID uuidAtom prev = uuid UUID.zero prev SameOpPrevUuid @@ -376,8 +400,8 @@ parseStateFrame = parseWireFrame >=> findObjects -- | Parse a state frame as an object-parseObject :: UUID -> ByteStringL -> Either String (Object a)-parseObject oid bytes = Object oid <$> parseStateFrame bytes+parseObject :: UUID -> ByteStringL -> Either String (ObjectState a)+parseObject oid bytes = ObjectState oid <$> parseStateFrame bytes -- | Extract object states from a common frame findObjects :: WireFrame -> Either String StateFrame
lib/RON/Text/Serialize.hs view
@@ -17,15 +17,19 @@ , serializeWireFrames ) where +import RON.Prelude++import Control.Monad.State.Strict (state) import qualified Data.Aeson as Json import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC+import qualified Data.List as List import qualified Data.Map.Strict as Map import RON.Text.Serialize.UUID (serializeUuid, serializeUuidAtom, serializeUuidKey) import RON.Types (Atom (AFloat, AInteger, AString, AUuid),- ClosedOp (..), Object (..), Op (..),+ ClosedOp (..), ObjectState (..), Op (..), StateChunk (..), StateFrame, WireChunk (Closed, Query, Value), WireFrame, WireReducedChunk (..))@@ -122,12 +126,27 @@ -- | Serialize an atom with compression for UUID in stream context serializeAtomZip :: Atom -> State UUID ByteStringL serializeAtomZip = \case- AFloat f -> pure $ BSLC.cons '^' $ BSLC.pack (show f)- AInteger i -> pure $ BSLC.cons '=' $ BSLC.pack (show i)+ AFloat f -> pure $ serializeFloatAtom f+ AInteger i -> pure $ serializeIntegerAtom i AString s -> pure $ serializeString s- AUuid u ->- state $ \prev -> (BSLC.cons '>' $ serializeUuidAtom prev u, u)+ AUuid u -> serializeUuidAtom' u +-- | Serialize a float atom.+-- If unambiguous, i.e. contains a '.' or an 'e'/'E', the prefix '^' is skipped.+serializeFloatAtom :: Double -> ByteStringL+serializeFloatAtom f = let+ s = show f+ p = ('.' `List.elem` s || 'e' `List.elem` s || 'E' `List.elem` s)+ b = BSLC.pack s+ in if p then b+ else BSLC.cons '^' b++-- | Serialize an integer atom.+-- Since integers are always unambiguous, the prefix '=' is always skipped.+serializeIntegerAtom :: Int64 -> ByteStringL+serializeIntegerAtom i =+ BSLC.pack (show i)+ -- | Serialize a string atom serializeString :: Text -> ByteStringL serializeString =@@ -143,6 +162,11 @@ else s1 <> "\\'" <> escapeApostrophe (BSL.tail s2) +serializeUuidAtom' :: UUID -> State UUID ByteStringL+serializeUuidAtom' u =+ -- FIXME: Check if uuid can be unambiguously serialized and if so, skip the prefix.+ state $ \prev -> (BSLC.cons '>' $ serializeUuidAtom prev u, u)+ -- | Serialize a payload in stream context serializePayload :: UUID -- ^ previous UUID (default is 'zero')@@ -167,8 +191,8 @@ wrcBody = stateBody -- | Serialize an object. Return object id that must be stored separately.-serializeObject :: Object a -> (UUID, ByteStringL)-serializeObject (Object oid frame) = (oid, serializeStateFrame frame)+serializeObject :: ObjectState a -> (UUID, ByteStringL)+serializeObject (ObjectState oid frame) = (oid, serializeStateFrame frame) opZero :: ClosedOp opZero = ClosedOp
lib/RON/Text/Serialize/UUID.hs view
@@ -11,6 +11,8 @@ , serializeUuidKey ) where +import RON.Prelude+ import Data.Bits (countLeadingZeros, shiftL, xor) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC
lib/RON/Types.hs view
@@ -5,6 +5,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} -- | RON model types module RON.Types (@@ -18,7 +20,7 @@ Atom (..), ClosedOp (..), Object (..),- ObjectPart (..),+ ObjectState (..), Op (..), OpPattern (..), OpTerm (..),@@ -31,6 +33,10 @@ opPattern, ) where +import RON.Prelude++import Data.Typeable (typeRep)+import Text.Show (showParen, showString, showsPrec) import qualified Text.Show import RON.Util.Word (pattern B00, pattern B10, pattern B11, Word2)@@ -108,13 +114,21 @@ -- | Frame containing only state chunks type StateFrame = Map UUID StateChunk --- | Reference to an object inside a frame.-data Object a = Object{id :: UUID, frame :: StateFrame}- deriving (Eq, Show)+-- | Reference to an object+newtype Object a = Object UUID+ deriving (Eq) --- | Specific field or item in an object, identified by UUID.-data ObjectPart obj part = ObjectPart- {partObject :: UUID, partLocation :: UUID, partFrame :: StateFrame}+instance Typeable a => Show (Object a) where+ showsPrec a (Object b) =+ showParen (a >= 11)+ $ showString "Object @"+ . showsPrec 11 (typeRep $ Proxy @a)+ . showString " "+ . showsPrec 11 b++-- | Object accompanied with a frame+data ObjectState a = ObjectState{uuid :: UUID, frame :: StateFrame}+ deriving (Eq, Show) data OpPattern = Regular | Delete | Undelete | Create | Ack | Annotation | AnnotationDerived
lib/RON/UUID.hs view
@@ -28,6 +28,8 @@ , encodeBase32 ) where +import RON.Prelude+ import Data.Bits (shiftL, shiftR, (.|.)) import qualified Data.ByteString.Char8 as BSC import Language.Haskell.TH.Syntax (Exp, Q, liftData)
lib/RON/Util/Word.hs view
@@ -47,6 +47,8 @@ , SafeCast (..) ) where +import RON.Prelude+ import Data.Bits ((.&.)) import Data.Fixed (Fixed, HasResolution) import Data.Hashable (hashUsing, hashWithSalt)
− prelude/Prelude.hs
@@ -1,164 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}--module Prelude (- module X,- fmapL,- foldr1,- identity,- lastDef,- maximumDef,- maxOn,- minOn,- show,- whenJust,- (?:),-) where---- 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.Fail as X (MonadFail, fail)-import Control.Monad.IO.Class as X (MonadIO, liftIO)-import Data.Bifunctor as X (bimap)-import Data.Bool as X (Bool (False, True), not, otherwise, (&&), (||))-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, and, asum, fold, foldMap, foldl',- foldr, for_, length, minimumBy, null, or,- toList, traverse_)-import Data.Function as X (const, flip, on, ($), (.))-import Data.Functor as X (Functor, fmap, ($>), (<$), (<$>))-import Data.Functor.Identity as X (Identity)-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 (filter, genericLength, intercalate, isPrefixOf,- isSuffixOf, lookup, map, partition, repeat,- replicate, sortBy, sortOn, span, splitAt, take,- takeWhile, unlines, unwords, zip, (++))-import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty)-import Data.Maybe as X (Maybe (Just, Nothing), catMaybes, fromMaybe,- listToMaybe, 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.Ratio as X ((%))-import Data.Semigroup as X (Semigroup, sconcat, (<>))-import Data.String as X (String)-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.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.Show as X (Show)--#ifdef VERSION_bytestring-import Data.ByteString as X (ByteString)-#endif--#ifdef VERSION_containers-import Data.Map.Strict as X (Map)-#endif--#ifdef VERSION_deepseq-import Control.DeepSeq as X (NFData, force)-#endif--#ifdef VERSION_filepath-import System.FilePath as X ((</>))-#endif--#ifdef VERSION_hashable-import Data.Hashable as X (Hashable, hash)-#endif--#ifdef VERSION_mtl-import Control.Monad.Except as X (ExceptT, MonadError, catchError,- liftEither, runExceptT, throwError)-import Control.Monad.Reader as X (ReaderT (ReaderT), ask, reader,- runReaderT)-import Control.Monad.State.Strict as X (MonadState, State, StateT,- evalState, evalStateT,- execStateT, get, gets,- modify', put, runState,- runStateT, state)-import Control.Monad.Trans as X (MonadTrans, lift)-import Control.Monad.Writer.Strict as X (MonadWriter, WriterT,- runWriterT, tell)-#endif--#ifdef VERSION_text-import Data.Text as X (Text)-#endif--#ifdef VERSION_time-import Data.Time as X (UTCTime)-#endif--#ifdef VERSION_unordered_containers-import Data.HashMap.Strict as X (HashMap)-#endif------------------------------------------------------------------------------------import qualified Data.Foldable-import Data.List (last, maximum)-import Data.String (IsString, fromString)-import qualified Text.Show--fmapL :: (a -> b) -> Either a c -> Either b c-fmapL f = either (Left . f) Right--foldr1 :: (a -> a -> a) -> NonEmpty a -> a-foldr1 = Data.Foldable.foldr1--identity :: a -> a-identity x = x--lastDef :: a -> [a] -> a-lastDef def = list' def last--list' :: b -> ([a] -> b) -> [a] -> b-list' onEmpty onNonEmpty = \case- [] -> onEmpty- xs -> onNonEmpty xs--maximumDef :: Ord a => a -> [a] -> a-maximumDef def = list' def maximum--maxOn :: Ord b => (a -> b) -> a -> a -> a-maxOn f x y = if f x < f y then y else x--minOn :: Ord b => (a -> b) -> a -> a -> a-minOn f x y = if f x < f y then x else y--show :: (Show a, IsString s) => a -> s-show = fromString . Text.Show.show--whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()-whenJust m f = maybe (pure ()) f m---- | An infix form of 'fromMaybe' with arguments flipped.-(?:) :: Maybe a -> a -> a-maybeA ?: b = fromMaybe b maybeA-{-# INLINABLE (?:) #-}-infixr 0 ?:
ron.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-version: 0.6+version: 0.7 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database@@ -15,38 +15,17 @@ description: Replicated Object Notation (RON), data types (RDT), and RON-Schema .- Typical usage:- .- > import RON.Data- > import RON.Schema.TH- > import RON.Storage.IO as Storage- >- > [mkReplicated|- > (struct_lww Note- > active Boole- > text RgaString)- > |]- >- > instance Collection Note where- > collectionName = "note"- >- > main :: IO ()- > main = do- > let dataDir = "./data/"- > h <- Storage.newHandle dataDir- > runStorage h $ do- > obj <- newObject- > Note{active = True, text = "Write a task manager"}- > createDocument obj+ Examples: https://github.com/ff-notes/ron/tree/master/examples build-type: Simple +extra-source-files:+ CHANGELOG.md+ common language build-depends: base >= 4.10 && < 4.13, integer-gmp- default-extensions: MonadFailDesugaring StrictData+ default-extensions: MonadFailDesugaring NoImplicitPrelude StrictData default-language: Haskell2010- hs-source-dirs: prelude- other-modules: Prelude library import: language@@ -58,6 +37,7 @@ containers, hashable, mtl,+ scientific, template-haskell, text, time,@@ -72,6 +52,8 @@ RON.Error RON.Event RON.Event.Simulation+ RON.Prelude+ RON.Semilattice RON.Text RON.Text.Parse RON.Text.Serialize