diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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) diff --git a/lib/Attoparsec/Extra.hs b/lib/Attoparsec/Extra.hs --- a/lib/Attoparsec/Extra.hs +++ b/lib/Attoparsec/Extra.hs @@ -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 diff --git a/lib/Data/ZigZag.hs b/lib/Data/ZigZag.hs --- a/lib/Data/ZigZag.hs +++ b/lib/Data/ZigZag.hs @@ -5,6 +5,8 @@ , zzDecode64 ) where +import RON.Prelude + import Data.Bits (Bits, FiniteBits, finiteBitSize, shiftL, shiftR, xor, (.&.)) diff --git a/lib/RON/Base64.hs b/lib/RON/Base64.hs --- a/lib/RON/Base64.hs +++ b/lib/RON/Base64.hs @@ -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 diff --git a/lib/RON/Binary/Parse.hs b/lib/RON/Binary/Parse.hs --- a/lib/RON/Binary/Parse.hs +++ b/lib/RON/Binary/Parse.hs @@ -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 diff --git a/lib/RON/Binary/Serialize.hs b/lib/RON/Binary/Serialize.hs --- a/lib/RON/Binary/Serialize.hs +++ b/lib/RON/Binary/Serialize.hs @@ -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, (.|.)) diff --git a/lib/RON/Binary/Types.hs b/lib/RON/Binary/Types.hs --- a/lib/RON/Binary/Types.hs +++ b/lib/RON/Binary/Types.hs @@ -3,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 diff --git a/lib/RON/Epoch.hs b/lib/RON/Epoch.hs --- a/lib/RON/Epoch.hs +++ b/lib/RON/Epoch.hs @@ -10,6 +10,8 @@ runEpochClockFromCurrentTime, ) where +import RON.Prelude + import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime) diff --git a/lib/RON/Error.hs b/lib/RON/Error.hs --- a/lib/RON/Error.hs +++ b/lib/RON/Error.hs @@ -13,6 +13,8 @@ throwErrorText, ) where +import RON.Prelude + import Data.String (IsString, fromString) data Error diff --git a/lib/RON/Event.hs b/lib/RON/Event.hs --- a/lib/RON/Event.hs +++ b/lib/RON/Event.hs @@ -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 diff --git a/lib/RON/Event/Simulation.hs b/lib/RON/Event/Simulation.hs --- a/lib/RON/Event/Simulation.hs +++ b/lib/RON/Event/Simulation.hs @@ -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 -- diff --git a/lib/RON/Prelude.hs b/lib/RON/Prelude.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Prelude.hs @@ -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 ?: diff --git a/lib/RON/Semilattice.hs b/lib/RON/Semilattice.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Semilattice.hs @@ -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) diff --git a/lib/RON/Text/Parse.hs b/lib/RON/Text/Parse.hs --- a/lib/RON/Text/Parse.hs +++ b/lib/RON/Text/Parse.hs @@ -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 diff --git a/lib/RON/Text/Serialize.hs b/lib/RON/Text/Serialize.hs --- a/lib/RON/Text/Serialize.hs +++ b/lib/RON/Text/Serialize.hs @@ -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 diff --git a/lib/RON/Text/Serialize/UUID.hs b/lib/RON/Text/Serialize/UUID.hs --- a/lib/RON/Text/Serialize/UUID.hs +++ b/lib/RON/Text/Serialize/UUID.hs @@ -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 diff --git a/lib/RON/Types.hs b/lib/RON/Types.hs --- a/lib/RON/Types.hs +++ b/lib/RON/Types.hs @@ -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 diff --git a/lib/RON/UUID.hs b/lib/RON/UUID.hs --- a/lib/RON/UUID.hs +++ b/lib/RON/UUID.hs @@ -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) diff --git a/lib/RON/Util/Word.hs b/lib/RON/Util/Word.hs --- a/lib/RON/Util/Word.hs +++ b/lib/RON/Util/Word.hs @@ -47,6 +47,8 @@ , SafeCast (..) ) where +import RON.Prelude + import Data.Bits ((.&.)) import Data.Fixed (Fixed, HasResolution) import Data.Hashable (hashUsing, hashWithSalt) diff --git a/prelude/Prelude.hs b/prelude/Prelude.hs deleted file mode 100644 --- a/prelude/Prelude.hs +++ /dev/null @@ -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 ?: diff --git a/ron.cabal b/ron.cabal --- a/ron.cabal +++ b/ron.cabal @@ -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