ron 0.2 → 0.3
raw patch · 22 files changed
+638/−328 lines, 22 filesdep +hedndep +transformersdep −stringsearch
Dependencies added: hedn, transformers
Dependencies removed: stringsearch
Files
- bench/Main.hs +15/−4
- lib/RON/Base64.hs +2/−3
- lib/RON/Binary/Parse.hs +1/−1
- lib/RON/Binary/Serialize.hs +1/−1
- lib/RON/Data.hs +14/−13
- lib/RON/Data/RGA.hs +1/−1
- lib/RON/Data/Time.hs +1/−1
- lib/RON/Epoch.hs +33/−22
- lib/RON/Event.hs +7/−7
- lib/RON/Event/Simulation.hs +9/−5
- lib/RON/Internal/Word.hs +0/−193
- lib/RON/Schema.hs +48/−39
- lib/RON/Schema/EDN.hs +257/−0
- lib/RON/Schema/TH.hs +24/−10
- lib/RON/Storage.hs +0/−1
- lib/RON/Text/Parse.hs +2/−2
- lib/RON/Text/Serialize.hs +10/−3
- lib/RON/Text/Serialize/UUID.hs +3/−3
- lib/RON/Types.hs +5/−6
- lib/RON/UUID.hs +5/−7
- lib/RON/Util/Word.hs +193/−0
- ron.cabal +7/−6
bench/Main.hs view
@@ -1,16 +1,27 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# OPTIONS -Wno-orphans #-} -import RON.Internal.Prelude+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-} -import Control.DeepSeq (force)+import Control.DeepSeq (NFData, force) import Control.Exception (evaluate)+import Control.Monad (void) import Criterion (bench, nf) import Criterion.Main (defaultConfig, defaultMainWith) import Criterion.Types (timeLimit) import RON.Text (parseWireFrames, serializeWireFrames)-import RON.Types (Op (..), RawOp (..), WireChunk (Raw))+import RON.Types (Atom, Op (..), RawOp (..), UUID, WireChunk (Raw),+ WireReducedChunk) import qualified RON.UUID as UUID++deriving instance NFData Atom+deriving instance NFData Op+deriving instance NFData RawOp+deriving instance NFData UUID+deriving instance NFData WireChunk+deriving instance NFData WireReducedChunk main :: IO () main = do
lib/RON/Base64.hs view
@@ -29,9 +29,8 @@ import qualified Data.ByteString.Lazy as BSL import Data.Char (ord) -import RON.Internal.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
lib/RON/Binary/Parse.hs view
@@ -28,7 +28,7 @@ import Data.ZigZag (zzDecode64) import RON.Binary.Types (Desc (..), Size, descIsOp)-import RON.Internal.Word (safeCast)+import RON.Util.Word (safeCast) import RON.Types (Atom (AFloat, AInteger, AString, AUuid), Op (..), OpTerm (THeader, TQuery, TRaw, TReduced), RawOp (..), UUID (UUID),
lib/RON/Binary/Serialize.hs view
@@ -23,11 +23,11 @@ import Data.ZigZag (zzEncode) import RON.Binary.Types (Desc (..), Size, descIsOp)-import RON.Internal.Word (Word4, b0000, leastSignificant4, safeCast) import RON.Types (Atom (AFloat, AInteger, AString, AUuid), Op (..), RawOp (..), UUID (UUID), WireChunk (Query, Raw, Value), WireFrame, WireReducedChunk (..))+import RON.Util.Word (Word4, b0000, leastSignificant4, safeCast) -- | Serialize a frame serialize :: WireFrame -> Either String ByteStringL
lib/RON/Data.hs view
@@ -8,19 +8,20 @@ {-# LANGUAGE TypeApplications #-} -- | Typed and untyped RON tools-module RON.Data- ( Reducible (..)- , Replicated (..)- , ReplicatedAsObject (..)- , ReplicatedAsPayload (..)- , fromRon- , newRon- , objectEncoding- , payloadEncoding- , reduceObject- , reduceStateFrame- , reduceWireFrame- ) where+module RON.Data (+ Reducible (..),+ Replicated (..),+ ReplicatedAsObject (..),+ ReplicatedAsPayload (..),+ fromRon,+ mkStateChunk,+ newRon,+ objectEncoding,+ payloadEncoding,+ reduceObject,+ reduceStateFrame,+ reduceWireFrame,+) where import RON.Internal.Prelude
lib/RON/Data/RGA.hs view
@@ -37,8 +37,8 @@ import RON.Data.Internal import RON.Event (ReplicaClock, advanceToUuid, getEventUuid, getEventUuids)-import RON.Internal.Word (pattern B11, ls60) import RON.Types (Object (..), Op (..), StateChunk (..), UUID)+import RON.Util.Word (pattern B11, ls60) import RON.UUID (pattern Zero, uuidVersion) import qualified RON.UUID as UUID
lib/RON/Data/Time.hs view
@@ -28,4 +28,4 @@ -- | RON-Schema type for 'Day' day :: RonType-day = opaqueAtoms def{oaHaskellType = Just "Day"}+day = opaqueAtoms "Day" def{oaHaskellType = Just "Day"}
lib/RON/Epoch.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeApplications #-} module RON.Epoch ( EpochClock,+ decode,+ encode, getCurrentEpochTime, localEpochTimeFromUnix, runEpochClock,@@ -12,13 +13,16 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (ReaderT (ReaderT), reader, runReaderT) import Data.IORef (IORef, atomicModifyIORef', newIORef)-import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Ratio ((%))+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime,+ posixSecondsToUTCTime) import Data.Word (Word64) import RON.Event (EpochEvent (EpochEvent), EpochTime, LocalTime (TEpoch), ReplicaClock, ReplicaId, advance, getEvents, getPid)-import RON.Internal.Word (leastSignificant60, ls60, word60add)+import RON.Util.Word (leastSignificant60, ls60, safeCast, word60add) -- | Real epoch clock. -- Uses kind of global variable to ensure strict monotonicity.@@ -34,13 +38,11 @@ getEvents n0 = EpochClock $ ReaderT $ \(pid, timeVar) -> do let n = max n0 $ ls60 1 realTime <- getCurrentEpochTime- timeRangeStart <- atomicModifyIORef' timeVar $ \timeCur ->- let timeRangeStart = max realTime $ succ timeCur- in (timeRangeStart `word60add` pred n, timeRangeStart)- pure- [ EpochEvent t pid- | t <- [timeRangeStart .. timeRangeStart `word60add` pred n]- ]+ (begin, end) <- atomicModifyIORef' timeVar $ \timeCur -> let+ begin = max realTime $ succ timeCur+ end = begin `word60add` pred n+ in (end, (begin, end))+ pure [EpochEvent t pid | t <- [begin .. end]] -- | Run 'EpochClock' action with explicit time variable. runEpochClock :: ReplicaId -> IORef EpochTime -> EpochClock a -> IO a@@ -57,20 +59,29 @@ -- | Get current time in 'EpochTime' format (with 100 ns resolution). -- Monotonicity is not guaranteed. getCurrentEpochTime :: IO EpochTime-getCurrentEpochTime- = epochTimeFromUnix @Word64- . round- . (* 10000000)- <$> getPOSIXTime+getCurrentEpochTime = encode <$> getPOSIXTime -- | Convert unix time in hundreds of milliseconds to RFC 4122 time.-epochTimeFromUnix :: Integral int => int -> EpochTime-epochTimeFromUnix- = leastSignificant60- . (+ 0x01B21DD213814000)- -- the difference between Unix epoch and UUID epoch;- -- the constant is taken from RFC 4122+epochTimeFromUnix :: Word64 -> EpochTime+epochTimeFromUnix = leastSignificant60 . (+ epochDiff) +-- The difference between Unix epoch and UUID epoch;+-- the constant is taken from RFC 4122+epochDiff :: Word64+epochDiff = 0x01B21DD213814000+ -- | Convert unix time in hundreds of milliseconds to RFC 4122 time.-localEpochTimeFromUnix :: Integral int => int -> LocalTime+localEpochTimeFromUnix :: Word64 -> LocalTime localEpochTimeFromUnix = TEpoch . epochTimeFromUnix++-- | Decode date and time from UUID epoch timestamp+decode :: EpochTime -> UTCTime+decode+ = posixSecondsToUTCTime+ . realToFrac+ . (% 10000000)+ . subtract epochDiff+ . safeCast++encode :: POSIXTime -> EpochTime+encode = epochTimeFromUnix . round . (* 10000000)
lib/RON/Event.hs view
@@ -34,13 +34,13 @@ import Data.Bits (shiftL, shiftR, (.|.)) import Data.Hashable (Hashable, hashUsing, hashWithSalt) -import RON.Internal.Word (pattern B00, pattern B01, pattern B10,- pattern B11, Word12, Word16, Word2, Word24,- Word32, Word6, Word60, Word64, Word8,- leastSignificant12, leastSignificant2,- leastSignificant24, leastSignificant4,- leastSignificant6, ls12, ls24, ls6, ls60,- safeCast)+import RON.Util.Word (pattern B00, pattern B01, pattern B10,+ pattern B11, Word12, Word16, Word2, Word24,+ Word32, Word6, Word60, Word64, Word8,+ leastSignificant12, leastSignificant2,+ leastSignificant24, leastSignificant4,+ leastSignificant6, ls12, ls24, ls6, ls60,+ safeCast) import RON.UUID (UUID, UuidFields (UuidFields), uuidOrigin, uuidValue, uuidVariant, uuidVariety, uuidVersion) import qualified RON.UUID as UUID
lib/RON/Event/Simulation.hs view
@@ -23,9 +23,9 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM -import RON.Event (EpochEvent (EpochEvent), ReplicaClock, ReplicaId,- advance, getEvents, getPid)-import RON.Internal.Word (Word60, ls60, word60add)+import RON.Event (EpochEvent (EpochEvent), ReplicaClock,+ ReplicaId (ReplicaId), advance, getEvents, getPid)+import RON.Util.Word (Word60, ls60, safeCast, word60add) -- | Lamport clock simulation. Key is 'ReplicaId'. -- Non-present value is equivalent to (0, initial).@@ -53,10 +53,14 @@ rid <- ask (t0, t1) <- lift $ NetworkSim $ state $ \replicaStates -> let- t0 = HM.lookupDefault (ls60 1) rid replicaStates+ t0orig = HM.lookupDefault (ls60 0) rid replicaStates+ ReplicaId _ r = rid+ randomLeap =+ ls60 $ (safeCast t0orig + safeCast n + safeCast r) `mod` 41+ t0 = t0orig `word60add` randomLeap t1 = t0 `word60add` n in ((t0, t1), HM.insert rid t1 replicaStates)- pure [EpochEvent t rid | t <- [t0 .. t1]]+ pure [EpochEvent t rid | t <- [succ t0 .. t1]] where n = max n' (ls60 1)
− lib/RON/Internal/Word.hs
@@ -1,193 +0,0 @@-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeApplications #-}--module RON.Internal.Word- (- -- * Word2- Word2- , 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- , 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- , word60add- -- * Word64- , Word64- -- * SafeCast- , SafeCast (..)- ) where--import Data.Bits ((.&.))-import Data.Coerce (coerce)-import Data.Fixed (Fixed, HasResolution)-import Data.Hashable (Hashable, hashUsing, hashWithSalt)-import Data.Word (Word16, Word32, Word64, Word8)--newtype Word2 = W2 Word8- deriving (Eq, Ord, Show)--b00, b01, b10, b11 :: Word2-b00 = W2 0b00-b01 = W2 0b01-b10 = W2 0b10-b11 = W2 0b11--pattern B00 :: Word2-pattern B00 = W2 0b00-pattern B01 :: Word2-pattern B01 = W2 0b01-pattern B10 :: Word2-pattern B10 = W2 0b10-pattern B11 :: Word2-pattern B11 = W2 0b11-{-# COMPLETE B00, B01, B10, B11 #-}---- | 'Word2' smart constructor dropping upper bits-leastSignificant2 :: Integral integral => integral -> Word2-leastSignificant2 = W2 . (0b11 .&.) . fromIntegral--newtype Word4 = W4 Word8- deriving (Eq, Ord, Show)--b0000, b0001, b0010, b0011, b0100, b0101, b0110, b0111 :: Word4-b1000, b1001, b1010, b1011, b1100, b1101, b1110, b1111 :: Word4-b0000 = W4 0b0000-b0001 = W4 0b0001-b0010 = W4 0b0010-b0011 = W4 0b0011-b0100 = W4 0b0100-b0101 = W4 0b0101-b0110 = W4 0b0110-b0111 = W4 0b0111-b1000 = W4 0b1000-b1001 = W4 0b1001-b1010 = W4 0b1010-b1011 = W4 0b1011-b1100 = W4 0b1100-b1101 = W4 0b1101-b1110 = W4 0b1110-b1111 = W4 0b1111--pattern B0000 :: Word4-pattern B0000 = W4 0b0000---- | 'Word4' smart constructor dropping upper bits-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 = W6 . (0x3F .&.) . fromIntegral---- | 'leastSignificant6' specialized for 'Word8'-ls6 :: Word8 -> Word6-ls6 = W6 . (0x3F .&.)--newtype Word12 = W12 Word16- deriving (Eq, Ord, Show)---- | 'Word12' smart constructor dropping upper bits-leastSignificant12 :: Integral integral => integral -> Word12-leastSignificant12 = W12 . (0xFFF .&.) . fromIntegral---- | 'leastSignificant12' specialized for 'Word16'-ls12 :: Word16 -> Word12-ls12 = W12 . (0xFFF .&.)--newtype Word24 = W24 Word32- deriving (Eq, Ord, Show)---- | 'Word24' smart constructor dropping upper bits-leastSignificant24 :: Integral integral => integral -> Word24-leastSignificant24 = W24 . (0xFFFFFF .&.) . fromIntegral---- | 'leastSignificant24' specialized for 'Word32'-ls24 :: Word32 -> Word24-ls24 = W24 . (0xFFF .&.)--newtype Word60 = W60 Word64- deriving (Enum, Eq, Ord, Show)--instance Bounded Word60 where- minBound = W60 0- maxBound = W60 0xFFFFFFFFFFFFFFF--instance Hashable Word60 where- hashWithSalt = hashUsing @Word64 coerce---- | 'Word60' smart constructor dropping upper bits-leastSignificant60 :: Integral integral => integral -> Word60-leastSignificant60 = W60 . (0xFFFFFFFFFFFFFFF .&.) . fromIntegral---- | 'leastSignificant60' specialized for 'Word64'-ls60 :: Word64 -> Word60-ls60 = W60 . (0xFFFFFFFFFFFFFFF .&.)---- | 'Word60' smart constructor checking domain-toWord60 :: Word64 -> Maybe Word60-toWord60 w- | w < 0x1000000000000000 = Just $ W60 w- | otherwise = Nothing--word60add :: Word60 -> Word60 -> Word60-word60add (W60 a) (W60 b) = leastSignificant60 $ a + b--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 Word64 Integer where safeCast = fromIntegral---- Fixed are Integers inside, so have arbitrary magnitude-instance HasResolution e => SafeCast Word64 (Fixed e) where- safeCast = fromIntegral
lib/RON/Schema.hs view
@@ -2,33 +2,34 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module RON.Schema- ( Declaration (..)- , Field (..)- , FieldAnnotations (..)- , OpaqueAnnotations (..)- , RonType (..)- , Schema- , StructAnnotations (..)- , StructLww (..)- , TAtom (..)- , TComposite (..)- , TObject (..)- , TOpaque (..)- , atomInteger- , atomString- , boole- , char- , def- , field- , opaqueAtoms- , opaqueObject- , option- , orSet- , rgaString- , structLww- , versionVector- ) where+module RON.Schema (+ CaseTransform (..),+ Declaration (..),+ Field (..),+ FieldAnnotations (..),+ Opaque (..),+ OpaqueAnnotations (..),+ RonType (..),+ Schema,+ StructAnnotations (..),+ StructLww (..),+ TAtom (..),+ TComposite (..),+ TObject (..),+ atomInteger,+ atomString,+ boole,+ char,+ def,+ field,+ opaqueAtoms,+ opaqueObject,+ option,+ orSet,+ rgaString,+ structLww,+ versionVector,+) where import RON.Internal.Prelude @@ -41,7 +42,7 @@ = TAtom TAtom | TComposite TComposite | TObject TObject- | TOpaque TOpaque+ | TOpaque Opaque deriving (Show) newtype TComposite@@ -63,11 +64,16 @@ deriving (Show) data StructAnnotations = StructAnnotations- {saHaskellDeriving :: Set Text, saHaskellFieldPrefix :: Text}+ { saHaskellFieldPrefix :: Text+ , saHaskellFieldCaseTransform :: Maybe CaseTransform+ } deriving (Show) -instance Default StructAnnotations where def = StructAnnotations def ""+data CaseTransform = TitleCase+ deriving (Show) +instance Default StructAnnotations where def = StructAnnotations "" Nothing+ data Field = Field{fieldType :: RonType, fieldAnnotations :: FieldAnnotations} deriving (Show) @@ -80,7 +86,7 @@ instance Default FieldAnnotations where def = FieldAnnotations -newtype Declaration = DStructLww StructLww+data Declaration = DOpaque Opaque | DStructLww StructLww type Schema = [Declaration] @@ -88,20 +94,23 @@ deriving (Default, Show) char :: RonType-char = opaqueAtoms def{oaHaskellType = Just "Char"}+char = opaqueAtoms "Char" def{oaHaskellType = Just "Char"} rgaString :: RonType rgaString = TObject $ TRga char -data TOpaque =- Opaque{opaqueIsObject :: Bool, opaqueAnnotations :: OpaqueAnnotations}+data Opaque = Opaque+ { opaqueIsObject :: Bool+ , opaqueName :: Text+ , opaqueAnnotations :: OpaqueAnnotations+ } deriving (Show) -opaqueObject :: OpaqueAnnotations -> RonType-opaqueObject = TOpaque . Opaque True+opaqueObject :: Text -> OpaqueAnnotations -> RonType+opaqueObject name = TOpaque . Opaque True name -opaqueAtoms :: OpaqueAnnotations -> RonType-opaqueAtoms = TOpaque . Opaque False+opaqueAtoms :: Text -> OpaqueAnnotations -> RonType+opaqueAtoms name = TOpaque . Opaque False name option :: RonType -> RonType option = TComposite . TOption@@ -122,4 +131,4 @@ versionVector = TObject TVersionVector boole :: RonType-boole = opaqueAtoms def{oaHaskellType = Just "Bool"}+boole = opaqueAtoms "Boole" def{oaHaskellType = Just "Bool"}
+ lib/RON/Schema/EDN.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module RON.Schema.EDN (parseSchema) where++import RON.Internal.Prelude++import Control.Monad.State.Strict (StateT, evalStateT, get, gets, put)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Trans.Identity (runIdentityT)+import Data.Attoparsec.Lazy (Result (Done))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Char8 as BSLC+import Data.Char (isSpace)+import Data.EDN (Tagged (NoTag, Tagged), Value (List, Map, Symbol),+ (.!=), (.:?))+import Data.EDN.Encode (fromTagged)+import Data.EDN.Parser (parseBSL)+import Data.EDN.Types (EDNList, EDNMap)+import Data.EDN.Types.Class (Parser, parseEither, typeMismatch)+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Lazy as TextL+import Data.Text.Lazy.Builder (toLazyText)+import qualified Data.Text.Lazy.Encoding as TextL++import RON.Schema++newtype Env = Env {knownTypes :: Map Text RonType}+ deriving (Show)++startEnv :: Env+startEnv = Env+ { knownTypes = Map.fromList+ [ ("AtomInteger", atomInteger)+ , ("AtomString", atomString)+ , ("RgaString", rgaString)+ , ("VersionVector", versionVector)+ ]+ }++type Parser' = StateT Env Parser++parseDeclaration :: Tagged Value -> Parser' Declaration+parseDeclaration = withNoTag $ withList "declaration" $ \case+ func : args -> do+ func' <- withNoTag pure func+ withSymbol "declaration name symbol" (go args) func'+ [] -> fail "empty declaration"+ where+ go args = withNoPrefix "declaration name" $ \case+ "opaque" -> DOpaque <$> parseOpaque args+ "struct_lww" -> DStructLww <$> parseStructLww args+ name -> fail $ "unknown declaration " ++ decodeUtf8 name++parseOpaque :: EDNList -> Parser' Opaque+parseOpaque code = do+ opaque@Opaque{opaqueName} <- case code of+ kind' : name : annotations -> do+ kind <- parseKind kind'+ case kind of+ "atoms" -> go False+ "object" -> go True+ _ -> fail "opaque kind must be either atoms or object"+ where+ go isObject =+ Opaque isObject <$> parseName name <*> parseAnnotations+ parseKind =+ withNoTag $+ withSymbol "opaque kind symbol" $+ withNoPrefix "opaque kind" pure+ parseName =+ withNoTag $+ withSymbol "opaque name symbol" $+ withNoPrefix "opaque name" $+ pure . Text.decodeUtf8+ parseAnnotations = case annotations of+ [] -> pure def+ _ -> fail "opaque annotations are not implemented yet"+ _ -> fail+ "Expected declaration in the form\+ \ (opaque <kind:symbol> <name:symbol> <annotations>...)"+ env@Env{knownTypes} <- get+ case Map.lookup opaqueName knownTypes of+ Nothing ->+ put env { knownTypes =+ Map.insert opaqueName (TOpaque opaque) knownTypes+ }+ Just _ ->+ fail $ "duplicate declaration of type " ++ Text.unpack opaqueName+ pure opaque++parseStructLww :: EDNList -> Parser' StructLww+parseStructLww code = do+ struct@StructLww{structName} <- case code of+ name : body -> do+ let (annotations, fields) = span isTagged body+ StructLww+ <$> parseName name+ <*> parseFields fields+ <*> parseAnnotations annotations+ [] -> fail+ "Expected declaration in the form\+ \ (struct_lww <name:symbol> <annotations>... <fields>...)"+ env@Env{knownTypes} <- get+ case Map.lookup structName knownTypes of+ Nothing ->+ put env { knownTypes =+ Map.insert structName (structLww struct) knownTypes+ }+ Just _ ->+ fail $ "duplicate declaration of type " ++ Text.unpack structName+ pure struct++ where++ parseName =+ withNoTag $+ withSymbol "struct_lww name symbol" $+ withNoPrefix "struct_lww name" $+ pure . Text.decodeUtf8++ parseFields = \case+ [] -> pure mempty+ nameAsTagged : typeAsTagged : cont -> do+ name <- parseFieldName nameAsTagged+ typ <- parseType typeAsTagged+ Map.insert name (Field typ FieldAnnotations) <$> parseFields cont+ [f] -> fail $ "field " ++ showEdn f ++ " must have type"+ where+ parseFieldName =+ withNoTag $+ withSymbol "struct_lww field name symbol" $+ withNoPrefix "struct_lww field name" $+ pure . Text.decodeUtf8++ parseAnnotations annTaggedValues = do+ annValues <- traverse unwrapTag annTaggedValues+ case lookup "haskell" annValues of+ Nothing -> pure def+ Just annValue ->+ withMap "struct_lww haskell annotations map" go annValue+ where+ unwrapTag = \case+ Tagged value prefix tag -> let+ name | BS.null prefix = tag | otherwise = prefix <> "/" <> tag+ in pure (name, value)+ NoTag _ -> fail "annotation must be a tagged value"+ go m = lift $+ StructAnnotations+ <$> m .:? Symbol "" "field_prefix" .!= ""+ <*> (m .:? Symbol "" "field_case" >>= traverse parseCaseTransform)++parseCaseTransform :: Value -> Parser CaseTransform+parseCaseTransform =+ (runIdentityT .) $+ withSymbol "case transformation symbol" $+ withNoPrefix "case transformation" $ \case+ "title" -> pure TitleCase+ _ -> fail "unknown case transformation"++parseSchema :: Monad m => String -> m Schema+parseSchema string = either fail pure $ do+ values <- parseEdnStream $ encodeUtf8L string+ parseEither ((`evalStateT` startEnv) . traverse parseDeclaration) values++parseEdnStream :: ByteStringL -> Either String EDNList+parseEdnStream input+ | BSLC.all isSpace input = pure []+ | otherwise =+ case parseBSL input of+ Done rest value -> (value :) <$> parseEdnStream rest+ failure -> Left $ show failure++parseType :: Tagged Value -> Parser' RonType+parseType = withNoTag $ \case+ Symbol "" name ->+ gets (Map.lookup (Text.decodeUtf8 name) . knownTypes) >>= \case+ Nothing -> fail $ "unknown type " ++ decodeUtf8 name+ Just typ -> pure typ+ Symbol _ _ -> fail "types must not be prefixed"+ List expr -> evalType expr+ value -> lift $ typeMismatch "type symbol or expression" value++evalType :: EDNList -> Parser' RonType+evalType = \case+ [] -> fail "empty type expression"+ [a] -> parseType a+ func : args -> applyType func =<< traverse parseType args++applyType :: Tagged Value -> [RonType] -> Parser' RonType+applyType func args =+ withNoTag+ (withSymbol "parametric type symbol" $+ withNoPrefix "parametric type" go)+ func+ where++ go = \case+ "Option" -> apply "Option" option+ "ORSet" -> apply "ORSet" orSet+ name -> fail $ "unknown parametric type " ++ decodeUtf8 name++ apply name wrapper = case args of+ [a] -> pure $ wrapper a+ _ -> fail $ name ++ " expects 1 argument, got " ++ show (length args)++-- * Parser helpers++withNoPrefix+ :: Monad m+ => String -> (ByteString -> m a) -> ByteString -> ByteString -> m a+withNoPrefix ctx f prefix name = do+ unless (prefix == "") $ fail $ ctx ++ ": empty prefix expected"+ f name++withList :: String -> (EDNList -> Parser' a) -> Value -> Parser' a+withList expected f = \case+ List list -> f list+ value -> lift $ typeMismatch expected value++withMap :: String -> (EDNMap -> Parser' a) -> Value -> Parser' a+withMap expected f = \case+ Map m -> f m+ value -> lift $ typeMismatch expected value++withNoTag :: Monad m => (Value -> m a) -> Tagged Value -> m a+withNoTag f = \case+ NoTag value -> f value+ Tagged _ prefix tag -> fail+ $ "when expecting a non-tagged value, encountered tag "+ ++ decodeUtf8 prefix ++ "/" ++ decodeUtf8 tag ++ " instead"++withSymbol+ :: MonadTrans t+ => String -> (ByteString -> ByteString -> t Parser a) -> Value -> t Parser a+withSymbol expected f = \case+ Symbol prefix symbol -> f prefix symbol+ value -> lift $ typeMismatch expected value++-- * ByteString helpers++decodeUtf8 :: ByteString -> String+decodeUtf8 = Text.unpack . Text.decodeUtf8++encodeUtf8L :: String -> ByteStringL+encodeUtf8L = TextL.encodeUtf8 . TextL.pack++isTagged :: Tagged a -> Bool+isTagged = \case+ NoTag {} -> False+ Tagged{} -> True++showEdn :: Tagged Value -> String+showEdn = TextL.unpack . toLazyText . fromTagged
lib/RON/Schema/TH.hs view
@@ -7,6 +7,7 @@ module RON.Schema.TH( module X, mkReplicated,+ mkReplicated', ) where import Prelude hiding (read)@@ -16,12 +17,15 @@ import Control.Monad.Except (MonadError) import Control.Monad.State.Strict (MonadState, StateT) import qualified Data.ByteString.Char8 as BSC+import Data.Char (toTitle) import qualified Data.Map.Strict as Map import qualified Data.Text as Text import Language.Haskell.TH (Exp (VarE), bindS, conE, conP, conT, dataD, doE, letS, listE, noBindS, recC, recConE, sigD, varE, varP, varT) import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter), quoteDec,+ quoteExp, quotePat, quoteType) import Language.Haskell.TH.Syntax (lift, liftData) import RON.Data (Replicated (..), ReplicatedAsObject (..),@@ -34,13 +38,21 @@ import RON.Data.VersionVector (VersionVector) import RON.Event (ReplicaClock) import RON.Schema as X+import qualified RON.Schema.EDN as EDN import RON.Types (Object (..), UUID) import qualified RON.UUID as UUID +mkReplicated :: QuasiQuoter+mkReplicated = QuasiQuoter{quoteDec, quoteExp = e, quotePat = e, quoteType = e}+ where+ e = error "declaration only"+ quoteDec = EDN.parseSchema >=> mkReplicated'+ -- | Generate Haskell types from RON-Schema-mkReplicated :: Schema -> TH.DecsQ-mkReplicated = fmap fold . traverse fromDecl where+mkReplicated' :: Schema -> TH.DecsQ+mkReplicated' = fmap fold . traverse fromDecl where fromDecl decl = case decl of+ DOpaque _ -> pure [] DStructLww s -> mkReplicatedStructLww s -- | Type-directing newtype@@ -99,7 +111,7 @@ StructLww{structName, structFields, structAnnotations} = struct - StructAnnotations{saHaskellDeriving, saHaskellFieldPrefix} =+ StructAnnotations{saHaskellFieldPrefix, saHaskellFieldCaseTransform} = structAnnotations name = mkNameT structName@@ -116,8 +128,7 @@ Map.assocs structFields , let viewType = mkViewType fieldType ]]- [TH.derivClause Nothing . map (conT . mkNameT) $- toList saHaskellDeriving]+ [] mkInstanceReplicated = [d| instance Replicated $structT where@@ -167,7 +178,12 @@ ] consP = conP name [varP field'Var | Field'{field'Var} <- fields] - mkHaskellFieldName = (saHaskellFieldPrefix <>)+ mkHaskellFieldName base = saHaskellFieldPrefix <> base' where+ base' = case saHaskellFieldCaseTransform of+ Nothing -> base+ Just TitleCase -> case Text.uncons base of+ Nothing -> base+ Just (b, baseTail) -> Text.cons (toTitle b) baseTail mkAccessors field' = do a <- varT <$> TH.newName "a"@@ -228,11 +244,9 @@ TRga item -> wrapList item TStructLww StructLww{structName} -> conT $ mkNameT structName TVersionVector -> [t| VersionVector |]- TOpaque Opaque{opaqueAnnotations} -> let+ TOpaque Opaque{opaqueName, opaqueAnnotations} -> let OpaqueAnnotations{oaHaskellType} = opaqueAnnotations- in case oaHaskellType of- Just name -> conT $ mkNameT name- Nothing -> fail "Opaque type must define a Haskell type"+ in conT $ mkNameT $ fromMaybe opaqueName oaHaskellType where wrapList a = [t| [$(mkViewType a)] |]
lib/RON/Storage.hs view
@@ -15,7 +15,6 @@ , DocVersion , MonadStorage (..) , createDocument- , createVersion , decodeDocId , loadDocument , modify
lib/RON/Text/Parse.hs view
@@ -37,14 +37,14 @@ import Data.Text (Text) import qualified RON.Base64 as Base64-import RON.Internal.Word (Word2, Word4, Word60, b00, b0000, b01, b10,- b11, ls60, safeCast) import RON.Types (Atom (AFloat, AInteger, AString, AUuid), Object (..), Op (..), OpTerm (THeader, TQuery, TRaw, TReduced), RawOp (..), StateChunk (..), StateFrame, UUID (UUID), WireChunk (Query, Raw, Value), WireFrame, WireReducedChunk (..))+import RON.Util.Word (Word2, Word4, Word60, b00, b0000, b01, b10, b11,+ ls60, safeCast) import RON.UUID (UuidFields (..)) import qualified RON.UUID as UUID
lib/RON/Text/Serialize.hs view
@@ -23,7 +23,6 @@ import qualified Data.Aeson as Json import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC-import qualified Data.ByteString.Lazy.Search as BSL import qualified Data.Map.Strict as Map import Data.Text (Text) import Data.Traversable (for)@@ -135,9 +134,17 @@ -- | Serialize a string atom serializeString :: Text -> ByteStringL serializeString =- fixQuotes . BSL.replace "'" ("\\'" :: ByteString) . Json.encode+ wrapSingleQuotes . escapeApostrophe . stripDoubleQuotes . Json.encode where- fixQuotes = (`BSLC.snoc` '\'') . BSLC.cons '\'' . BSL.init . BSL.tail+ wrapSingleQuotes = (`BSLC.snoc` '\'') . BSLC.cons '\''+ stripDoubleQuotes = BSL.init . BSL.tail+ escapeApostrophe s = let+ (s1, s2) = BSLC.break (== '\'') s+ in+ if BSL.null s2 then+ s1+ else+ s1 <> "\\'" <> escapeApostrophe (BSL.tail s2) -- | Serialize a payload in stream context serializePayload
lib/RON/Text/Serialize/UUID.hs view
@@ -21,9 +21,9 @@ import Data.Ord (comparing) import qualified RON.Base64 as Base64-import RON.Internal.Word (pattern B00, pattern B0000, pattern B01,- pattern B10, pattern B11, Word2, Word60,- ls60, safeCast)+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) -- | Serialize UUID without context (used for test)
lib/RON/Types.hs view
@@ -24,7 +24,6 @@ import RON.Internal.Prelude -import Control.DeepSeq (NFData) import Data.Data (Data) import Data.Text (Text) import GHC.Generics (Generic)@@ -33,7 +32,7 @@ -- | Atom — a payload element data Atom = AFloat Double | AInteger Int64 | AString Text | AUuid UUID- deriving (Data, Eq, Generic, Hashable, NFData, Show)+ deriving (Data, Eq, Generic, Hashable, Show) -- | Raw op data RawOp = RawOp@@ -44,7 +43,7 @@ , op :: Op -- ^ other keys and payload, that are common with reduced op }- deriving (Data, Eq, Generic, NFData)+ deriving (Data, Eq, Generic) -- | “Reduced” op (op from reduced chunk) data Op = Op@@ -55,7 +54,7 @@ , opPayload :: [Atom] -- ^ payload }- deriving (Data, Eq, Generic, Hashable, NFData, Show)+ deriving (Data, Eq, Generic, Hashable, Show) instance Show RawOp where show RawOp{opType, opObject, op = Op{opEvent, opRef, opPayload}} =@@ -77,11 +76,11 @@ { wrcHeader :: RawOp , wrcBody :: [Op] }- deriving (Data, Eq, Generic, NFData, Show)+ deriving (Data, Eq, Generic, Show) -- | Common chunk data WireChunk = Raw RawOp | Value WireReducedChunk | Query WireReducedChunk- deriving (Data, Eq, Generic, NFData, Show)+ deriving (Data, Eq, Generic, Show) -- | Common frame type WireFrame = [WireChunk]
lib/RON/UUID.hs view
@@ -29,7 +29,6 @@ import RON.Internal.Prelude -import Control.DeepSeq (NFData) import Data.Bits (shiftL, shiftR, (.|.)) import qualified Data.ByteString.Char8 as BSC import Data.Char (chr, toUpper)@@ -38,17 +37,16 @@ import GHC.Generics (Generic) import qualified RON.Base64 as Base64-import RON.Internal.Word (pattern B00, pattern B0000, pattern B01,- pattern B10, pattern B11, Word2, Word4,- Word60, leastSignificant2,- leastSignificant4, leastSignificant60,- safeCast)+import RON.Util.Word (pattern B00, pattern B0000, pattern B01,+ pattern B10, pattern B11, Word2, Word4, Word60,+ leastSignificant2, leastSignificant4,+ leastSignificant60, safeCast) -- | Universally unique identifier of anything data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64- deriving (Data, Eq, Generic, Hashable, NFData, Ord)+ deriving (Data, Eq, Generic, Hashable, Ord) -- | RON-Text-encoding instance Show UUID where
+ lib/RON/Util/Word.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeApplications #-}++module RON.Util.Word+ (+ -- * Word2+ Word2+ , 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+ , 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+ , word60add+ -- * Word64+ , Word64+ -- * SafeCast+ , SafeCast (..)+ ) where++import Data.Bits ((.&.))+import Data.Coerce (coerce)+import Data.Fixed (Fixed, HasResolution)+import Data.Hashable (Hashable, hashUsing, hashWithSalt)+import Data.Word (Word16, Word32, Word64, Word8)++newtype Word2 = W2 Word8+ deriving (Eq, Ord, Show)++b00, b01, b10, b11 :: Word2+b00 = W2 0b00+b01 = W2 0b01+b10 = W2 0b10+b11 = W2 0b11++pattern B00 :: Word2+pattern B00 = W2 0b00+pattern B01 :: Word2+pattern B01 = W2 0b01+pattern B10 :: Word2+pattern B10 = W2 0b10+pattern B11 :: Word2+pattern B11 = W2 0b11+{-# COMPLETE B00, B01, B10, B11 #-}++-- | 'Word2' smart constructor dropping upper bits+leastSignificant2 :: Integral integral => integral -> Word2+leastSignificant2 = W2 . (0b11 .&.) . fromIntegral++newtype Word4 = W4 Word8+ deriving (Eq, Ord, Show)++b0000, b0001, b0010, b0011, b0100, b0101, b0110, b0111 :: Word4+b1000, b1001, b1010, b1011, b1100, b1101, b1110, b1111 :: Word4+b0000 = W4 0b0000+b0001 = W4 0b0001+b0010 = W4 0b0010+b0011 = W4 0b0011+b0100 = W4 0b0100+b0101 = W4 0b0101+b0110 = W4 0b0110+b0111 = W4 0b0111+b1000 = W4 0b1000+b1001 = W4 0b1001+b1010 = W4 0b1010+b1011 = W4 0b1011+b1100 = W4 0b1100+b1101 = W4 0b1101+b1110 = W4 0b1110+b1111 = W4 0b1111++pattern B0000 :: Word4+pattern B0000 = W4 0b0000++-- | 'Word4' smart constructor dropping upper bits+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 = W6 . (0x3F .&.) . fromIntegral++-- | 'leastSignificant6' specialized for 'Word8'+ls6 :: Word8 -> Word6+ls6 = W6 . (0x3F .&.)++newtype Word12 = W12 Word16+ deriving (Eq, Ord, Show)++-- | 'Word12' smart constructor dropping upper bits+leastSignificant12 :: Integral integral => integral -> Word12+leastSignificant12 = W12 . (0xFFF .&.) . fromIntegral++-- | 'leastSignificant12' specialized for 'Word16'+ls12 :: Word16 -> Word12+ls12 = W12 . (0xFFF .&.)++newtype Word24 = W24 Word32+ deriving (Eq, Ord, Show)++-- | 'Word24' smart constructor dropping upper bits+leastSignificant24 :: Integral integral => integral -> Word24+leastSignificant24 = W24 . (0xFFFFFF .&.) . fromIntegral++-- | 'leastSignificant24' specialized for 'Word32'+ls24 :: Word32 -> Word24+ls24 = W24 . (0xFFF .&.)++newtype Word60 = W60 Word64+ deriving (Enum, Eq, Ord, Show)++instance Bounded Word60 where+ minBound = W60 0+ maxBound = W60 0xFFFFFFFFFFFFFFF++instance Hashable Word60 where+ hashWithSalt = hashUsing @Word64 coerce++-- | 'Word60' smart constructor dropping upper bits+leastSignificant60 :: Integral integral => integral -> Word60+leastSignificant60 = W60 . (0xFFFFFFFFFFFFFFF .&.) . fromIntegral++-- | 'leastSignificant60' specialized for 'Word64'+ls60 :: Word64 -> Word60+ls60 = W60 . (0xFFFFFFFFFFFFFFF .&.)++-- | 'Word60' smart constructor checking domain+toWord60 :: Word64 -> Maybe Word60+toWord60 w+ | w < 0x1000000000000000 = Just $ W60 w+ | otherwise = Nothing++word60add :: Word60 -> Word60 -> Word60+word60add (W60 a) (W60 b) = leastSignificant60 $ a + b++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 Word64 Integer where safeCast = fromIntegral++-- Fixed are Integers inside, so have arbitrary magnitude+instance HasResolution e => SafeCast Word64 (Fixed e) where+ safeCast = fromIntegral
ron.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-version: 0.2+version: 0.3 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database@@ -56,20 +56,20 @@ bytestring, containers, data-default,- deepseq, Diff, directory, errors, extra, filepath, hashable,+ hedn, mtl, network-info, safe,- stringsearch, template-haskell, text, time,+ transformers, unordered-containers, vector, exposed-modules:@@ -79,7 +79,6 @@ RON.Binary.Serialize RON.Binary.Types RON.Data- RON.Data.Internal RON.Data.LWW RON.Data.ORSet RON.Data.RGA@@ -88,8 +87,6 @@ RON.Epoch RON.Event RON.Event.Simulation- RON.Internal.Prelude- RON.Internal.Word RON.Schema RON.Schema.TH RON.Storage@@ -100,10 +97,14 @@ RON.Text.Serialize RON.Text.Serialize.UUID RON.Types+ RON.Util.Word RON.UUID other-modules: Attoparsec.Extra Data.ZigZag+ RON.Data.Internal+ RON.Internal.Prelude+ RON.Schema.EDN hs-source-dirs: lib benchmark bench