diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/lib/RON/Schema.hs b/lib/RON/Schema.hs --- a/lib/RON/Schema.hs +++ b/lib/RON/Schema.hs @@ -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) diff --git a/lib/RON/Schema/EDN.hs b/lib/RON/Schema/EDN.hs --- a/lib/RON/Schema/EDN.hs +++ b/lib/RON/Schema/EDN.hs @@ -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 diff --git a/lib/RON/Schema/TH.hs b/lib/RON/Schema/TH.hs --- a/lib/RON/Schema/TH.hs +++ b/lib/RON/Schema/TH.hs @@ -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 diff --git a/lib/RON/Schema/TH/Common.hs b/lib/RON/Schema/TH/Common.hs --- a/lib/RON/Schema/TH/Common.hs +++ b/lib/RON/Schema/TH/Common.hs @@ -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) |] diff --git a/lib/RON/Schema/TH/Struct.hs b/lib/RON/Schema/TH/Struct.hs --- a/lib/RON/Schema/TH/Struct.hs +++ b/lib/RON/Schema/TH/Struct.hs @@ -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 diff --git a/ron-schema.cabal b/ron-schema.cabal --- a/ron-schema.cabal +++ b/ron-schema.cabal @@ -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