ron-schema 0.7 → 0.8
raw patch · 7 files changed
+499/−187 lines, 7 files
Files
- CHANGELOG.md +20/−2
- lib/RON/Schema.hs +60/−25
- lib/RON/Schema/EDN.hs +159/−59
- lib/RON/Schema/TH.hs +3/−1
- lib/RON/Schema/TH/Common.hs +25/−10
- lib/RON/Schema/TH/Struct.hs +231/−89
- ron-schema.cabal +1/−1
CHANGELOG.md view
@@ -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
lib/RON/Schema.hs view
@@ -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)
lib/RON/Schema/EDN.hs view
@@ -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 <name:symbol> <annotations>... <fields>...)"+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+ ++ " <name:symbol> <annotations>... <fields>...)" + 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 <name:symbol> <target:type>)"++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
lib/RON/Schema/TH.hs view
@@ -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
lib/RON/Schema/TH/Common.hs view
@@ -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
lib/RON/Schema/TH/Struct.hs view
@@ -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
ron-schema.cabal view
@@ -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