diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/lib/Data/EDN/Extra.hs b/lib/Data/EDN/Extra.hs --- a/lib/Data/EDN/Extra.hs +++ b/lib/Data/EDN/Extra.hs @@ -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 diff --git a/lib/RON/Schema.hs b/lib/RON/Schema.hs --- a/lib/RON/Schema.hs +++ b/lib/RON/Schema.hs @@ -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) 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 @@ -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 ...)" 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 ... ...)" @@ -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 )" 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 @@ -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) diff --git a/lib/RON/Schema/TH/Common.hs b/lib/RON/Schema/TH/Common.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Schema/TH/Common.hs @@ -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] diff --git a/lib/RON/Schema/TH/Struct.hs b/lib/RON/Schema/TH/Struct.hs new file mode 100644 --- /dev/null +++ b/lib/RON/Schema/TH/Struct.hs @@ -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" diff --git a/prelude/Prelude.hs b/prelude/Prelude.hs deleted file mode 100644 --- a/prelude/Prelude.hs +++ /dev/null @@ -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 ?: 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.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