diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,23 @@ ## [Unreleased] +## [0.8] - 2019-08-10 +### Added +- `Float` atom type +- `UUID` atom type +- Struct field annotations +- `struct_set` to define an ORSet-based structure + +### Changed +- LWW + - fields are always optional + - `viewField` returns `Maybe` + - `readField` returns `Maybe` + - `assignField` takes `Maybe` + +### Removed +- `Option` type + ## [0.7] - 2019-07-26 ### Added - `alias` declaration. @@ -114,8 +131,9 @@ - RON-Schema - RON-Schema TemplateHaskell code generator -[Unreleased]: https://github.com/ff-notes/ron/compare/v0.7...HEAD -[0.7]: https://github.com/ff-notes/ron/compare/v0.6...v0.7 +[Unreleased]: https://github.com/ff-notes/ron/compare/ron-schema-0.8...HEAD +[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 [0.5]: https://github.com/ff-notes/ff/compare/v0.4...v0.5 [0.4]: https://github.com/ff-notes/ff/compare/v0.3...v0.4 diff --git a/lib/RON/Schema.hs b/lib/RON/Schema.hs --- a/lib/RON/Schema.hs +++ b/lib/RON/Schema.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -10,14 +9,19 @@ Alias (..), CaseTransform (..), Declaration (..), - Field (..), - Opaque (..), - OpaqueAnnotations (..), + Field (..), XField, + FieldAnnotations (..), defaultFieldAnnotations, + MergeStrategy (..), + Opaque (..), opaqueAtoms, opaqueAtoms_, opaqueObject, + OpaqueAnnotations (..), defaultOpaqueAnnotations, RonType (..), Schema, Stage (..), - StructAnnotations (..), - StructLww (..), + Struct (..), + StructAnnotations (..), defaultStructAnnotations, + StructEncoding (..), + StructLww, + StructSet, TAtom (..), TComposite (..), TEnum (..), @@ -25,25 +29,20 @@ TypeExpr (..), TypeName, UseType, - defaultOpaqueAnnotations, - defaultStructAnnotations, - opaqueAtoms, - opaqueAtoms_, - opaqueObject, ) where import RON.Prelude import qualified Data.Text as Text -data Stage = Parsed | Resolved +data Stage = Parsed | Resolved | Equipped type TypeName = Text data TypeExpr = Use TypeName | Apply TypeName [TypeExpr] deriving (Show) -data TAtom = TAInteger | TAString +data TAtom = TAFloat | TAInteger | TAString | TAUuid deriving (Show) data RonType @@ -53,9 +52,9 @@ | TOpaque Opaque deriving (Show) -data TComposite - = TOption RonType - | TEnum TEnum +-- | TODO(2019-08-04, cblp) do we need is as a group? +newtype TComposite + = TEnum TEnum deriving (Show) data TEnum = Enum {name :: Text, items :: [Text]} @@ -65,17 +64,25 @@ = TORSet RonType | TORSetMap RonType RonType | TRga RonType - | TStructLww (StructLww 'Resolved) + | TStructLww (StructLww Resolved) + | TStructSet (StructSet Resolved) | TVersionVector deriving (Show) -data StructLww stage = StructLww +data StructEncoding = SELww | SESet + +data Struct (encoding :: StructEncoding) stage = Struct { name :: Text , fields :: Map Text (Field stage) , annotations :: StructAnnotations } -deriving instance Show (UseType stage) => Show (StructLww stage) +deriving instance + (Show (UseType stage), Show (XField stage)) => Show (Struct encoding stage) +type StructLww = Struct SELww + +type StructSet = Struct SESet + data StructAnnotations = StructAnnotations { haskellFieldPrefix :: Text , haskellFieldCaseTransform :: Maybe CaseTransform @@ -89,19 +96,40 @@ data CaseTransform = TitleCase deriving (Show) -newtype Field stage = Field{ronType :: UseType stage} -deriving instance Show (UseType stage) => Show (Field stage) +data Field (stage :: Stage) = Field + { ronType :: UseType stage + , annotations :: FieldAnnotations + , ext :: XField stage + } +deriving instance + (Show (UseType stage), Show (XField stage)) => Show (Field stage) +newtype FieldAnnotations = + FieldAnnotations{mergeStrategy :: Maybe MergeStrategy} + deriving (Show) + +defaultFieldAnnotations :: FieldAnnotations +defaultFieldAnnotations = FieldAnnotations{mergeStrategy = Nothing} + +type family XField (stage :: Stage) + +type instance XField Parsed = () + +type instance XField Resolved = () + type family UseType (stage :: Stage) where - UseType 'Parsed = TypeExpr - UseType 'Resolved = RonType + UseType Parsed = TypeExpr + UseType Resolved = RonType + UseType Equipped = RonType data Declaration stage = DAlias (Alias stage) | DEnum TEnum | DOpaque Opaque | DStructLww (StructLww stage) -deriving instance Show (UseType stage) => Show (Declaration stage) + | DStructSet (StructSet stage) +deriving instance + (Show (UseType stage), Show (XField stage)) => Show (Declaration stage) type family Schema (stage :: Stage) where Schema 'Parsed = [Declaration 'Parsed] @@ -131,3 +159,10 @@ data Alias stage = Alias{name :: Text, target :: UseType stage} deriving instance Show (UseType stage) => Show (Alias stage) + +data MergeStrategy + = LWW + | Max + | Min + | Set + deriving (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 @@ -7,15 +7,17 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module RON.Schema.EDN (readSchema) where import RON.Prelude -import Data.EDN (FromEDN, Tagged (NoTag, Tagged), +import Control.Arrow ((&&&)) +import Data.EDN (FromEDN, Tagged (NoTag, Tagged), TaggedValue, Value (List, Symbol), mapGetSymbol, parseEDN, renderText, unexpected, withList, withMap, withNoTag) -import Data.EDN.Class.Parser (parseM) +import Data.EDN.Class.Parser (Parser, parseM) import Data.EDN.Extra (decodeMultiDoc, isTagged, parseList, parseSymbol', withNoPrefix, withSymbol') import Data.Map.Strict ((!?)) @@ -27,10 +29,11 @@ readSchema :: MonadFail m => String -> Text -> m (Schema 'Resolved) readSchema sourceName source = do parsed <- parseSchema sourceName source - env <- (`execStateT` Env{userTypes=Map.empty}) $ do - collectDeclarations parsed - validateTypeUses parsed - pure $ evalSchema env + env <- (`execStateT` Env{userTypes=Map.empty}) $ collectDeclarations parsed + validateParsed env parsed + let resolved = evalSchema env + validateResolved resolved + pure resolved newtype Env = Env{userTypes :: Map TypeName (Declaration 'Parsed)} deriving (Show) @@ -45,14 +48,15 @@ [ ("Bool", Type0 $ opaqueAtoms "Bool" OpaqueAnnotations{haskellType = Just "Bool"}) , ("Day", Type0 day) + , ("Float", Type0 $ TAtom TAFloat) , ("Integer", Type0 $ TAtom TAInteger) + , ("ORSet.Map", Type2 $ \k v -> TObject $ TORSetMap k v) + , ("ORSet", Type1 $ TObject . TORSet) + , ("RGA", Type1 $ TObject . TRga) , ("RgaString", Type0 $ TObject $ TRga char) , ("String", Type0 $ TAtom TAString) + , ("UUID", Type0 $ TAtom TAUuid) , ("VersionVector", Type0 $ TObject TVersionVector) - , ("Option", Type1 $ TComposite . TOption) - , ("ORSet", Type1 $ TObject . TORSet) - , ("ORSet.Map", Type2 $ \k v -> TObject $ TORSetMap k v) - , ("RGA", Type1 $ TObject . TRga) ] where char = opaqueAtoms "Char" OpaqueAnnotations{haskellType = Just "Char"} @@ -65,6 +69,7 @@ "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 [] -> fail "empty declaration" @@ -110,35 +115,48 @@ declarationName :: Declaration stage -> TypeName declarationName = \case - DAlias Alias {name} -> name - DEnum Enum {name} -> name - DOpaque Opaque {name} -> name - DStructLww StructLww{name} -> name + DAlias Alias {name} -> name + DEnum Enum {name} -> name + DOpaque Opaque{name} -> name + DStructLww Struct{name} -> name + DStructSet Struct{name} -> name -instance FromEDN (StructLww 'Parsed) where - parseEDN = withNoTag . withList $ \case - nameSym : body -> do - let (annotationVals, fieldVals) = span isTagged body - name <- parseSymbol' nameSym - fields <- parseFields fieldVals - annotations <- parseList annotationVals - pure StructLww{name, fields, annotations} - [] -> fail - "Expected declaration in the form\ - \ (struct_lww ... ...)" +instance FromEDN (StructLww Parsed) where + parseEDN = parseStruct "struct_lww" - where +instance FromEDN (StructSet Parsed) where + parseEDN = parseStruct "struct_set" - parseFields = \case - [] -> pure mempty - nameAsTagged : typeAsTagged : cont -> do - name <- parseSymbol' nameAsTagged - typ <- parseEDN typeAsTagged - Map.insert name (Field typ) <$> parseFields cont - [f] -> - fail $ - "field " ++ Text.unpack (renderText f) ++ " must have type" +parseStruct :: String -> TaggedValue -> Parser (Struct encoding Parsed) +parseStruct keyword = withNoTag . withList $ \case + nameSym : body -> do + let (annotationVals, fieldVals) = span isTagged body + name <- parseSymbol' nameSym + fields <- parseFields fieldVals + annotations <- parseList annotationVals + pure Struct{..} + [] -> + fail + $ "Expected declaration in the form (" + ++ keyword + ++ " ... ...)" + where + + parseFields = \case + [] -> pure mempty + nameVal : typeVal : cont -> do + let (annotationVals, cont') = span isTagged cont + name <- parseSymbol' nameVal + ronType <- parseEDN typeVal + annotations <- parseList annotationVals + let field = Field{ronType, annotations, ext = ()} + fields' <- parseFields cont' + pure $ Map.insert name field fields' + [f] -> + fail $ + "field " ++ Text.unpack (renderText f) ++ " must have type" + instance FromEDN StructAnnotations where parseEDN = withNoTag . withList $ \annTaggedValues -> do annValues <- traverse unwrapTag annTaggedValues @@ -146,13 +164,6 @@ Nothing -> pure defaultStructAnnotations Just annValue -> withMap go annValue where - unwrapTag = \case - Tagged prefix tag value -> let - name = case prefix of - "" -> tag - _ -> prefix <> "/" <> tag - in pure (name, value) - NoTag _ -> fail "annotation must be a tagged value" go m = do haskellFieldPrefix <- mapGetSymbol "field_prefix" m <|> pure "" haskellFieldCaseTransform <- optional $ mapGetSymbol "field_case" m @@ -185,25 +196,81 @@ collectDeclarations :: (MonadFail m, MonadState Env m) => Schema 'Parsed -> m () collectDeclarations = traverse_ rememberDeclaration -validateTypeUses :: (MonadFail m, MonadState Env m) => Schema 'Parsed -> m () -validateTypeUses = traverse_ $ \case - DAlias Alias{target} -> validateExpr target - DEnum _ -> pure () - DOpaque _ -> pure () - DStructLww StructLww{fields} -> - for_ fields $ \(Field typeExpr) -> validateExpr typeExpr +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 where - validateName name = do - Env{userTypes} <- get + validateName name = unless (name `Map.member` userTypes || name `Map.member` prelude) - (fail $ "unknown type name " ++ Text.unpack name) + (fail $ "validateParsed: unknown type name " ++ Text.unpack name) validateExpr = \case Use name -> validateName name Apply name args -> do validateName name for_ args validateExpr + validateStruct = + traverse_ $ \Field{ronType} -> validateExpr ronType +validateResolved :: MonadFail m => Schema Resolved -> m () +validateResolved = traverse_ $ \case + DAlias _ -> pure () + DEnum _ -> pure () + DOpaque _ -> 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 + where + Field{ronType, annotations} = field + FieldAnnotations{mergeStrategy} = annotations + goAtom a = case mergeStrategy of + Nothing -> + fail' + "atom field must be declared with #ron{merge strategy}" + Just ms -> case (ms, a) of + (LWW, _) -> pure () + (Set, _) -> pure () + (Max, TAInteger) -> pure () + (Max, TAFloat) -> pure () + (Min, TAInteger) -> pure () + (Min, TAFloat) -> pure () + (Max, _) -> + fail' + "max strategy requires either integer or float\ + \ field" + (Min, _) -> + fail' + "min strategy requires either integer or float\ + \ field" + goOpaqueAtoms = case mergeStrategy of + Nothing -> + fail' + "opaque atoms field must be declared with\ + \ #ron{merge strategy}" + Just _ -> pure () + goObject = case mergeStrategy of + Nothing -> pure () + Just _ -> fail' "object field must not declared merge strategy" + fail' msg = + fail $ + Text.unpack $ structName <> "." <> fieldName <> ": " <> msg + evalSchema :: Env -> Schema 'Resolved evalSchema env = fst <$> userTypes' where Env{userTypes} = env @@ -214,14 +281,19 @@ 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 StructLww{..} -> let - fields' = - (\(Field typeExpr) -> Field $ evalType typeExpr) <$> fields - struct = StructLww{fields = fields', ..} - in (DStructLww struct, Type0 $ TObject $ TStructLww struct) + DEnum t -> (DEnum t, Type0 $ TComposite $ TEnum t) + DOpaque t -> (DOpaque t, Type0 $ TOpaque t) + DStructLww s -> + (DStructLww &&& Type0 . TObject . TStructLww) $ evalStruct s + DStructSet s -> + (DStructSet &&& Type0 . TObject . TStructSet) $ evalStruct s + evalStruct :: Struct encoding Parsed -> Struct encoding Resolved + evalStruct Struct{..} = Struct{fields = evalField <$> fields, ..} + + evalField :: Field Parsed -> Field Resolved + evalField Field{..} = Field{ronType = evalType ronType, ..} + getType :: TypeName -> RonTypeF getType typ = (prelude !? typ) @@ -256,3 +328,31 @@ _ -> fail "Expected declaration in the form\ \ (alias )" + +instance FromEDN FieldAnnotations where + parseEDN = withNoTag . withList $ \annTaggedValues -> do + annValues <- traverse unwrapTag annTaggedValues + case lookup "ron" annValues of + Nothing -> pure defaultFieldAnnotations + Just annValue -> withMap go annValue + where + go m = do + mergeStrategy <- mapGetSymbol "merge" m + pure FieldAnnotations{mergeStrategy} + +unwrapTag :: Tagged Text a -> Parser (Text, a) +unwrapTag = \case + Tagged prefix tag value -> let + name = case prefix of + "" -> tag + _ -> prefix <> "/" <> tag + in pure (name, value) + NoTag _ -> fail "annotation must be a tagged value" + +instance FromEDN MergeStrategy where + parseEDN = withSymbol' $ \case + "LWW" -> pure LWW + "max" -> pure Max + "min" -> pure Min + "set" -> pure Set + s -> fail $ "unknown merge strategy " <> show s 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 @@ -27,7 +27,8 @@ import RON.Schema as X import qualified RON.Schema.EDN as EDN import RON.Schema.TH.Common (mkGuideType, mkNameT) -import RON.Schema.TH.Struct (mkReplicatedStructLww) +import RON.Schema.TH.Struct (mkReplicatedStructLww, + mkReplicatedStructSet) import qualified RON.UUID as UUID -- | QuasiQuoter to generate Haskell types from RON-Schema @@ -48,6 +49,7 @@ DEnum e -> mkEnum e DOpaque _ -> 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 @@ -4,10 +4,13 @@ {-# LANGUAGE TemplateHaskell #-} module RON.Schema.TH.Common ( + fieldExp', + fieldPat', let1S, liftText, mkGuideType, mkNameT, + newNameT, valD, valDP, ) where @@ -15,7 +18,7 @@ import RON.Prelude import qualified Data.Text as Text -import Language.Haskell.TH (conT, normalB, varP) +import Language.Haskell.TH (Q, conT, normalB, varP) import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Syntax (liftString) @@ -23,10 +26,14 @@ import RON.Data.RGA (RGA) import RON.Data.VersionVector (VersionVector) import RON.Schema as X +import RON.Types (UUID) mkNameT :: Text -> TH.Name mkNameT = TH.mkName . Text.unpack +newNameT :: Text -> Q TH.Name +newNameT = TH.newName . Text.unpack + valD :: TH.PatQ -> TH.ExpQ -> TH.DecQ valD pat body = TH.valD pat (normalB body) [] @@ -39,17 +46,19 @@ mkGuideType :: RonType -> TH.TypeQ mkGuideType typ = case typ of TAtom atom -> case atom of - TAInteger -> [t| Int64 |] - TAString -> [t| Text |] + TAFloat -> [t| Double |] + TAInteger -> [t| Int64 |] + TAString -> [t| Text |] + TAUuid -> [t| UUID |] TComposite t -> case t of - TEnum Enum{name} -> conT $ mkNameT name - TOption u -> [t| Maybe $(mkGuideType u) |] + 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 StructLww{name} -> conT $ mkNameT name - TVersionVector -> [t| VersionVector |] + 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 @@ -62,3 +71,9 @@ let1S :: TH.PatQ -> TH.ExpQ -> TH.StmtQ let1S pat exp = TH.letS [valD pat exp] + +fieldExp' :: Text -> TH.ExpQ -> TH.Q (TH.Name, TH.Exp) +fieldExp' = TH.fieldExp . mkNameT + +fieldPat' :: Text -> TH.PatQ -> TH.FieldPatQ +fieldPat' = TH.fieldPat . mkNameT 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 @@ -1,116 +1,212 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module RON.Schema.TH.Struct (mkReplicatedStructLww) where +{- HLINT ignore "Reduce duplication" -} +module RON.Schema.TH.Struct ( + mkReplicatedStructLww, + mkReplicatedStructSet, +) where + import RON.Prelude -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, conP, conT, doE, listE, - noBindS, recC, recConE, sigD, varE, varP, +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 qualified Language.Haskell.TH as TH import Language.Haskell.TH.Syntax (liftData) import RON.Data (MonadObjectState, ObjectStateT, - Replicated (encoding), ReplicatedAsObject, getObject, - getObjectStateChunk, newObject, objectEncoding, - objectOpType) -import RON.Data.LWW (lwwType) + Replicated (encoding), + ReplicatedAsObject (Rep, getObject, newObject), + getObjectStateChunk, objectEncoding) +import RON.Data.LWW (LwwRep) import qualified RON.Data.LWW as LWW +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 (liftText, mkGuideType, mkNameT, valDP) +import RON.Schema.TH.Common (fieldExp', fieldPat', liftText, + mkGuideType, mkNameT, newNameT, valDP) import RON.Types (Object (Object), UUID) import RON.Util (Instance (Instance)) import qualified RON.UUID as UUID -data Field' = Field' +type instance XField Equipped = XFieldEquipped + +data XFieldEquipped = XFieldEquipped { haskellName :: Text , ronName :: UUID - , ronType :: RonType - , var :: TH.Name } -mkReplicatedStructLww :: StructLww 'Resolved -> TH.DecsQ -mkReplicatedStructLww StructLww{name, fields, annotations} = do - fields' <- for (Map.assocs fields) $ \(haskellName, Field{ronType}) -> - case UUID.mkName . BSC.pack $ Text.unpack haskellName of - Just ronName -> do - var <- TH.newName $ Text.unpack haskellName - pure Field'{haskellName, ronName, ronType, var} - Nothing -> fail $ - "Field name is not representable in RON: " ++ show haskellName - dataType <- mkDataType name' fields annotations - [instanceReplicated] <- mkInstanceReplicated structType - [instanceReplicatedAsObject] <- - mkInstanceReplicatedAsObject name fields' annotations - accessors <- fold <$> traverse (mkAccessors structType annotations) fields' - pure $ - dataType : instanceReplicated : instanceReplicatedAsObject : accessors +equipStruct :: Struct e Resolved -> Struct e Equipped +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 where + struct@Struct{name, fields} = equipStruct structResolved name' = mkNameT name - structType = conT name' + type' = conT name' -mkDataType - :: TH.Name -> Map Text (Field Resolved) -> StructAnnotations -> TH.DecQ -mkDataType name fields annotations = TH.dataD (TH.cxt []) name [] Nothing - [recC name - [ TH.varBangType (mkNameT $ mkHaskellFieldName annotations fieldName) $ - TH.bangType (TH.bang TH.sourceNoUnpack TH.sourceStrict) $ - mkGuideType ronType - | (fieldName, Field ronType) <- Map.assocs fields - ]] - [] +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 + where + struct@Struct{name, fields} = equipStruct structResolved + name' = mkNameT 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 + where + haskellName = mkHaskellFieldName structAnnotations schemaName + +varBangType' :: Text -> TH.TypeQ -> TH.VarBangTypeQ +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 + ]] + [] + where + name' = mkNameT name + mkInstanceReplicated :: TH.TypeQ -> TH.DecsQ -mkInstanceReplicated structType = [d| - instance Replicated $structType where +mkInstanceReplicated type' = [d| + instance Replicated $type' where encoding = objectEncoding |] -mkInstanceReplicatedAsObject - :: Text -> [Field'] -> StructAnnotations -> TH.DecsQ -mkInstanceReplicatedAsObject name fields annotations = do - ops <- TH.newName "ops" - let fieldsToUnpack = - [ bindS (varP var) - [| LWW.viewField $(liftData ronName) $(varE ops) |] - | Field'{var, ronName} <- fields +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 + | 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 + | var <- toList vars + ] let getObjectImpl = doE $ bindS (varP ops) [| getObjectStateChunk |] - : fieldsToUnpack + : unpackFields ++ [noBindS [| pure $consE |]] - [d| instance ReplicatedAsObject $structType where - objectOpType = lwwType - newObject $consP = Object <$> LWW.newObject $fieldsToPack - getObject = - errorContext $(liftText errCtx) $getObjectImpl + [d| instance ReplicatedAsObject $type' where + type Rep $type' = LwwRep + newObject $consP = Object <$> LWW.newStruct $packFields + getObject = errorContext $(liftText errCtx) $getObjectImpl + -- rempty = $remptyImpl |] where name' = mkNameT name - structType = conT name' - fieldsToPack = listE - [ [| ($(liftData ronName), Instance $(varE var)) |] - | Field'{var, ronName} <- fields - ] - errCtx = "getObject @" <> name <> ":\n" - consE = recConE name' - [ pure (fieldName, VarE var) - | Field'{haskellName, var} <- fields - , let fieldName = mkNameT $ mkHaskellFieldName annotations haskellName - ] - consP = conP name' [varP var | Field'{var} <- fields] + type' = conT name' + errCtx = "getObject @" <> 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 + | 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 + 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 + | 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 = _ + |] + where + name' = mkNameT name + type' = conT name' + errCtx = "getObject @" <> name + mkHaskellFieldName :: StructAnnotations -> Text -> Text mkHaskellFieldName annotations base = prefix <> base' where StructAnnotations @@ -124,36 +220,82 @@ Nothing -> base Just (b, baseTail) -> Text.cons (toTitle b) baseTail -mkAccessors :: TH.TypeQ -> StructAnnotations -> Field' -> TH.DecsQ -mkAccessors structType annotations field' = do - a <- varT <$> TH.newName "a" - m <- varT <$> TH.newName "m" +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 $structType $m) - => $fieldGuideType -> $m () - |] - , valDP assign [| LWW.assignField $(liftData ronName) |] + (ReplicaClock $m, MonadE $m, MonadObjectState $type' $m) + => Maybe $guideType -> $m () |] + , valDP assign [| LWW.assignField $ronName' |] ] readF = [ sigD read [t| - (MonadE $m, MonadObjectState $structType $m) - => $m $fieldGuideType - |] - , valDP read [| LWW.readField $(liftData ronName) |] + (MonadE $m, MonadObjectState $type' $m) + => $m (Maybe $guideType) |] + , valDP read [| LWW.readField $ronName' |] ] zoomF = [ sigD zoom [t| MonadE $m - => ObjectStateT $(mkGuideType ronType) $m $a - -> ObjectStateT $structType $m $a - |] - , valDP zoom [| LWW.zoomField $(liftData ronName) |] + => ObjectStateT $guideType $m $a + -> ObjectStateT $type' $m $a |] + , valDP zoom [| LWW.zoomField $ronName' |] ] sequenceA $ assignF ++ readF ++ zoomF where - Field'{haskellName, ronName, ronType} = field' - fieldGuideType = mkGuideType ronType - assign = mkNameT $ mkHaskellFieldName annotations haskellName <> "_assign" - read = mkNameT $ mkHaskellFieldName annotations haskellName <> "_read" - zoom = mkNameT $ mkHaskellFieldName annotations haskellName <> "_zoom" + Field{ronType, ext = XFieldEquipped{haskellName, ronName}} = field + ronName' = liftData ronName + type' = conT name' + guideType = mkGuideType ronType + assign = mkNameT $ haskellName <> "_assign" + 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 + where + Field{ronType, annotations = FieldAnnotations{mergeStrategy}, ext} = field + XFieldEquipped{haskellName, ronName} = ext + ronName' = liftData ronName + type' = conT name' + guideType = mkGuideType ronType + assign = mkNameT $ haskellName <> "_assign" + read = mkNameT $ haskellName <> "_read" + 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 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.7 +version: 0.8 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database