ron-schema 0.6 → 0.7
raw patch · 9 files changed
+370/−516 lines, 9 files
Files
- CHANGELOG.md +21/−1
- lib/Data/EDN/Extra.hs +2/−0
- lib/RON/Schema.hs +29/−18
- lib/RON/Schema/EDN.hs +67/−38
- lib/RON/Schema/TH.hs +23/−243
- lib/RON/Schema/TH/Common.hs +64/−0
- lib/RON/Schema/TH/Struct.hs +159/−0
- prelude/Prelude.hs +0/−189
- ron-schema.cabal +5/−27
CHANGELOG.md view
@@ -7,6 +7,25 @@ ## [Unreleased] +## [0.7] - 2019-07-26+### Added+- `alias` declaration.+- `ORSet.Map` type.++### Changed+- Renamed `Boole` -> `Bool` due to tradition.+- `ORSet` don't generate `ObjectORSet` wrapper since `ORSet` now manages+ objects too.+- Now `ObjectState` keeps a typed reference to an object with state frame+ attached,+ and `Object` is just a type UUID --+ a typed reference to an object in a state frame passed in+ `MonadObjectState` context.+ Object is now passed as an explicit argument.++### Removed+- Concept of view type. Maybe will return later.+ ## [0.6] - 2019-04-25 ### Added - Schema language: `RGA` type.@@ -95,7 +114,8 @@ - RON-Schema - RON-Schema TemplateHaskell code generator -[Unreleased]: https://github.com/ff-notes/ff/compare/ron-schema-0.6...HEAD+[Unreleased]: https://github.com/ff-notes/ron/compare/v0.7...HEAD+[0.7]: https://github.com/ff-notes/ron/compare/v0.6...v0.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/Data/EDN/Extra.hs view
@@ -10,6 +10,8 @@ withSymbol', ) where +import RON.Prelude+ import qualified Data.EDN.AST.Lexer as EdnAst import qualified Data.EDN.AST.Parser as EdnAst import qualified Data.EDN.AST.Types as EdnAst
lib/RON/Schema.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-}@@ -6,6 +7,7 @@ {-# LANGUAGE UndecidableInstances #-} module RON.Schema (+ Alias (..), CaseTransform (..), Declaration (..), Field (..),@@ -30,6 +32,8 @@ opaqueObject, ) where +import RON.Prelude+ import qualified Data.Text as Text data Stage = Parsed | Resolved@@ -54,69 +58,76 @@ | TEnum TEnum deriving (Show) -data TEnum = Enum {enumName :: Text, enumItems :: [Text]}+data TEnum = Enum {name :: Text, items :: [Text]} deriving (Show) data TObject = TORSet RonType+ | TORSetMap RonType RonType | TRga RonType | TStructLww (StructLww 'Resolved) | TVersionVector deriving (Show) data StructLww stage = StructLww- { structName :: Text- , structFields :: Map Text (Field stage)- , structAnnotations :: StructAnnotations+ { name :: Text+ , fields :: Map Text (Field stage)+ , annotations :: StructAnnotations } deriving instance Show (UseType stage) => Show (StructLww stage) data StructAnnotations = StructAnnotations- { saHaskellFieldPrefix :: Text- , saHaskellFieldCaseTransform :: Maybe CaseTransform+ { haskellFieldPrefix :: Text+ , haskellFieldCaseTransform :: Maybe CaseTransform } deriving (Show) defaultStructAnnotations :: StructAnnotations defaultStructAnnotations = StructAnnotations- {saHaskellFieldPrefix = Text.empty, saHaskellFieldCaseTransform = Nothing}+ {haskellFieldPrefix = Text.empty, haskellFieldCaseTransform = Nothing} data CaseTransform = TitleCase deriving (Show) -newtype Field stage = Field{fieldType :: UseType stage}+newtype Field stage = Field{ronType :: UseType stage} deriving instance Show (UseType stage) => Show (Field stage) type family UseType (stage :: Stage) where UseType 'Parsed = TypeExpr UseType 'Resolved = RonType -data Declaration stage =- DEnum TEnum | DOpaque Opaque | DStructLww (StructLww stage)+data Declaration stage+ = DAlias (Alias stage)+ | DEnum TEnum+ | DOpaque Opaque+ | DStructLww (StructLww stage) deriving instance Show (UseType stage) => Show (Declaration stage) type family Schema (stage :: Stage) where Schema 'Parsed = [Declaration 'Parsed] Schema 'Resolved = Map TypeName (Declaration 'Resolved) -newtype OpaqueAnnotations = OpaqueAnnotations{oaHaskellType :: Maybe Text}+newtype OpaqueAnnotations = OpaqueAnnotations{haskellType :: Maybe Text} deriving (Show) defaultOpaqueAnnotations :: OpaqueAnnotations-defaultOpaqueAnnotations = OpaqueAnnotations{oaHaskellType = Nothing}+defaultOpaqueAnnotations = OpaqueAnnotations{haskellType = Nothing} data Opaque = Opaque- { opaqueIsObject :: Bool- , opaqueName :: Text- , opaqueAnnotations :: OpaqueAnnotations+ { isObject :: Bool+ , name :: Text+ , annotations :: OpaqueAnnotations } deriving (Show) opaqueObject :: Text -> OpaqueAnnotations -> RonType-opaqueObject name = TOpaque . Opaque True name+opaqueObject tyname = TOpaque . Opaque True tyname opaqueAtoms :: Text -> OpaqueAnnotations -> RonType-opaqueAtoms name = TOpaque . Opaque False name+opaqueAtoms tyname = TOpaque . Opaque False tyname opaqueAtoms_ :: Text -> RonType-opaqueAtoms_ name = TOpaque $ Opaque False name defaultOpaqueAnnotations+opaqueAtoms_ tyname = TOpaque $ Opaque False tyname defaultOpaqueAnnotations++data Alias stage = Alias{name :: Text, target :: UseType stage}+deriving instance Show (UseType stage) => Show (Alias stage)
lib/RON/Schema/EDN.hs view
@@ -10,6 +10,8 @@ module RON.Schema.EDN (readSchema) where +import RON.Prelude+ import Data.EDN (FromEDN, Tagged (NoTag, Tagged), Value (List, Symbol), mapGetSymbol, parseEDN, renderText, unexpected, withList, withMap, withNoTag)@@ -33,13 +35,15 @@ newtype Env = Env{userTypes :: Map TypeName (Declaration 'Parsed)} deriving (Show) -data RonTypeF = Type0 RonType | Type1 (RonType -> RonType)+data RonTypeF+ = Type0 RonType+ | Type1 (RonType -> RonType)+ | Type2 (RonType -> RonType -> RonType) prelude :: Map TypeName RonTypeF prelude = Map.fromList- [ ("Boole",- Type0 $- opaqueAtoms "Boole" OpaqueAnnotations{oaHaskellType = Just "Bool"})+ [ ("Bool",+ Type0 $ opaqueAtoms "Bool" OpaqueAnnotations{haskellType = Just "Bool"}) , ("Day", Type0 day) , ("Integer", Type0 $ TAtom TAInteger) , ("RgaString", Type0 $ TObject $ TRga char)@@ -47,15 +51,17 @@ , ("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{oaHaskellType = Just "Char"}+ char = opaqueAtoms "Char" OpaqueAnnotations{haskellType = Just "Char"} day = opaqueAtoms_ "Day" 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@@ -64,24 +70,27 @@ instance FromEDN TEnum where parseEDN = withNoTag . withList $ \case- name : items -> Enum- <$> parseSymbol' name- <*> traverse parseSymbol' items+ nameSym : itemSyms -> do+ name <- parseSymbol' nameSym+ items <- traverse parseSymbol' itemSyms+ pure Enum{name, items} [] -> fail "Expected declaration in the form\ \ (enum <name:symbol> <item:symbol>...)" instance FromEDN Opaque where parseEDN = withNoTag . withList $ \case- kind : name : annotations ->+ kind : nameSym : annotationVals -> (`withSymbol'` kind) $ \case "atoms" -> go False "object" -> go True _ -> fail "opaque kind must be either atoms or object"- where- go isObject =- Opaque isObject <$> parseSymbol' name <*> parseAnnotations- parseAnnotations = case annotations of+ 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" _ -> fail@@ -101,18 +110,19 @@ declarationName :: Declaration stage -> TypeName declarationName = \case- DEnum Enum {enumName } -> enumName- DOpaque Opaque {opaqueName} -> opaqueName- DStructLww StructLww{structName} -> structName+ DAlias Alias {name} -> name+ DEnum Enum {name} -> name+ DOpaque Opaque {name} -> name+ DStructLww StructLww{name} -> name instance FromEDN (StructLww 'Parsed) where parseEDN = withNoTag . withList $ \case- name : body -> do- let (annotations, fields) = span isTagged body- StructLww- <$> parseSymbol' name- <*> parseFields fields- <*> parseList annotations+ 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>...)"@@ -126,7 +136,8 @@ typ <- parseEDN typeAsTagged Map.insert name (Field typ) <$> parseFields cont [f] ->- fail $ "field " ++ Text.unpack (renderText f) ++ " must have type"+ fail $+ "field " ++ Text.unpack (renderText f) ++ " must have type" instance FromEDN StructAnnotations where parseEDN = withNoTag . withList $ \annTaggedValues -> do@@ -143,10 +154,10 @@ in pure (name, value) NoTag _ -> fail "annotation must be a tagged value" go m = do- saHaskellFieldPrefix <- mapGetSymbol "field_prefix" m <|> pure ""- saHaskellFieldCaseTransform <-- optional $ mapGetSymbol "field_case" m- pure StructAnnotations{..}+ haskellFieldPrefix <- mapGetSymbol "field_prefix" m <|> pure ""+ haskellFieldCaseTransform <- optional $ mapGetSymbol "field_case" m+ pure+ StructAnnotations{haskellFieldPrefix, haskellFieldCaseTransform} instance FromEDN CaseTransform where parseEDN = withSymbol' $ \case@@ -176,10 +187,11 @@ validateTypeUses :: (MonadFail m, MonadState Env m) => Schema 'Parsed -> m () validateTypeUses = traverse_ $ \case- DEnum _ -> pure ()- DOpaque _ -> pure ()- DStructLww StructLww{structFields} ->- for_ structFields $ \(Field typeExpr) -> validateExpr typeExpr+ DAlias Alias{target} -> validateExpr target+ DEnum _ -> pure ()+ DOpaque _ -> pure ()+ DStructLww StructLww{fields} ->+ for_ fields $ \(Field typeExpr) -> validateExpr typeExpr where validateName name = do Env{userTypes} <- get@@ -199,13 +211,15 @@ evalDeclaration :: Declaration 'Parsed -> (Declaration 'Resolved, RonTypeF) evalDeclaration = \case+ 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- structFields' =- (\(Field typeExpr) -> Field $ evalType typeExpr)- <$> structFields- struct = StructLww{structFields = structFields', ..}+ fields' =+ (\(Field typeExpr) -> Field $ evalType typeExpr) <$> fields+ struct = StructLww{fields = fields', ..} in (DStructLww struct, Type0 $ TObject $ TStructLww struct) getType :: TypeName -> RonTypeF@@ -215,9 +229,9 @@ ?: error "type is validated but not found" evalType = \case- Use typ -> case getType typ of- Type0 t0 -> t0- Type1 _ -> error "type arity mismatch"+ Use typ -> case getType typ of+ Type0 t0 -> t0+ _ -> error "type arity mismatch" Apply typ args -> applyType typ $ evalType <$> args applyType name args = case getType name of@@ -227,3 +241,18 @@ _ -> error $ Text.unpack name ++ " expects 1 argument, got " ++ show (length args)+ Type2 t2 -> case args of+ [a, b] -> t2 a b+ _ -> error+ $ Text.unpack name ++ " expects 2 arguments, got "+ ++ show (length args)++instance FromEDN (Alias 'Parsed) where+ parseEDN = withNoTag . withList $ \case+ [nameSym, targetVal] -> do+ name <- parseSymbol' nameSym+ target <- parseEDN targetVal+ pure Alias{name, target}+ _ -> fail+ "Expected declaration in the form\+ \ (alias <name:symbol> <target:type>)"
lib/RON/Schema/TH.hs view
@@ -11,36 +11,23 @@ mkReplicated', ) where -import Prelude hiding (lift)+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 qualified Data.Text.Encoding as Text-import Language.Haskell.TH (Exp (VarE), Loc (Loc), bindS, conE, conP,- conT, doE, lamCaseE, listE, noBindS,- normalB, recC, recConE, sigD, varE, varP,- varT)+import Language.Haskell.TH (Loc (Loc), conE, conP, conT, lamCaseE,+ normalB) import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter), quoteDec, quoteExp, quotePat, quoteType)-import Language.Haskell.TH.Syntax (dataToPatQ, liftData, liftString)+import Language.Haskell.TH.Syntax (dataToPatQ, liftData) -import RON.Data (Replicated (..), ReplicatedAsObject (..),- ReplicatedAsPayload (..), getObjectStateChunk,- objectEncoding)-import RON.Data.LWW (lwwType)-import qualified RON.Data.LWW as LWW-import RON.Data.ORSet (ORSet (..), ObjectORSet (..))-import RON.Data.RGA (RGA (..))-import RON.Data.VersionVector (VersionVector)-import RON.Error (MonadE, errorContext, throwErrorString)-import RON.Event (ReplicaClock)+import RON.Data (Replicated (..), ReplicatedAsPayload (..))+import RON.Error (throwErrorString) import RON.Schema as X import qualified RON.Schema.EDN as EDN-import RON.Types (Object (Object), UUID)-import RON.Util (Instance (Instance))+import RON.Schema.TH.Common (mkGuideType, mkNameT)+import RON.Schema.TH.Struct (mkReplicatedStructLww) import qualified RON.UUID as UUID -- | QuasiQuoter to generate Haskell types from RON-Schema@@ -54,224 +41,17 @@ mkReplicated' schema -- | Generate Haskell types from RON-Schema-mkReplicated' :: HasCallStack => Schema 'Resolved -> TH.DecsQ+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 --- | Type-directing newtype-fieldWrapperC :: RonType -> Maybe TH.Name-fieldWrapperC typ = case typ of- TAtom _ -> Nothing- TComposite _ -> Nothing- TObject t -> case t of- TORSet a- | isObjectType a -> Just 'ObjectORSet- | otherwise -> Just 'ORSet- TRga _ -> Just 'RGA- TStructLww _ -> Nothing- TVersionVector -> Nothing- TOpaque _ -> Nothing--mkGuideType :: RonType -> TH.TypeQ-mkGuideType typ = case typ of- TAtom _ -> view- TComposite _ -> view- TObject t -> case t of- TORSet a- | isObjectType a -> wrap ''ObjectORSet a- | otherwise -> wrap ''ORSet a- TRga a -> wrap ''RGA a- TStructLww _ -> view- TVersionVector -> view- TOpaque _ -> view- where- view = mkViewType typ- wrap w item = [t| $(conT w) $(mkGuideType item) |]--data Field' = Field'- { field'Name :: Text- , field'RonName :: UUID- , field'Type :: RonType- , field'Var :: TH.Name- }--mkReplicatedStructLww :: HasCallStack => StructLww 'Resolved -> TH.DecsQ-mkReplicatedStructLww struct = do- fields <- for (Map.assocs structFields) $ \(field'Name, Field{fieldType}) ->- case UUID.mkName . BSC.pack $ Text.unpack field'Name of- Just field'RonName -> do- field'Var <- TH.newName $ Text.unpack field'Name- pure Field'{field'Type = fieldType, ..}- Nothing -> fail $- "Field name is not representable in RON: " ++ show field'Name- dataType <- mkDataType- [instanceReplicated] <- mkInstanceReplicated- [instanceReplicatedAsObject] <- mkInstanceReplicatedAsObject fields- accessors <- fold <$> traverse mkAccessors fields- pure $- dataType : instanceReplicated : instanceReplicatedAsObject : accessors- where-- StructLww{structName, structFields, structAnnotations} = struct-- StructAnnotations{saHaskellFieldPrefix, saHaskellFieldCaseTransform} =- structAnnotations-- name = mkNameT structName-- structT = conT name-- objectT = [t| Object $structT |]-- mkDataType = TH.dataD (TH.cxt []) name [] Nothing- [recC name- [ TH.varBangType (mkNameT $ mkHaskellFieldName fieldName) $- TH.bangType (TH.bang TH.sourceNoUnpack TH.sourceStrict) viewType- | (fieldName, Field fieldType) <- Map.assocs structFields- , let viewType = mkViewType fieldType- ]]- []-- mkInstanceReplicated = [d|- instance Replicated $structT where- encoding = objectEncoding- |]-- mkInstanceReplicatedAsObject fields = do- obj <- TH.newName "obj"- frame <- TH.newName "frame"- ops <- TH.newName "ops"- let fieldsToUnpack =- [ bindS var [|- LWW.viewField- $(liftData field'RonName) $(varE ops) $(varE frame)- |]- | Field'{field'Type, field'Var, field'RonName} <- fields- , let- fieldP = varP field'Var- var = maybe fieldP (\w -> conP w [fieldP]) $- fieldWrapperC field'Type- ]- let getObjectImpl = doE- $ let1S [p| Object _ $(varP frame) |] (varE obj)- : bindS (varP ops) [| getObjectStateChunk $(varE obj) |]- : fieldsToUnpack- ++ [noBindS [| pure $consE |]]- [d| instance ReplicatedAsObject $structT where- objectOpType = lwwType- newObject $consP = LWW.newObject $fieldsToPack- getObject $(varP obj) =- errorContext $(liftText errCtx) $getObjectImpl- |]- where- fieldsToPack = listE- [ [| ($(liftData field'RonName), Instance $var) |]- | Field'{field'Type, field'Var, field'RonName} <- fields- , let- fieldVarE = varE field'Var- var = case fieldWrapperC field'Type of- Nothing -> fieldVarE- Just con -> [| $(conE con) $fieldVarE |]- ]- errCtx = "getObject @" <> structName <> ":\n"- consE = recConE name- [ pure (fieldName, VarE field'Var)- | Field'{field'Name, field'Var} <- fields- , let fieldName = mkNameT $ mkHaskellFieldName field'Name- ]- consP = conP name [varP field'Var | Field'{field'Var} <- fields]-- mkHaskellFieldName base = saHaskellFieldPrefix <> base' where- base' = case saHaskellFieldCaseTransform of- Nothing -> base- Just TitleCase -> case Text.uncons base of- Nothing -> base- Just (b, baseTail) -> Text.cons (toTitle b) baseTail-- mkAccessors field' = do- a <- varT <$> TH.newName "a"- m <- varT <$> TH.newName "m"- let assignF =- [ sigD assign [t|- (ReplicaClock $m, MonadE $m, MonadState $objectT $m)- => $fieldViewType -> $m ()- |]- , valDP assign- [| LWW.assignField $(liftData field'RonName) . $guide |]- ]- readF =- [ sigD read [t|- (MonadE $m, MonadState $objectT $m) => $m $fieldViewType- |]- , valDP read- [| $unguide <$> LWW.readField $(liftData field'RonName) |]- ]- zoomF =- [ sigD zoom [t|- MonadE $m- => StateT (Object $(mkGuideType field'Type)) $m $a- -> StateT $objectT $m $a- |]- , valDP zoom [| LWW.zoomField $(liftData field'RonName) |]- ]- sequenceA $ assignF ++ readF ++ zoomF- where- Field'{field'Name, field'RonName, field'Type} = field'- fieldViewType = mkViewType field'Type- assign = mkNameT $ mkHaskellFieldName field'Name <> "_assign"- read = mkNameT $ mkHaskellFieldName field'Name <> "_read"- zoom = mkNameT $ mkHaskellFieldName field'Name <> "_zoom"- guidedX = case fieldWrapperC field'Type of- Just w -> conP w [x]- Nothing -> x- where- x = varP $ TH.mkName "x"- unguide = [| \ $guidedX -> x |]- guide = case fieldWrapperC field'Type of- Just w -> conE w- Nothing -> [| identity |]--mkNameT :: Text -> TH.Name-mkNameT = TH.mkName . Text.unpack--mkViewType :: HasCallStack => RonType -> TH.TypeQ-mkViewType = \case- TAtom atom -> case atom of- TAInteger -> [t| Int64 |]- TAString -> [t| Text |]- TComposite t -> case t of- TEnum Enum{enumName} -> conT $ mkNameT enumName- TOption u -> [t| Maybe $(mkViewType u) |]- TObject t -> case t of- TORSet item -> wrapList item- TRga item -> wrapList item- TStructLww StructLww{structName} -> conT $ mkNameT structName- TVersionVector -> [t| VersionVector |]- TOpaque Opaque{opaqueName, opaqueAnnotations} -> let- OpaqueAnnotations{oaHaskellType} = opaqueAnnotations- in conT $ mkNameT $ fromMaybe opaqueName oaHaskellType- where- wrapList a = [t| [$(mkViewType a)] |]--valD :: TH.PatQ -> TH.ExpQ -> TH.DecQ-valD pat body = TH.valD pat (normalB body) []--valDP :: TH.Name -> TH.ExpQ -> TH.DecQ-valDP = valD . varP--isObjectType :: RonType -> Bool-isObjectType = \case- TAtom _ -> False- TComposite _ -> False- TObject _ -> True- TOpaque Opaque{opaqueIsObject} -> opaqueIsObject- mkEnum :: TEnum -> TH.DecsQ-mkEnum Enum{enumName, enumItems} = do- itemsUuids <- for enumItems $ \item -> do+mkEnum Enum{name, items} = do+ itemsUuids <- for items $ \item -> do uuid <- UUID.mkName $ Text.encodeUtf8 item pure (mkNameT item, uuid) dataType <- mkDataType@@ -281,10 +61,10 @@ where - typeName = conT $ mkNameT enumName+ typeName = conT $ mkNameT name - mkDataType = TH.dataD (TH.cxt []) (mkNameT enumName) [] Nothing- [TH.normalC (mkNameT item) [] | item <- enumItems] []+ mkDataType = TH.dataD (TH.cxt []) (mkNameT name) [] Nothing+ [TH.normalC (mkNameT item) [] | item <- items] [] mkInstanceReplicated = [d| instance Replicated $typeName where@@ -298,10 +78,12 @@ |] where toUuid = lamCaseE- [match (conP name []) (liftData uuid) | (name, uuid) <- itemsUuids]+ [ match (conP itemName []) (liftData uuid)+ | (itemName, uuid) <- itemsUuids+ ] fromUuid = lamCaseE- $ [ match (liftDataP uuid) [| pure $(conE name) |]- | (name, uuid) <- itemsUuids+ $ [ match (liftDataP uuid) [| pure $(conE itemName) |]+ | (itemName, uuid) <- itemsUuids ] ++ [match TH.wildP@@ -309,8 +91,6 @@ liftDataP = dataToPatQ $ const Nothing match pat body = TH.match pat (normalB body) [] -liftText :: Text -> TH.ExpQ-liftText t = [| Text.pack $(liftString $ Text.unpack t) |]--let1S :: TH.PatQ -> TH.ExpQ -> TH.StmtQ-let1S pat exp = TH.letS [valD pat exp]+mkAlias :: Alias Resolved -> TH.DecsQ+mkAlias Alias{name, target} =+ (:[]) <$> TH.tySynD (mkNameT name) [] (mkGuideType target)
+ lib/RON/Schema/TH/Common.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-}++module RON.Schema.TH.Common (+ let1S,+ liftText,+ mkGuideType,+ mkNameT,+ valD,+ valDP,+) where++import RON.Prelude++import qualified Data.Text as Text+import Language.Haskell.TH (conT, normalB, varP)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax (liftString)++import RON.Data.ORSet (ORSet, ORSetMap)+import RON.Data.RGA (RGA)+import RON.Data.VersionVector (VersionVector)+import RON.Schema as X++mkNameT :: Text -> TH.Name+mkNameT = TH.mkName . Text.unpack++valD :: TH.PatQ -> TH.ExpQ -> TH.DecQ+valD pat body = TH.valD pat (normalB body) []++valDP :: TH.Name -> TH.ExpQ -> TH.DecQ+valDP = valD . varP++-- | Guide type is the type which has an instance of 'Replicated'.+-- Different guide types may have same user type, or, from the other side,+-- a user type may be replicated different ways, with different guide types.+mkGuideType :: RonType -> TH.TypeQ+mkGuideType typ = case typ of+ TAtom atom -> case atom of+ TAInteger -> [t| Int64 |]+ TAString -> [t| Text |]+ TComposite t -> case t of+ TEnum Enum{name} -> conT $ mkNameT name+ TOption u -> [t| Maybe $(mkGuideType u) |]+ 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 |]+ TOpaque Opaque{name, annotations} -> let+ OpaqueAnnotations{haskellType} = annotations+ in conT $ mkNameT $ fromMaybe name haskellType+ where+ wrap w a = [t| $(conT w) $(mkGuideType a) |]+ wrap2 w a b = [t| $(conT w) $(mkGuideType a) $(mkGuideType b) |]++liftText :: Text -> TH.ExpQ+liftText t = [| Text.pack $(liftString $ Text.unpack t) |]++let1S :: TH.PatQ -> TH.ExpQ -> TH.StmtQ+let1S pat exp = TH.letS [valD pat exp]
+ lib/RON/Schema/TH/Struct.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module RON.Schema.TH.Struct (mkReplicatedStructLww) 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,+ 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)+import qualified RON.Data.LWW as LWW+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.Types (Object (Object), UUID)+import RON.Util (Instance (Instance))+import qualified RON.UUID as UUID++data Field' = Field'+ { 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+ where+ name' = mkNameT name+ structType = 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+ ]]+ []++mkInstanceReplicated :: TH.TypeQ -> TH.DecsQ+mkInstanceReplicated structType = [d|+ instance Replicated $structType 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+ ]+ let getObjectImpl = doE+ $ bindS (varP ops) [| getObjectStateChunk |]+ : fieldsToUnpack+ ++ [noBindS [| pure $consE |]]+ [d| instance ReplicatedAsObject $structType where+ objectOpType = lwwType+ newObject $consP = Object <$> LWW.newObject $fieldsToPack+ getObject =+ errorContext $(liftText errCtx) $getObjectImpl+ |]+ 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]++mkHaskellFieldName :: StructAnnotations -> Text -> Text+mkHaskellFieldName annotations base = prefix <> base' where+ StructAnnotations+ { 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++mkAccessors :: TH.TypeQ -> StructAnnotations -> Field' -> TH.DecsQ+mkAccessors structType annotations field' = do+ a <- varT <$> TH.newName "a"+ m <- varT <$> TH.newName "m"+ let assignF =+ [ sigD assign [t|+ (ReplicaClock $m, MonadE $m, MonadObjectState $structType $m)+ => $fieldGuideType -> $m ()+ |]+ , valDP assign [| LWW.assignField $(liftData ronName) |]+ ]+ readF =+ [ sigD read [t|+ (MonadE $m, MonadObjectState $structType $m)+ => $m $fieldGuideType+ |]+ , valDP read [| LWW.readField $(liftData ronName) |]+ ]+ zoomF =+ [ sigD zoom [t|+ MonadE $m+ => ObjectStateT $(mkGuideType ronType) $m $a+ -> ObjectStateT $structType $m $a+ |]+ , valDP zoom [| LWW.zoomField $(liftData 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"
− prelude/Prelude.hs
@@ -1,189 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}--module Prelude (- module X,- fmapL,- foldr1,- headMay,- identity,- lastDef,- maximumDef,- maxOn,- minOn,- note,- replicateM2,- replicateM3,- show,- whenJust,- (!!),- (?:),-) where---- base-import Control.Applicative as X (Alternative, Applicative, liftA2,- many, optional, pure, some, (*>),- (<*), (<*>), (<|>))-import Control.Exception as X (Exception, catch, evaluate, throwIO)-import Control.Monad as X (Monad, filterM, guard, unless, void, when,- (<=<), (=<<), (>=>), (>>=))-import Control.Monad.Fail as X (MonadFail, fail)-import Control.Monad.IO.Class as X (MonadIO, liftIO)-import Data.Bifunctor as X (bimap)-import Data.Bool as X (Bool (False, True), not, otherwise, (&&), (||))-import Data.Char as X (Char, chr, ord, toLower, toUpper)-import Data.Coerce as X (Coercible, coerce)-import Data.Data as X (Data)-import Data.Either as X (Either (Left, Right), either)-import Data.Eq as X (Eq, (/=), (==))-import Data.Foldable as X (Foldable, and, asum, fold, foldMap, foldl',- foldr, for_, length, minimumBy, null, or,- toList, traverse_)-import Data.Function as X (const, flip, on, ($), (.))-import Data.Functor as X (Functor, fmap, ($>), (<$), (<$>))-import Data.Functor.Identity as X (Identity)-import Data.Int as X (Int, Int16, Int32, Int64, Int8)-import Data.IORef as X (IORef, atomicModifyIORef', newIORef,- readIORef, writeIORef)-import Data.List as X (drop, filter, genericLength, intercalate,- isPrefixOf, isSuffixOf, lookup, map, partition,- repeat, replicate, sortBy, sortOn, span,- splitAt, take, takeWhile, unlines, unwords,- zip, (++))-import Data.List.NonEmpty as X (NonEmpty ((:|)), nonEmpty)-import Data.Maybe as X (Maybe (Just, Nothing), catMaybes, fromMaybe,- listToMaybe, maybe, maybeToList)-import Data.Monoid as X (Last (Last), Monoid, mempty)-import Data.Ord as X (Down (Down), Ord, Ordering (EQ, GT, LT),- compare, comparing, max, min, (<), (<=), (>),- (>=))-import Data.Ratio as X ((%))-import Data.Semigroup as X (Semigroup, sconcat, (<>))-import Data.String as X (String)-import Data.Traversable as X (for, sequence, sequenceA, traverse)-import Data.Tuple as X (fst, snd, uncurry)-import Data.Typeable as X (Typeable)-import Data.Word as X (Word, Word16, Word32, Word64, Word8)-import GHC.Enum as X (Bounded, Enum, fromEnum, maxBound, minBound,- pred, succ, toEnum)-import GHC.Err as X (error, undefined)-import GHC.Exts as X (Double)-import GHC.Generics as X (Generic)-import GHC.Integer as X (Integer)-import GHC.Num as X (Num, negate, subtract, (*), (+), (-))-import GHC.Real as X (Integral, fromIntegral, mod, realToFrac, round,- (^), (^^))-import GHC.Stack as X (HasCallStack)-import System.IO as X (FilePath, IO)-import Text.Show as X (Show)--#ifdef VERSION_bytestring-import Data.ByteString as X (ByteString)-#endif--#ifdef VERSION_containers-import Data.Map.Strict as X (Map)-#endif--#ifdef VERSION_deepseq-import Control.DeepSeq as X (NFData, force)-#endif--#ifdef VERSION_filepath-import System.FilePath as X ((</>))-#endif--#ifdef VERSION_hashable-import Data.Hashable as X (Hashable, hash)-#endif--#ifdef VERSION_mtl-import Control.Monad.Except as X (ExceptT, MonadError, catchError,- liftEither, runExceptT, throwError)-import Control.Monad.Reader as X (ReaderT (ReaderT), ask, reader,- runReaderT)-import Control.Monad.State.Strict as X (MonadState, State, StateT,- evalState, evalStateT,- execStateT, get, gets,- modify', put, runState,- runStateT, state)-import Control.Monad.Trans as X (MonadTrans, lift)-import Control.Monad.Writer.Strict as X (MonadWriter, WriterT,- runWriterT, tell)-#endif--#ifdef VERSION_text-import Data.Text as X (Text)-#endif--#ifdef VERSION_time-import Data.Time as X (UTCTime)-#endif--#ifdef VERSION_unordered_containers-import Data.HashMap.Strict as X (HashMap)-#endif------------------------------------------------------------------------------------import qualified Data.Foldable-import Data.List (last, maximum)-import Data.String (IsString, fromString)-import qualified Text.Show--fmapL :: (a -> b) -> Either a c -> Either b c-fmapL f = either (Left . f) Right--foldr1 :: (a -> a -> a) -> NonEmpty a -> a-foldr1 = Data.Foldable.foldr1--headMay :: [a] -> Maybe a-headMay = \case- [] -> Nothing- a:_ -> Just a--identity :: a -> a-identity x = x--lastDef :: a -> [a] -> a-lastDef def = list' def last--list' :: b -> ([a] -> b) -> [a] -> b-list' onEmpty onNonEmpty = \case- [] -> onEmpty- xs -> onNonEmpty xs--maximumDef :: Ord a => a -> [a] -> a-maximumDef def = list' def maximum--maxOn :: Ord b => (a -> b) -> a -> a -> a-maxOn f x y = if f x < f y then y else x--minOn :: Ord b => (a -> b) -> a -> a -> a-minOn f x y = if f x < f y then x else y--note :: e -> Maybe a -> Either e a-note e = maybe (Left e) Right--replicateM2 :: Applicative m => m a -> m (a, a)-replicateM2 ma = (,) <$> ma <*> ma--replicateM3 :: Applicative m => m a -> m (a, a, a)-replicateM3 ma = (,,) <$> ma <*> ma <*> ma--show :: (Show a, IsString s) => a -> s-show = fromString . Text.Show.show--whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()-whenJust m f = maybe (pure ()) f m--(!!) :: [a] -> Int -> Maybe a-xs !! i- | i < 0 = Nothing- | otherwise = headMay $ drop i xs---- | An infix form of 'fromMaybe' with arguments flipped.-(?:) :: Maybe a -> a -> a-maybeA ?: b = fromMaybe b maybeA-{-# INLINABLE (?:) #-}-infixr 0 ?:
ron-schema.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: ron-schema-version: 0.6+version: 0.7 bug-reports: https://github.com/ff-notes/ron/issues category: Distributed Systems, Protocol, Database@@ -15,29 +15,7 @@ description: Replicated Object Notation (RON), data types (RDT), and RON-Schema .- Typical usage:- .- > import RON.Data- > import RON.Schema.TH- > import RON.Storage.FS as Storage- >- > [mkReplicated|- > (struct_lww Note- > active Boole- > text RgaString)- > |]- >- > instance Collection Note where- > collectionName = "note"- >- > main :: IO ()- > main = do- > let dataDir = "./data/"- > h <- Storage.newHandle dataDir- > runStorage h $ do- > obj <- newObject- > Note{active = True, text = "Write a task manager"}- > createDocument obj+ Examples: https://github.com/ff-notes/ron/tree/master/examples build-type: Simple @@ -46,10 +24,8 @@ common language build-depends: base >= 4.10 && < 4.13, integer-gmp- default-extensions: MonadFailDesugaring StrictData+ default-extensions: MonadFailDesugaring NoImplicitPrelude StrictData default-language: Haskell2010- hs-source-dirs: prelude- other-modules: Prelude library import: language@@ -72,4 +48,6 @@ other-modules: Data.EDN.Extra RON.Schema.EDN+ RON.Schema.TH.Common+ RON.Schema.TH.Struct hs-source-dirs: lib