ron-schema 0.8 → 0.9
raw patch · 7 files changed
+446/−304 lines, 7 files
Files
- CHANGELOG.md +24/−1
- lib/RON/Schema.hs +22/−27
- lib/RON/Schema/EDN.hs +39/−41
- lib/RON/Schema/TH.hs +6/−5
- lib/RON/Schema/TH/Common.hs +27/−16
- lib/RON/Schema/TH/Struct.hs +327/−213
- ron-schema.cabal +1/−1
CHANGELOG.md view
@@ -7,6 +7,28 @@ ## [Unreleased] +## [0.9] - 2019-09-06+### Added+- Generate `struct_set.$(field)_zoom` for opaque object field+- Generate `struct_set.$(field)_get` for object field+- `ObjectRef` is available in the schema language+- Generate `struct_set.$(field)_add`+- Generate `struct_set.$(field)_remove` for set-merged fields+- Generate `struct_set.$(field)_removeIf` for set-merged fields++### Changed+- `opaque atoms` is now `opaque_atoms`+- `opaque object` is now `opaque_object`+- `struct_set.$(field)_assign` is split into:+ - `struct_set.$(field)_set` now accepts only "whole" (not Nothing) values+ - `struct_set.$(field)_clear` assigns Nothing+- Renamed `struct_lww.$(field)_assign` to `struct_lww.$(field)_set`+- Type of `struct_set` fields with merge strategy `set` is now `[]` and its+ value contains all alive versions.++### Removed+- `TComposite`, now `TEnum _ :: RonType`+ ## [0.8] - 2019-08-10 ### Added - `Float` atom type@@ -131,7 +153,8 @@ - RON-Schema - RON-Schema TemplateHaskell code generator -[Unreleased]: https://github.com/ff-notes/ron/compare/ron-schema-0.8...HEAD+[Unreleased]: https://github.com/ff-notes/ron/compare/ron-schema-0.9...HEAD+[0.9]: https://github.com/ff-notes/ron/compare/ron-schema-0.8...ron-schema-0.9 [0.8]: https://github.com/ff-notes/ron/compare/ron-schema-0.7...ron-schema-0.8 [0.7]: https://github.com/ff-notes/ron/compare/ron-schema-0.6...ron-schema-0.7 [0.6]: https://github.com/ff-notes/ff/compare/v0.5...ron-schema-0.6
lib/RON/Schema.hs view
@@ -23,7 +23,6 @@ StructLww, StructSet, TAtom (..),- TComposite (..), TEnum (..), TObject (..), TypeExpr (..),@@ -42,30 +41,26 @@ data TypeExpr = Use TypeName | Apply TypeName [TypeExpr] deriving (Show) -data TAtom = TAFloat | TAInteger | TAString | TAUuid+data TAtom = TAFloat | TAInteger | TAString | TAUuid | TObjectRef RonType deriving (Show) data RonType- = TAtom TAtom- | TComposite TComposite- | TObject TObject- | TOpaque Opaque- deriving (Show)---- | TODO(2019-08-04, cblp) do we need is as a group?-newtype TComposite- = TEnum TEnum+ = TAtom TAtom+ | TEnum TEnum+ | TObject TObject+ | TOpaqueAtoms Opaque deriving (Show) data TEnum = Enum {name :: Text, items :: [Text]} deriving (Show) data TObject- = TORSet RonType- | TORSetMap RonType RonType- | TRga RonType- | TStructLww (StructLww Resolved)- | TStructSet (StructSet Resolved)+ = TOpaqueObject Opaque+ | TORSet RonType+ | TORSetMap RonType RonType+ | TRga RonType+ | TStructLww (StructLww Resolved)+ | TStructSet (StructSet Resolved) | TVersionVector deriving (Show) @@ -123,11 +118,12 @@ UseType Equipped = RonType data Declaration stage- = DAlias (Alias stage)- | DEnum TEnum- | DOpaque Opaque- | DStructLww (StructLww stage)- | DStructSet (StructSet stage)+ = DAlias (Alias stage)+ | DEnum TEnum+ | DOpaqueAtoms Opaque+ | DOpaqueObject Opaque+ | DStructLww (StructLww stage)+ | DStructSet (StructSet stage) deriving instance (Show (UseType stage), Show (XField stage)) => Show (Declaration stage) @@ -142,20 +138,19 @@ defaultOpaqueAnnotations = OpaqueAnnotations{haskellType = Nothing} data Opaque = Opaque- { isObject :: Bool- , name :: Text+ { name :: Text , annotations :: OpaqueAnnotations } deriving (Show) opaqueObject :: Text -> OpaqueAnnotations -> RonType-opaqueObject tyname = TOpaque . Opaque True tyname+opaqueObject tyname = TObject . TOpaqueObject . Opaque tyname opaqueAtoms :: Text -> OpaqueAnnotations -> RonType-opaqueAtoms tyname = TOpaque . Opaque False tyname+opaqueAtoms tyname = TOpaqueAtoms . Opaque tyname opaqueAtoms_ :: Text -> RonType-opaqueAtoms_ tyname = TOpaque $ Opaque False tyname defaultOpaqueAnnotations+opaqueAtoms_ tyname = TOpaqueAtoms $ Opaque tyname defaultOpaqueAnnotations data Alias stage = Alias{name :: Text, target :: UseType stage} deriving instance Show (UseType stage) => Show (Alias stage)@@ -165,4 +160,4 @@ | Max | Min | Set- deriving (Show)+ deriving (Eq, Show)
lib/RON/Schema/EDN.hs view
@@ -50,6 +50,7 @@ , ("Day", Type0 day) , ("Float", Type0 $ TAtom TAFloat) , ("Integer", Type0 $ TAtom TAInteger)+ , ("ObjectRef", Type1 $ TAtom . TObjectRef) , ("ORSet.Map", Type2 $ \k v -> TObject $ TORSetMap k v) , ("ORSet", Type1 $ TObject . TORSet) , ("RGA", Type1 $ TObject . TRga)@@ -65,12 +66,13 @@ instance FromEDN (Declaration 'Parsed) where parseEDN = withNoTag . withList $ \case func : args -> (`withSymbol'` func) $ \case- "alias" -> DAlias <$> parseList args- "enum" -> DEnum <$> parseList args- "opaque" -> DOpaque <$> parseList args- "struct_lww" -> DStructLww <$> parseList args- "struct_set" -> DStructSet <$> parseList args- name -> fail $ "unknown declaration " ++ Text.unpack name+ "alias" -> DAlias <$> parseList args+ "enum" -> DEnum <$> parseList args+ "opaque_atoms" -> DOpaqueAtoms <$> parseList args+ "opaque_object" -> DOpaqueObject <$> parseList args+ "struct_lww" -> DStructLww <$> parseList args+ "struct_set" -> DStructSet <$> parseList args+ name -> fail $ "unknown declaration " ++ Text.unpack name [] -> fail "empty declaration" instance FromEDN TEnum where@@ -85,16 +87,11 @@ instance FromEDN Opaque where parseEDN = withNoTag . withList $ \case- kind : nameSym : annotationVals ->- (`withSymbol'` kind) $ \case- "atoms" -> go False- "object" -> go True- _ -> fail "opaque kind must be either atoms or object"+ nameSym : annotationVals -> do+ name <- parseSymbol' nameSym+ annotations <- parseAnnotations+ pure Opaque{name, annotations} where- go isObject = do- name <- parseSymbol' nameSym- annotations <- parseAnnotations- pure Opaque{isObject, name, annotations} parseAnnotations = case annotationVals of [] -> pure defaultOpaqueAnnotations _ -> fail "opaque annotations are not implemented yet"@@ -115,11 +112,12 @@ declarationName :: Declaration stage -> TypeName declarationName = \case- DAlias Alias {name} -> name- DEnum Enum {name} -> name- DOpaque Opaque{name} -> name- DStructLww Struct{name} -> name- DStructSet Struct{name} -> name+ DAlias Alias {name} -> name+ DEnum Enum {name} -> name+ DOpaqueAtoms Opaque{name} -> name+ DOpaqueObject Opaque{name} -> name+ DStructLww Struct{name} -> name+ DStructSet Struct{name} -> name instance FromEDN (StructLww Parsed) where parseEDN = parseStruct "struct_lww"@@ -198,11 +196,12 @@ validateParsed :: MonadFail m => Env -> Schema Parsed -> m () validateParsed Env{userTypes} = traverse_ $ \case- DAlias Alias{target} -> validateExpr target- DEnum _ -> pure ()- DOpaque _ -> pure ()- DStructLww Struct{fields} -> validateStruct fields- DStructSet Struct{fields} -> validateStruct fields+ DAlias Alias{target} -> validateExpr target+ DEnum _ -> pure ()+ DOpaqueAtoms _ -> pure ()+ DOpaqueObject _ -> pure ()+ DStructLww Struct{fields} -> validateStruct fields+ DStructSet Struct{fields} -> validateStruct fields where validateName name = unless@@ -218,24 +217,22 @@ validateResolved :: MonadFail m => Schema Resolved -> m () validateResolved = traverse_ $ \case- DAlias _ -> pure ()- DEnum _ -> pure ()- DOpaque _ -> pure ()- DStructLww _ -> pure ()- DStructSet Struct{name, fields} -> validateSetFields name fields+ DAlias _ -> pure ()+ DEnum _ -> pure ()+ DOpaqueAtoms _ -> pure ()+ DOpaqueObject _ -> pure ()+ DStructLww _ -> pure ()+ DStructSet Struct{name, fields} -> validateSetFields name fields where validateSetFields structName fields = void $ Map.traverseWithKey validateField fields where validateField fieldName field = case ronType of- TAtom a -> goAtom a- TComposite c -> case c of- TEnum _ -> goAtom TAUuid- TObject _ -> goObject- TOpaque Opaque{isObject}- | isObject -> goObject- | otherwise -> goOpaqueAtoms+ TAtom a -> goAtom a+ TEnum _ -> goAtom TAUuid+ TObject _ -> goObject+ TOpaqueAtoms _ -> goOpaqueAtoms where Field{ronType, annotations} = field FieldAnnotations{mergeStrategy} = annotations@@ -281,11 +278,12 @@ DAlias Alias{name, target} -> let target' = evalType target in (DAlias Alias{name, target = target'}, Type0 target')- DEnum t -> (DEnum t, Type0 $ TComposite $ TEnum t)- DOpaque t -> (DOpaque t, Type0 $ TOpaque t)- DStructLww s ->+ DEnum t -> (DEnum t, Type0 $ TEnum t)+ DOpaqueAtoms t -> (DOpaqueAtoms t, Type0 $ TOpaqueAtoms t)+ DOpaqueObject t -> (DOpaqueObject t, Type0 $ TObject $ TOpaqueObject t)+ DStructLww s -> (DStructLww &&& Type0 . TObject . TStructLww) $ evalStruct s- DStructSet s ->+ DStructSet s -> (DStructSet &&& Type0 . TObject . TStructSet) $ evalStruct s evalStruct :: Struct encoding Parsed -> Struct encoding Resolved
lib/RON/Schema/TH.hs view
@@ -45,11 +45,12 @@ mkReplicated' :: Schema 'Resolved -> TH.DecsQ mkReplicated' = fmap fold . traverse fromDecl where fromDecl decl = case decl of- DAlias a -> mkAlias a- DEnum e -> mkEnum e- DOpaque _ -> pure []- DStructLww s -> mkReplicatedStructLww s- DStructSet s -> mkReplicatedStructSet s+ DAlias a -> mkAlias a+ DEnum e -> mkEnum e+ DOpaqueAtoms _ -> pure []+ DOpaqueObject _ -> pure []+ DStructLww s -> mkReplicatedStructLww s+ DStructSet s -> mkReplicatedStructSet s mkEnum :: TEnum -> TH.DecsQ mkEnum Enum{name, items} = do
lib/RON/Schema/TH/Common.hs view
@@ -8,6 +8,7 @@ fieldPat', let1S, liftText,+ mkFieldType, mkGuideType, mkNameT, newNameT,@@ -26,7 +27,7 @@ import RON.Data.RGA (RGA) import RON.Data.VersionVector (VersionVector) import RON.Schema as X-import RON.Types (UUID)+import RON.Types (ObjectRef, UUID) mkNameT :: Text -> TH.Name mkNameT = TH.mkName . Text.unpack@@ -46,25 +47,35 @@ mkGuideType :: RonType -> TH.TypeQ mkGuideType typ = case typ of TAtom atom -> case atom of- TAFloat -> [t| Double |]- TAInteger -> [t| Int64 |]- TAString -> [t| Text |]- TAUuid -> [t| UUID |]- TComposite t -> case t of- TEnum Enum{name} -> conT $ mkNameT name+ TAFloat -> [t| Double |]+ TAInteger -> [t| Int64 |]+ TAString -> [t| Text |]+ TAUuid -> [t| UUID |]+ TObjectRef t -> wrap ''ObjectRef t+ TEnum Enum{name} -> conT $ mkNameT name TObject t -> case t of- TORSet item -> wrap ''ORSet item- TORSetMap key value -> wrap2 ''ORSetMap key value- TRga item -> wrap ''RGA item- TStructLww Struct{name} -> conT $ mkNameT name- TStructSet Struct{name} -> conT $ mkNameT name- TVersionVector -> [t| VersionVector |]- TOpaque Opaque{name, annotations} -> let- OpaqueAnnotations{haskellType} = annotations- in conT $ mkNameT $ fromMaybe name haskellType+ TOpaqueObject u -> mkOpaque u+ TORSet item -> wrap ''ORSet item+ TORSetMap key value -> wrap2 ''ORSetMap key value+ TRga item -> wrap ''RGA item+ TStructLww Struct{name} -> conT $ mkNameT name+ TStructSet Struct{name} -> conT $ mkNameT name+ TVersionVector -> [t| VersionVector |]+ TOpaqueAtoms t -> mkOpaque t where wrap w a = [t| $(conT w) $(mkGuideType a) |] wrap2 w a b = [t| $(conT w) $(mkGuideType a) $(mkGuideType b) |]+ mkOpaque Opaque{name, annotations = OpaqueAnnotations{haskellType}} =+ conT $ mkNameT $ fromMaybe name haskellType++mkFieldType :: RonType -> Maybe MergeStrategy -> TH.TypeQ+mkFieldType typ mergeStrategy = case (typ, mergeStrategy) of+ (_, Just Set) -> listGuide+ _ -> maybeGuide+ where+ listGuide = [t| [ $guide ] |]+ maybeGuide = [t| Maybe $guide |]+ guide = mkGuideType typ liftText :: Text -> TH.ExpQ liftText t = [| Text.pack $(liftString $ Text.unpack t) |]
lib/RON/Schema/TH/Struct.hs view
@@ -8,294 +8,408 @@ {-# LANGUAGE TypeFamilies #-} {- HLINT ignore "Reduce duplication" -}--module RON.Schema.TH.Struct (- mkReplicatedStructLww,- mkReplicatedStructSet,-) where--import RON.Prelude+module RON.Schema.TH.Struct+ ( mkReplicatedStructLww,+ mkReplicatedStructSet+ )+where -import Data.Char (toTitle)+import Data.Char (toTitle) import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.Text.Encoding as Text-import Language.Haskell.TH (bindS, conT, doE, listE, newName, noBindS,- recC, recConE, recP, sigD, varE, varP,- varT)+import Language.Haskell.TH+ ( bindS,+ conT,+ doE,+ listE,+ newName,+ noBindS,+ recC,+ recConE,+ recP,+ sigD,+ varE,+ varP,+ varT+ ) import qualified Language.Haskell.TH as TH-import Language.Haskell.TH.Syntax (liftData)--import RON.Data (MonadObjectState, ObjectStateT,- Replicated (encoding),- ReplicatedAsObject (Rep, getObject, newObject),- getObjectStateChunk, objectEncoding)-import RON.Data.LWW (LwwRep)+import Language.Haskell.TH.Syntax (liftData)+import RON.Data+ ( MonadObjectState,+ ObjectStateT,+ Replicated (encoding),+ ReplicatedAsObject (Rep, newObject, readObject),+ getObjectStateChunk,+ objectEncoding+ )+import RON.Data.LWW (LwwRep) import qualified RON.Data.LWW as LWW-import RON.Data.ORSet (ORSetRep)+import RON.Data.ORSet (ORSetRep) import qualified RON.Data.ORSet as ORSet-import RON.Error (MonadE, errorContext)-import RON.Event (ReplicaClock)-import RON.Schema as X-import RON.Schema.TH.Common (fieldExp', fieldPat', liftText,- mkGuideType, mkNameT, newNameT, valDP)-import RON.Types (Object (Object), UUID)-import RON.Util (Instance (Instance))+import RON.Error (MonadE, errorContext)+import RON.Event (ReplicaClock)+import RON.Prelude+import RON.Schema as X+import RON.Schema.TH.Common+ ( fieldExp',+ fieldPat',+ liftText,+ mkFieldType,+ mkGuideType,+ mkNameT,+ newNameT,+ valDP+ )+import RON.Types (ObjectRef (ObjectRef), UUID) import qualified RON.UUID as UUID+import RON.Util (Instance (Instance)) type instance XField Equipped = XFieldEquipped -data XFieldEquipped = XFieldEquipped- { haskellName :: Text- , ronName :: UUID- }+data XFieldEquipped+ = XFieldEquipped+ { haskellName :: Text,+ ronName :: UUID+ } equipStruct :: Struct e Resolved -> Struct e Equipped-equipStruct Struct{name, fields, annotations} = Struct- {name, fields = Map.mapWithKey (equipField annotations) fields, annotations}+equipStruct Struct {name, fields, annotations} = Struct+ { name,+ fields = Map.mapWithKey (equipField annotations) fields,+ annotations+ } mkReplicatedStructLww :: StructLww Resolved -> TH.DecsQ mkReplicatedStructLww structResolved = do- dataType <- mkDataType struct- [instanceReplicated] <- mkInstanceReplicated type'- [instanceReplicatedAO] <- mkInstanceReplicatedAOLww struct- accessors <- fold <$> traverse (mkAccessorsLww name') fields- pure- $ dataType- : instanceReplicated : instanceReplicatedAO- : accessors+ dataType <- mkDataTypeLww struct+ [instanceReplicated] <- mkInstanceReplicated type'+ [instanceReplicatedAO] <- mkInstanceReplicatedAOLww struct+ accessors <- fold <$> traverse (mkAccessorsLww name') fields+ pure $ dataType : instanceReplicated : instanceReplicatedAO : accessors where- struct@Struct{name, fields} = equipStruct structResolved+ struct@Struct {name, fields} = equipStruct structResolved name' = mkNameT name- type' = conT name'+ type' = conT name' mkReplicatedStructSet :: StructSet Resolved -> TH.DecsQ mkReplicatedStructSet structResolved = do- dataType <- mkDataType struct- [instanceReplicated] <- mkInstanceReplicated type'- [instanceReplicatedAO] <- mkInstanceReplicatedAOSet struct- accessors <- fold <$> traverse (mkAccessorsSet name') fields- pure- $ dataType- : instanceReplicated : instanceReplicatedAO- : accessors+ dataType <- mkDataTypeSet struct+ [instanceReplicated] <- mkInstanceReplicated type'+ [instanceReplicatedAO] <- mkInstanceReplicatedAOSet struct+ accessors <- fold <$> traverse (mkAccessorsSet name') fields+ pure $ dataType : instanceReplicated : instanceReplicatedAO : accessors where- struct@Struct{name, fields} = equipStruct structResolved+ struct@Struct {name, fields} = equipStruct structResolved name' = mkNameT name- type' = conT name'+ type' = conT name' equipField :: StructAnnotations -> Text -> Field Resolved -> Field Equipped-equipField structAnnotations schemaName Field{..} =- case UUID.mkName $ Text.encodeUtf8 schemaName of- Just ronName -> Field{ext = XFieldEquipped{haskellName, ronName}, ..}- Nothing -> error $- "Field name is not representable in RON: " ++ show schemaName+equipField structAnnotations schemaName Field {..} =+ case UUID.mkName $ Text.encodeUtf8 schemaName of+ Just ronName -> Field {ext = XFieldEquipped {haskellName, ronName}, ..}+ Nothing ->+ error $ "Field name is not representable in RON: " ++ show schemaName where haskellName = mkHaskellFieldName structAnnotations schemaName varBangType' :: Text -> TH.TypeQ -> TH.VarBangTypeQ-varBangType' name- = TH.varBangType (mkNameT name)+varBangType' name =+ TH.varBangType (mkNameT name) . TH.bangType (TH.bang TH.noSourceUnpackedness TH.sourceStrict) -mkDataType :: Struct encoding Equipped -> TH.DecQ-mkDataType Struct{name, fields} =- TH.dataD- (TH.cxt [])- name'- []- Nothing- [recC name'- [ varBangType' haskellName [t| Maybe $(mkGuideType ronType) |]- | Field{ronType, ext = XFieldEquipped{haskellName}} <- toList fields- ]]- []+mkDataTypeLww :: StructLww Equipped -> TH.DecQ+mkDataTypeLww Struct {name, fields} =+ TH.dataD+ (TH.cxt [])+ name'+ []+ Nothing+ [ recC name'+ [ varBangType' haskellName [t|Maybe $(mkGuideType ronType)|]+ | Field {ronType, ext = XFieldEquipped {haskellName}} <- toList fields+ ]+ ]+ [] where name' = mkNameT name +mkDataTypeSet :: StructSet Equipped -> TH.DecQ+mkDataTypeSet Struct {name, fields} =+ TH.dataD+ (TH.cxt [])+ name'+ []+ Nothing+ [ recC name'+ [ varBangType' haskellName (mkFieldType ronType mergeStrategy)+ | Field {ronType, annotations, ext} <- toList fields,+ let FieldAnnotations {mergeStrategy} = annotations+ XFieldEquipped {haskellName} = ext+ ]+ ]+ []+ where+ name' = mkNameT name+ mkInstanceReplicated :: TH.TypeQ -> TH.DecsQ-mkInstanceReplicated type' = [d|+mkInstanceReplicated type' =+ [d| instance Replicated $type' where- encoding = objectEncoding+ encoding = objectEncoding |] mkInstanceReplicatedAOLww :: StructLww Equipped -> TH.DecsQ-mkInstanceReplicatedAOLww Struct{name, fields} = do- ops <- newName "ops"- vars <- traverse (newNameT . haskellName . ext) fields- let packFields = listE- [ [| ($ronName', Instance <$> $(varE var)) |]- | Field{ext = XFieldEquipped{ronName}} <- toList fields- , let ronName' = liftData ronName- | var <- toList vars- ]- unpackFields =- [ bindS (varP var) [| LWW.viewField $ronName' $(varE ops) |]- | Field{ext = XFieldEquipped{ronName}} <- toList fields- , let ronName' = liftData ronName+mkInstanceReplicatedAOLww Struct {name, fields} = do+ ops <- newName "ops"+ vars <- traverse (newNameT . haskellName . ext) fields+ let packFields =+ listE+ [ [|($ronName', Instance <$> $(varE var))|]+ | Field {ext = XFieldEquipped {ronName}} <- toList fields,+ let ronName' = liftData ronName | var <- toList vars ]- let consE = recConE name'- [ fieldExp' haskellName $ varE var- | Field{ext = XFieldEquipped{haskellName}} <- toList fields+ unpackFields =+ [ bindS (varP var) [|LWW.viewField $ronName' $(varE ops)|]+ | Field {ext = XFieldEquipped {ronName}} <- toList fields,+ let ronName' = liftData ronName+ | var <- toList vars+ ]+ let consE =+ recConE name'+ [ fieldExp' haskellName $ varE var+ | Field {ext = XFieldEquipped {haskellName}} <- toList fields | var <- toList vars ]- consP = recP name'- [ fieldPat' haskellName $ varP var- | Field{ext = XFieldEquipped{haskellName}} <- toList fields+ consP =+ recP name'+ [ fieldPat' haskellName $ varP var+ | Field {ext = XFieldEquipped {haskellName}} <- toList fields | var <- toList vars ]- let getObjectImpl = doE- $ bindS (varP ops) [| getObjectStateChunk |]- : unpackFields- ++ [noBindS [| pure $consE |]]- [d| instance ReplicatedAsObject $type' where- type Rep $type' = LwwRep- newObject $consP = Object <$> LWW.newStruct $packFields- getObject = errorContext $(liftText errCtx) $getObjectImpl- -- rempty = $remptyImpl- |]+ let readObjectImpl =+ doE+ $ bindS (varP ops) [|getObjectStateChunk|]+ : unpackFields+ ++ [noBindS [|pure $consE|]]+ [d|+ instance ReplicatedAsObject $type' where++ type Rep $type' = LwwRep++ newObject $consP = ObjectRef <$> LWW.newStruct $packFields++ readObject = errorContext $(liftText errCtx) $readObjectImpl+ |] where name' = mkNameT name- type' = conT name'- errCtx = "getObject @" <> name+ type' = conT name'+ errCtx = "readObject @" <> name mkInstanceReplicatedAOSet :: StructSet Equipped -> TH.DecsQ-mkInstanceReplicatedAOSet Struct{name, fields} = do- ops <- newName "ops"- vars <- traverse (newNameT . haskellName . ext) fields- let packFields = listE- [ [| ($ronName', fmap Instance $(varE var)) |]- | Field{ext = XFieldEquipped{ronName}} <- toList fields- , let ronName' = liftData ronName+mkInstanceReplicatedAOSet Struct {name, fields} = do+ ops <- newName "ops"+ vars <- traverse (newNameT . haskellName . ext) fields+ let packFields =+ listE+ [ [|[($ronName', Instance val) | val <- toList $(varE var)]|]+ | Field {ext = XFieldEquipped {ronName}} <- toList fields,+ let ronName' = liftData ronName | var <- toList vars ]- unpackFields =- [ bindS- (varP var)- [| errorContext $(liftText haskellName) $- $(orSetViewField mergeStrategy) $ronName' $(varE ops) |]- | Field{annotations = FieldAnnotations{mergeStrategy}, ext} <-- toList fields- , let- XFieldEquipped{haskellName, ronName} = ext+ unpackFields =+ [ bindS+ (varP var)+ [|+ errorContext $(liftText haskellName)+ $ $(orSetViewField mergeStrategy) $ronName' $(varE ops)+ |]+ | Field {annotations = FieldAnnotations {mergeStrategy}, ext} <-+ toList fields,+ let XFieldEquipped {haskellName, ronName} = ext ronName' = liftData ronName- | var <- toList vars- ]- let consE = recConE name'- [ fieldExp' haskellName $ varE var- | Field{ext = XFieldEquipped{haskellName}} <- toList fields+ | var <- toList vars+ ]+ let consE =+ recConE name'+ [ fieldExp' haskellName $ varE var+ | Field {ext = XFieldEquipped {haskellName}} <- toList fields | var <- toList vars ]- consP = recP name'- [ fieldPat' haskellName $ varP var- | Field{ext = XFieldEquipped{haskellName}} <- toList fields+ consP =+ recP name'+ [ fieldPat' haskellName $ varP var+ | Field {ext = XFieldEquipped {haskellName}} <- toList fields | var <- toList vars ]- let getObjectImpl = doE- $ bindS (varP ops) [| getObjectStateChunk |]- : unpackFields- ++ [noBindS [| pure $consE |]]- [d| instance ReplicatedAsObject $type' where- type Rep $type' = ORSetRep- newObject $consP = Object <$> ORSet.newStruct $packFields- getObject = errorContext $(liftText errCtx) $getObjectImpl- -- rempty = _- |]+ let readObjectImpl =+ doE+ $ bindS (varP ops) [|getObjectStateChunk|]+ : unpackFields+ ++ [noBindS [|pure $consE|]]+ [d|+ instance ReplicatedAsObject $type' where++ type Rep $type' = ORSetRep++ newObject $consP = ObjectRef <$> ORSet.newStruct (fold $packFields)++ readObject = errorContext $(liftText errCtx) $readObjectImpl+ |] where name' = mkNameT name type' = conT name'- errCtx = "getObject @" <> name+ errCtx = "readObject @" <> name mkHaskellFieldName :: StructAnnotations -> Text -> Text-mkHaskellFieldName annotations base = prefix <> base' where+mkHaskellFieldName annotations base = prefix <> base'+ where StructAnnotations- { haskellFieldPrefix = prefix- , haskellFieldCaseTransform = caseTransform- }- = annotations+ { haskellFieldPrefix = prefix,+ haskellFieldCaseTransform = caseTransform+ } =+ annotations base' = case caseTransform of- Nothing -> base- Just TitleCase -> case Text.uncons base of- Nothing -> base- Just (b, baseTail) -> Text.cons (toTitle b) baseTail+ Nothing -> base+ Just TitleCase -> case Text.uncons base of+ Nothing -> base+ Just (b, baseTail) -> Text.cons (toTitle b) baseTail mkAccessorsLww :: TH.Name -> Field Equipped -> TH.DecsQ mkAccessorsLww name' field = do- a <- varT <$> newName "a"- m <- varT <$> newName "m"- let assignF =- [ sigD assign [t|- (ReplicaClock $m, MonadE $m, MonadObjectState $type' $m)- => Maybe $guideType -> $m () |]- , valDP assign [| LWW.assignField $ronName' |]- ]- readF =- [ sigD read [t|- (MonadE $m, MonadObjectState $type' $m)- => $m (Maybe $guideType) |]- , valDP read [| LWW.readField $ronName' |]- ]- zoomF =- [ sigD zoom [t|- MonadE $m- => ObjectStateT $guideType $m $a- -> ObjectStateT $type' $m $a |]- , valDP zoom [| LWW.zoomField $ronName' |]- ]- sequenceA $ assignF ++ readF ++ zoomF+ a <- varT <$> newName "a"+ m <- varT <$> newName "m"+ let setF =+ [ sigD set+ [t|+ (ReplicaClock $m, MonadE $m, MonadObjectState $type' $m)+ => Maybe $guideType+ -> $m ()+ |],+ valDP set [|LWW.assignField $ronName'|]+ ]+ readF =+ [ sigD read+ [t|+ (MonadE $m, MonadObjectState $type' $m) => $m (Maybe $guideType)+ |],+ valDP read [|LWW.readField $ronName'|]+ ]+ zoomF =+ [ sigD zoom+ [t|+ MonadE $m+ => ObjectStateT $guideType $m $a+ -> ObjectStateT $type' $m $a+ |],+ valDP zoom [|LWW.zoomField $ronName'|]+ ]+ sequenceA $ setF ++ readF ++ zoomF where- Field{ronType, ext = XFieldEquipped{haskellName, ronName}} = field+ Field {ronType, ext = XFieldEquipped {haskellName, ronName}} = field ronName' = liftData ronName- type' = conT name'+ type' = conT name' guideType = mkGuideType ronType- assign = mkNameT $ haskellName <> "_assign"- read = mkNameT $ haskellName <> "_read"- zoom = mkNameT $ haskellName <> "_zoom"+ set = mkNameT $ haskellName <> "_set"+ read = mkNameT $ haskellName <> "_read"+ zoom = mkNameT $ haskellName <> "_zoom" mkAccessorsSet :: TH.Name -> Field Equipped -> TH.DecsQ mkAccessorsSet name' field = do- a <- varT <$> newName "a"- m <- varT <$> newName "m"- let assignF =- [ sigD assign [t|- (ReplicaClock $m, MonadE $m, MonadObjectState $type' $m)- => Maybe $guideType -> $m () |]- , valDP assign [| ORSet.assignField $ronName' |]- ]- readF =- [ sigD read [t|- (MonadE $m, MonadObjectState $type' $m)- => $m (Maybe $guideType) |]- , valDP read- [| do- chunk <- getObjectStateChunk- $(orSetViewField mergeStrategy) $ronName' chunk |]- ]- zoomF = case ronType of- TObject _ ->- [ sigD zoom [t|- (MonadE $m, ReplicaClock $m)- => ObjectStateT $(mkGuideType ronType) $m $a- -> ObjectStateT $type' $m $a |]- , valDP zoom [| ORSet.zoomFieldObject $ronName' |]- ]- _ -> []- sequenceA $ assignF ++ readF ++ zoomF+ a <- varT <$> newName "a"+ m <- varT <$> newName "m"+ let addF =+ [ sigD add+ [t|+ (ReplicaClock $m, MonadE $m, MonadObjectState $type' $m)+ => $guideType+ -> $m ()+ |],+ valDP add [|ORSet.addFieldValue $ronName'|]+ ]+ let setF =+ [ sigD set+ [t|+ (ReplicaClock $m, MonadE $m, MonadObjectState $type' $m)+ => $guideType+ -> $m ()+ |],+ valDP set [|ORSet.assignField $ronName' . Just|]+ ]+ let clearF =+ [ sigD clear+ [t|+ (ReplicaClock $m, MonadE $m, MonadObjectState $type' $m) => $m ()+ |],+ valDP clear+ [|ORSet.assignField $ronName' (Nothing :: Maybe $guideType)|]+ ]+ let getF = do+ TObject _ <- [ronType]+ [ sigD getName+ [t|+ (MonadE $m, MonadObjectState $type' $m)+ => $m (Maybe (ObjectRef $guideType))+ |],+ valDP getName [|ORSet.getFieldObject $ronName'|]+ ]+ let readF =+ [ sigD read+ [t|(MonadE $m, MonadObjectState $type' $m) => $m $fieldType|],+ valDP read+ [|+ do+ chunk <- getObjectStateChunk+ $(orSetViewField mergeStrategy) $ronName' chunk+ |]+ ]+ let removeF = do+ guard $ mergeStrategy == Just Set+ [ sigD remove+ [t|+ (MonadE $m, MonadObjectState $type' $m, ReplicaClock $m)+ => $guideType -> $m ()+ |],+ valDP remove [|ORSet.removeFieldValue $ronName'|],+ sigD removeIf+ [t|+ (MonadE $m, MonadObjectState $type' $m, ReplicaClock $m)+ => ($guideType -> $m Bool) -> $m ()+ |],+ valDP removeIf [|ORSet.removeFieldValueIf $ronName'|]+ ]+ let zoomF = do+ TObject _ <- [ronType]+ [ sigD zoom+ [t|+ (MonadE $m, ReplicaClock $m)+ => ObjectStateT $guideType $m $a+ -> ObjectStateT $type' $m $a+ |],+ valDP zoom [|ORSet.zoomFieldObject $ronName'|]+ ]+ sequenceA $ addF ++ setF ++ clearF ++ getF ++ readF ++ removeF ++ zoomF where- Field{ronType, annotations = FieldAnnotations{mergeStrategy}, ext} = field- XFieldEquipped{haskellName, ronName} = ext+ Field {ronType, annotations = FieldAnnotations {mergeStrategy}, ext} = field+ XFieldEquipped {haskellName, ronName} = ext ronName' = liftData ronName- type' = conT name'+ type' = conT name'+ fieldType = mkFieldType ronType mergeStrategy guideType = mkGuideType ronType- assign = mkNameT $ haskellName <> "_assign"- read = mkNameT $ haskellName <> "_read"- zoom = mkNameT $ haskellName <> "_zoom"+ add = mkNameT $ haskellName <> "_add"+ clear = mkNameT $ haskellName <> "_clear"+ getName = mkNameT $ haskellName <> "_get"+ read = mkNameT $ haskellName <> "_read"+ remove = mkNameT $ haskellName <> "_remove"+ removeIf = mkNameT $ haskellName <> "_removeIf"+ set = mkNameT $ haskellName <> "_set"+ zoom = mkNameT $ haskellName <> "_zoom" orSetViewField :: Maybe MergeStrategy -> TH.ExpQ orSetViewField = varE . \case- Nothing -> 'ORSet.viewField- Just LWW -> 'ORSet.viewFieldLWW- Just Max -> 'ORSet.viewFieldMax- Just Min -> 'ORSet.viewFieldMin- Just Set -> 'ORSet.viewFieldSet+ Nothing -> 'ORSet.viewField+ Just LWW -> 'ORSet.viewFieldLWW+ Just Max -> 'ORSet.viewFieldMax+ Just Min -> 'ORSet.viewFieldMin+ Just Set -> 'ORSet.viewFieldSet
ron-schema.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-schema-version: 0.8+version: 0.9 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database